home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a009 / 6.ddi / SAMPLE.LIF / DOT.PRG < prev    next >
Encoding:
Text File  |  1991-04-14  |  110.4 KB  |  5,362 lines
  1. ***
  2. * Dot.prg
  3. * Dot-prompt interpreter written in Clipper.
  4. * Copyright (c) 1986-1990 Nantucket Corp.  All rights reserved.
  5. * 
  6. * Kevin J. Shepherd
  7. * 
  8. * 
  9. * NOTE
  10. * ----
  11. * DOT is offered as an example of Clipper capabilities.  It does
  12. * not constitute a working dBASE interpreter.
  13. *
  14. *
  15. * PROGRAM OVERVIEW
  16. * ----------------
  17. * DOT is an interpreter for some of the commands in the Clipper command
  18. * set.  DOT consists of a stack, a parser to fill it, procedure driven
  19. * stack analyzers, list and expression building functions, command line
  20. * execution procedures, etc.
  21. *
  22. * After a command has been entered the verb analyzer checks the stack
  23. * for an equal sign after the first identifier.  If an assignment is
  24. * found, the analyzer procedure macro is set to "ASSIGN".  If not, the
  25. * analyzer searches the verb list for the existence of the first stack
  26. * item.  If a match is found, it is checked for correct abbreviation.
  27. * If it is correct, the analysis procedure macro is initialized to the
  28. * procedure name found in the analyzer procedure list.  If the item
  29. * was not found or failed the abbreviation test, the analyzer macro is
  30. * set to "UNKNOWN".  The analyzer procedure is used to set the Class
  31. * Execution procedure macro, execution flags and Command Line
  32. * Substitution macros.  If an assignment or a variable is to be
  33. * created or deleted, it is done next, in the top most level of DOT.
  34. * One of six Class Execution procedures is called next, based on what
  35. * was found on the stack.  The called procedure contains Clipper
  36. * command strings with substitution macros used in the variable
  37. * portion of the line.  The command is selected with the execution
  38. * flag set in the analyzer.  After the command has been executed, it
  39. * is placed into the History array.  The control variables and command
  40. * line macros are reset, and the loop returns to the top, ready for
  41. * another command.
  42. * 
  43. * What ever you want to do, DOT can be tailored to your needs by
  44. * adding PROCEDUREs and FUNCTIONs to form new commands.  A command can
  45. * be appended to DOT by adding the verb and the matching analysis
  46. * procedure name to the verb and analyzer lists. Next, decide on the
  47. * Class Execution procedure you want to execute your command in, and
  48. * add another DO CASE switch variable to the PUBLIC switch list at the
  49. * beginning of the DOT procedure.  The analysis procedure can be added
  50. * after you have selected the PROCEDURE and switch names.  These
  51. * procedures and/or functions that you define can be made up of any
  52. * combination of Clipper, "C", or ASSEMBLY routines. They, in turn,
  53. * are interfaced to DOT by using Clipper's EXTEND system and EXTERNAL
  54. * references. The EXTERNALs can either by added directly to DOT, your
  55. * .PRG file, or compiled as a seperate file and included in the link
  56. * line as an object module.
  57. *
  58.  
  59. clear
  60.  
  61. ** set CALLS class flags public **
  62. public CALLS1, CALLS2, CALLS3, CALLS4, CALLS5, CALLS6, CALLS7
  63.  
  64. ** set DBF_NTX class flags public **
  65. public DBF_NTX1, DBF_NTX2, DBF_NTX3, DBF_NTX4, DBF_NTX5, DBF_NTX6
  66. public DBF_NTX7, DBF_NTX8, DBF_NTX9, DBF_NTX10, DBF_NTX11, DBF_NTX12
  67. public DBF_NTX13, DBF_NTX14, DBF_NTX15, DBF_NTX16, DBF_NTX17, DBF_NTX18
  68. public DBF_NTX19, DBF_NTX20, DBF_NTX21, DBF_NTX22, DBF_NTX23, DBF_NTX24
  69. public DBF_NTX25, DBF_NTX26, DBF_NTX27, DBF_NTX28, DBF_NTX29, DBF_NTX30
  70. public DBF_NTX31, DBF_NTX32, DBF_NTX33, DBF_NTX34, DBF_NTX35, DBF_NTX36
  71.  
  72. ** set ERRS class flags public **
  73. public ERRS1, ERRS2, ERRS3, ERRS4, ERRS5, ERRS6, ERRS7, ERRS8, ERRS9
  74. public ERRS10, ERRS11, ERRS12, ERRS13, ERRS14, ERRS15
  75.  
  76. ** set SCRN class flags public **
  77. public SCRN1, SCRN2, SCRN3, SCRN4, SCRN5, SCRN6, SCRN7, SCRN8, SCRN9
  78. public SCRN10, SCRN11, SCRN12, SCRN13, SCRN14, SCRN15, SCRN16, SCRN17
  79. public SCRN18, SCRN19, SCRN20, SCRN21, SCRN22, SCRN23, SCRN24, SCRN25
  80. public SCRN26, SCRN27, SCRN28
  81.  
  82. ** set SETS class flags public **
  83. public SETS1, SETS2, SETS3, SETS4, SETS5, SETS6, SETS7, SETS8, SETS9
  84. public SETS10, SETS11, SETS12, SETS13, SETS14, SETS15, SETS16, SETS17
  85. public SETS18, SETS19, SETS20, SETS21, SETS22
  86.  
  87. ** set VARS class flags public **
  88. public VARS1, VARS2, VARS3, VARS4, VARS5, VARS6, VARS7, VARS8, VARS9
  89. public VARS10, VARS11, VARS12
  90.  
  91. ** set data and index file status flags public **
  92. public DBF_OPEN, NTX_OPEN
  93.  
  94. ** set command line execution macro variables public **
  95. public box_exp, coord1, coord2, coord3, coord4, dbf_file, dest, exp1
  96. public exp2, exp3, get_exp, get_pict, list0, list1, list2, list3, list4
  97. public list5, list6, list7, list8, list9, ntx_file, rng_exp1, rng_exp2
  98. public say_exp, say_pict, source, var1
  99.  
  100. ** set non-releasable macro variables **
  101. public alias, filter, range1, range2, relation, valid_exp
  102.  
  103. ** initialize non-releasable macro variables **
  104. store "" to alias, filter, range1, range2, relation, valid_exp
  105.  
  106. ** set conditional and scoping system variables public **
  107. public condition, rewind_dbf, scope
  108.  
  109. ** set internal status flags public **
  110. public color_stat, confr_stat, delim_stat, exact_stat, inten_stat
  111.  
  112. ** initialize internal status flags **
  113. color_stat = "7/0"
  114. confr_stat = "OFF"
  115. delim_stat = "OFF"
  116. exact_stat = "OFF"
  117. inten_stat = "ON"
  118.  
  119. ** set internal control variables public **
  120. public bottom_on, cmd_line, error_on, executor, hist_max, lex_proc
  121. public lex_list, max_hist, save_col, save_row, set_list, set_proc
  122. public stack_size, verb_list, dot_vers
  123.  
  124. ** initialize internal search list variables **
  125. do fill_lists
  126.  
  127. ** initialize internal control variables **
  128. bottom_on = .T.
  129. cmd_line = replicate("°", 80)
  130. error_on = .T.
  131. save_col = 0
  132. save_row = 0
  133. stack_size = 30
  134.  
  135. ** initialize the history variables **
  136. hist_max = 0
  137. max_hist = 20
  138. declare history[max_hist]
  139. dot_vers = "10/27/86"
  140.  
  141.  
  142. ** 5.0 error handler (see end of source file) **
  143. public SysErrorBlock := ErrorBlock( {|e| DotError(e)} )
  144.  
  145.  
  146. quit_now = .F.
  147.  
  148. do while !quit_now
  149.  
  150.     ** reset command line execution macro variables **
  151.     store "" to box_exp, coord1, coord2, coord3, coord4
  152.     store "" to dbf_file, dest, exp1, exp2, exp3
  153.     store "" to get_exp, get_pict, ntx_file, rng_exp1, rng_exp2
  154.     store "" to say_exp, say_pict, source, var1
  155.     store "" to list0, list1, list2, list3, list4
  156.     store "" to list5, list6, list7, list8, list9
  157.  
  158.  
  159.     begin sequence
  160.  
  161.         declare stack[stack_size]        && initialize STACK.
  162.         stack_ptr = 0                    && initialize stack element pointer.
  163.         max_ptr = 0                      && initialize stack element counter.
  164.  
  165.         lex_proc = ""                    && initialize analyzer macro.
  166.         executor = ""                    && initialize "class" executor macro.
  167.  
  168.         ** set PROMPT environment quantity **
  169.         set color to
  170.         set delimiters OFF
  171.         set confirm OFF
  172.         set exact OFF
  173.  
  174.         if bottom_on
  175.             do input_ln with "B"         && prompt at bottom of screen.
  176.         endif
  177.  
  178.         ** set HELP and HISTORY call keys **
  179.         set key 28 to help
  180.         set key 5 to history
  181.  
  182.         accept ". " to command           && get input from keyboard.
  183.  
  184.         do hist_put                      && place command into HISTORY array.
  185.  
  186.         command = "&command"             && expand all macros in string
  187.  
  188.         set key 5 to                     && turn OFF HISTORY mode.
  189.  
  190.         if bottom_on
  191.             do input_ln with "A"         && cursor to last display position.
  192.         endif
  193.  
  194.         do parse                         && call "stack" population routine.
  195.         max_ptr = stack_ptr              && assign maximum stack elements.
  196.  
  197.         if max_ptr > 0                   && stack elements exist.
  198.             if !err()                    && NO errors occurred in parser.
  199.                 do set_lex               && do analyzer macro set procedure.
  200.                 do &lex_proc             && do the analyze procedure macro.
  201.  
  202.                 if CALLS7
  203.                     quit_now = .t.
  204.                     break
  205.                 endif
  206.  
  207.                 if executor = "VARS"
  208.                     ** check for variable creation or release activity. **
  209.                     do case
  210.                         case VARS9
  211.                             ** if a variable is to be created **
  212.                             &var1 = &exp2
  213.                             VARS9 = .F.
  214.  
  215.                         case VARS10
  216.                             ** if an array is to be created **
  217.                             declare &var1[&exp1]
  218.                             VARS10 = .F.
  219.  
  220.                         case VARS11
  221.                             ** if a variable is to be released **
  222.                             release &var1
  223.                             VARS11 = .F.
  224.  
  225.                         case VARS12
  226.                             ** if an array is assigned a value **
  227.                             &var1[&exp1] = &exp2
  228.                             VARS12 = .F.
  229.                     endcase
  230.                 endif
  231.             endif
  232.  
  233.             if err()
  234.                 executor = "ERRS"        && set error executor procedure.
  235.             endif
  236.  
  237.  
  238.             ** set EXECUTION environment **
  239.             set color to &color_stat
  240.             set delimiters &delim_stat
  241.             set confirm &confr_stat
  242.             set exact &exact_stat
  243.  
  244.             do &executor                 && do execution procedure.
  245.  
  246.  
  247.         endif
  248.  
  249.     recover
  250.         ** this is just here to reset the parser **
  251.         command := '? ""'
  252.         do parse
  253.  
  254.     end
  255.  
  256. enddo
  257.  
  258. *
  259. ** eoproc dot.prg
  260.  
  261.  
  262. *******************
  263. * Dot procedures. *
  264. *******************
  265.  
  266.  
  267. ***
  268. * Procedure ACCEPT
  269. * kjs, 04/29/86, 10/08/86
  270. * Evaluates stack for ACCEPT verb.
  271. * Sets execution class macro, class execution flag(s) and command line
  272. * substitution macros.
  273. *
  274.  
  275. procedure accept
  276.  
  277. private stack_ptr, stack_item, item_ok, string, to, dest, active, error
  278.  
  279. stack_ptr = 2
  280. store .F. to string, to, dest, item_ok
  281. active = 1        && 0 = done, 1 = string, 2 = TO token, 3 = expression.
  282. error = 0
  283.  
  284. do while stack_ptr <= max_ptr .and. error = 0
  285.  
  286.     stack_item = ""
  287.     item_ok = get_stack("stack_item")
  288.  
  289.     do case 
  290.         case active = 0 .or. !item_ok
  291.             error = 2
  292.  
  293.         case active = 1
  294.             if !(upper(stack_item) == "TO")
  295.                 exp1 = stack_item
  296.                 string = .T.
  297.                 active = 2
  298.             else
  299.                 to = .T.    
  300.                 active = 3
  301.             endif
  302.  
  303.         case active = 2
  304.             if upper(stack_item) == "TO"
  305.                 to = .T.
  306.                 active = 3
  307.             else
  308.                 error = 15
  309.             endif
  310.  
  311.         case active = 3    
  312.             var1 = stack_item
  313.             dest = .T.
  314.             active = 0
  315.     endcase
  316. enddo
  317.  
  318. do case
  319.     case error = 2 .or. active <> 0
  320.         ERRS2 = .T.
  321.  
  322.     case error = 15
  323.         ERRS15 = .T.
  324.  
  325.     case to .and. dest .and. !string
  326.         executor = "VARS"
  327.         VARS1 = .T.
  328.         VARS9 = .T.
  329.  
  330.     case to .and. dest .and. string
  331.         executor = "VARS"
  332.         VARS2 = .T.
  333.         VARS9 = .T.
  334. endcase
  335.  
  336. return
  337.  
  338. *
  339. ** eoproc accept
  340.  
  341.  
  342. ***
  343. * Procedure APPEND
  344. * kjs, 05/01/86, 10/08/86
  345. * Evaluates stack for APPEND verb.
  346. * Sets execution class macro, class execution flag(s) and command line
  347. * substitution macros.
  348. *
  349.  
  350. procedure append
  351.  
  352. private stack_ptr, stack_item, item_ok, blank, file, from, active, error
  353.  
  354. stack_ptr = 2
  355. store .F. to blank, file, from, item_ok
  356. active = 0        && 0 = done, 1 = BLANK or FROM toke, 2 = source.
  357. error = 0
  358.  
  359. if error_on .and. !dbf_open
  360.     error = 5
  361. else
  362.     active = 1
  363. endif
  364.  
  365. do while stack_ptr <= max_ptr .and. error = 0
  366.  
  367.     stack_item = ""
  368.     item_ok = get_stack("stack_item")
  369.  
  370.     do case
  371.         case active = 0
  372.             error = 2
  373.  
  374.         case active = 1
  375.             do case
  376.                 case cmd_abbr(upper(stack_item), "BLANK")
  377.                     blank = .T.
  378.                     active = 0
  379.  
  380.                 case upper(stack_item) == "FROM"
  381.                     from = .T.
  382.                     active = 2
  383.  
  384.                 otherwise
  385.                     error = 2    
  386.             endcase
  387.  
  388.         case active = 2
  389.             exp1 = stack_item
  390.             if error_on
  391.                 if if("."$exp1, file(exp1), file("&exp1..dbf"))
  392.                     file = .T.
  393.                 else
  394.                     error = 13
  395.                 endif
  396.             else
  397.                 file = .T.
  398.             endif
  399.             active = 0
  400.     endcase
  401. enddo
  402.  
  403. do case
  404.     case error = 2 .or. active <> 0
  405.         ERRS2 = .T.
  406.  
  407.     case error = 5
  408.         ERRS5 = .T.
  409.  
  410.     case error = 13
  411.         ERRS13 = .T.
  412.  
  413.     case blank
  414.         executor = "DBF_NTX"
  415.         DBF_NTX18 = .T.
  416.  
  417.     case from .and. file
  418.         executor = "DBF_NTX"
  419.         DBF_NTX31 = .T.
  420. endcase
  421.  
  422. return
  423.  
  424. *
  425. ** eoproc append
  426.  
  427.  
  428. **
  429. * Procedure ASSIGN
  430. * kjs, 04/22/86
  431. * Evaluates stack for assignment operator "=".
  432. * Sets execution class macro, class execution flag(s) and command line
  433. * substitution macros.
  434. *
  435.  
  436. procedure assign
  437.  
  438. private stack_ptr, equal, exp, array
  439.  
  440. stack_ptr = 1
  441. store .F. to equal, exp, array
  442.  
  443. do while stack_ptr <= max_ptr
  444.     do case
  445.         case stack_ptr = 1
  446.             var1 = stack[stack_ptr]
  447.             stack_ptr = stack_ptr + 1
  448.             if stack_ptr <= max_ptr
  449.                 if "["$stack[stack_ptr]
  450.                     var1 = var1 + stack[stack_ptr]
  451.                     stack_ptr = stack_ptr + 1
  452.                 endif
  453.             endif
  454.             if "["$var1
  455.                 string = var1
  456.                 var1 = ""
  457.                 open_ptr = at("[",string)
  458.                 close_ptr = at("]",string)
  459.                 var1 = substr(string, 1, (open_ptr - 1))
  460.                 exp1 = substr(string,(open_ptr+1),(close_ptr-open_ptr-1))
  461.                 array = .T.
  462.             endif
  463.  
  464.         case stack[stack_ptr] = "="
  465.             equal = .T.
  466.             exp = get_expr1("exp2")
  467.     endcase
  468. enddo
  469.  
  470. if equal
  471.     if exp
  472.         executor = "VARS"
  473.         if array
  474.             VARS12 = .T.
  475.         else
  476.             VARS9 = .T.
  477.         endif
  478.     else
  479.        ERRS2 = .F.
  480.     endif
  481. else
  482.     ERRS1 = .T.
  483. endif
  484.  
  485. return
  486.  
  487. *
  488. ** eoproc assign
  489.  
  490.  
  491. ***
  492. * Procedure AT
  493. * kjs, 04/22/86
  494. * Evaluates stack for @ token.
  495. * Sets execution class macro, class execution flag(s) and command line
  496. * substitution macros.
  497. *
  498.  
  499. procedure at
  500.  
  501. set exact on
  502.  
  503. private at, clear, box, say, say_part, get, get_part, pic1, pic2, range,;
  504.     valid, xy, tlbr, co_num, stack_ptr, stack_item, active, null
  505.  
  506. store .F. to at, clear, box, say, say_part, get, get_part, pic1, pic2,;
  507.     range, valid, xy, tlbr
  508.  
  509. co_num = "1"
  510. stack_ptr = 1
  511. active = 1        && 0 = done, 1 = processing say, 2 = processing get.
  512.  
  513. do while stack_ptr <= max_ptr .and. !err()
  514.  
  515.     stack_item = upper(stack[stack_ptr])
  516.  
  517.     do case
  518.         case stack_item = "@"
  519.             null = get_expr1("coord&co_num")
  520.             co_num = str(val(co_num)+1,1)
  521.  
  522.         case stack_item = ","
  523.             null = get_expr1("coord&co_num")
  524.             co_num = str(val(co_num)+1,1)
  525.  
  526.         case stack_item = "BOX"
  527.             box = .T.
  528.             null = get_expr1("box_exp")
  529.  
  530.         case stack_item = "SAY"
  531.             active = 1
  532.             say = .T.
  533.             say_part = get_expr1("say_exp")
  534.  
  535.         case stack_item = "GET"
  536.             active = 2
  537.             get = .T.
  538.             get_part = get_expr1("get_exp")
  539.  
  540.         case cmd_abbr(stack_item, "PICTURE")
  541.             do case
  542.                 case say .and. !get
  543.                     pic1 = .T.
  544.                     null = get_expr1("say_pict")
  545.  
  546.                 case get .and. !say
  547.                     pic2 = .T.
  548.                     null = get_expr1("get_pict")
  549.  
  550.                 case say .and. get
  551.                     if active = 1        && if processing a say.
  552.                         pic1 = get_expr1("say_pict")
  553.                     else                 && if processing a get.
  554.                         pic2 = get_expr1("get_pict")
  555.                     endif
  556.  
  557.                 otherwise
  558.                     ERRS2 = .T.
  559.             endcase
  560.  
  561.         case cmd_abbr(stack_item, "CLEAR")
  562.             clear = .T.
  563.             stack_ptr = stack_ptr + 1
  564.  
  565.         case cmd_abbr(stack_item, "RANGE")
  566.             range = .T.
  567.             null = get_expr1("rng_exp1")
  568.             null = get_expr1("rng_exp2")
  569.  
  570.         case cmd_abbr(stack_item, "VALID")
  571.             valid = .T.
  572.             null = get_expr1("valid_exp")
  573.  
  574.         otherwise
  575.             ERRS2 = .T.
  576.     endcase
  577. enddo
  578.  
  579. set exact &exact_stat
  580.  
  581. if !err()
  582.  
  583.     if !empty(coord1) .and. !empty(coord2)
  584.         if !empty(coord3) .and. !empty(coord4)
  585.             tlbr = .T.
  586.         else
  587.             xy = .T.
  588.         endif
  589.     else
  590.         ERRS2 = .T.
  591.     endif
  592.  
  593.     do case
  594.         case xy .and. !say .and. !get .and. !clear .and. !box
  595.             executor = "SCRN"
  596.             SCRN1 = .T.
  597.     
  598.         case xy .and. clear .and. !say .and. !get .and. !box
  599.             executor = "SCRN"
  600.             SCRN2 = .T.
  601.  
  602.         case xy .and. say .and. !get
  603.             do case
  604.                 case !say_part
  605.                     ERRS2 = .T.
  606.  
  607.                 case !pic1 .and. !clear .and. !range .and. !valid
  608.                     executor = "SCRN"
  609.                     SCRN3 = .T.
  610.  
  611.                 case pic1 .and. !clear .and. !range .and. !valid
  612.                     executor = "SCRN"
  613.                     SCRN4 = .T.
  614.  
  615.                 otherwise
  616.                     ERRS1 = .T.
  617.             endcase
  618.  
  619.         case xy .and. get .and. !say
  620.             do case
  621.                 case !get_part
  622.                     ERRS2 = .T.
  623.  
  624.                 case !pic2 .and. !range .and. !valid
  625.                     executor = "SCRN"
  626.                     SCRN5 = .T.
  627.  
  628.                 case pic2 .and. !range .and. !valid
  629.                     executor = "SCRN"
  630.                     SCRN6 = .T.
  631.  
  632.                 case !pic2 .and. range .and. !valid
  633.                     executor = "SCRN"
  634.                     SCRN7 = .T.
  635.  
  636.                 case !pic2 .and. !range .and. valid
  637.                     executor = "SCRN"
  638.                     SCRN8 = .T.
  639.  
  640.                 case pic2 .and. !range .and. valid
  641.                     executor = "SCRN"
  642.                     SCRN10 = .T.
  643.  
  644.                 case pic2 .and. range .and. !valid
  645.                     executor = "SCRN"
  646.                     SCRN11 = .T.
  647.  
  648.                 otherwise
  649.                     ERRS2 = .T.
  650.             endcase
  651.  
  652.         case xy .and. say .and. get
  653.             do case
  654.                 case !say_part .or. !get_part
  655.                     ERRS2 = .T.
  656.  
  657.                 case !pic1 .and. !pic2 .and. !range .and. !valid
  658.                     executor = "SCRN"
  659.                     SCRN13 = .T.
  660.  
  661.                 case pic1 .and. !pic2 .and. !range .and. !valid
  662.                     executor = "SCRN"
  663.                     SCRN14 = .T.
  664.  
  665.                 case pic1 .and. pic2 .and. !range .and. !valid
  666.                     executor = "SCRN"
  667.                     SCRN15 = .T.
  668.  
  669.                 case pic1 .and. pic2 .and. range .and. !valid
  670.                     executor = "SCRN"
  671.                     SCRN16 = .T.
  672.  
  673.                 case pic1 .and. pic2 .and. !range .and. valid
  674.                     executor = "SCRN"
  675.                     SCRN17 = .T.
  676.  
  677.                 case !pic1 .and. pic2 .and. !range .and. !valid
  678.                     executor = "SCRN"
  679.                     SCRN19 = .T.
  680.  
  681.                 case !pic1 .and. pic2 .and. range .and. !valid
  682.                     executor = "SCRN"
  683.                     SCRN20 = .T.
  684.  
  685.                 case !pic1 .and. pic2 .and. !range .and. valid
  686.                     executor = "SCRN"
  687.                     SCRN21 = .T.
  688.  
  689.                 otherwise
  690.                     ERRS2 = .T.
  691.             endcase
  692.  
  693.         case tlbr .and. box
  694.             executor = "SCRN"
  695.             SCRN22 = .T.
  696.  
  697.         otherwise
  698.             ERRS1 = .T.
  699.     endcase
  700. endif
  701.  
  702. return
  703.  
  704. *
  705. ** eoproc at
  706.  
  707.  
  708. ***
  709. * Procedure CALL
  710. * kjs, 05/28/86, 10/08/86
  711. * Evaluates stack for CALL verb.
  712. * Sets execution class macro, class execution flag(s) and command line
  713. * substitution macros.
  714. *
  715.  
  716. procedure call
  717.  
  718. private stack_ptr, stack_item, xproc, with, params, active, error,;
  719.   item_ok
  720.  
  721. stack_ptr = 2
  722. store .F. to xproc, with, params, item_ok
  723. active = 1       && 0 = done, 1 = procedure, 2 = WITH toke and params.
  724. error = 0
  725.  
  726. do while stack_ptr <= max_ptr .and. error = 0
  727.  
  728.     stack_item = ""
  729.     stack_item = stack[stack_ptr]
  730.  
  731.     do case
  732.         case active = 0
  733.             error = 2
  734.  
  735.         case active = 1
  736.             exp1 = stack_item
  737.             xproc = .T.
  738.             stack_ptr = stack_ptr + 1
  739.             if stack_ptr > max_ptr
  740.                 active = 0
  741.             else
  742.                 active = 2
  743.             endif
  744.  
  745.         case active = 2
  746.             if upper(stack_item) = "WITH"
  747.                 with = .T.
  748.                 params = get_list("E")
  749.                 if params
  750.                     active = 0
  751.                 else
  752.                     error = 2
  753.                 endif
  754.             else
  755.                 error = 2
  756.             endif
  757.     endcase
  758. enddo
  759.  
  760. do case
  761.     case error = 2 .or. active <> 0
  762.         ERRS2 = .T.
  763.  
  764.     case xproc .and. !with .and. !params
  765.         executor = "CALLS"
  766.         CALLS4 = .T.
  767.  
  768.     case xproc .and. with .and. params
  769.         executor = "CALLS"
  770.         CALLS5 = .T.
  771. endcase
  772.  
  773. return
  774.  
  775. *
  776. ** eoproc call
  777.  
  778.  
  779. ***    
  780. * Procedure CLEAR
  781. * kjs, 04/22/86
  782. * Evaluates stack for CLEAR verb.
  783. * Sets execution class macro, class execution flag(s) and command line
  784. * substitution macros.
  785. *
  786.  
  787. procedure clear
  788.  
  789. if stack_ptr = 1
  790.     executor = "SCRN"
  791.     SCRN23 = .T.
  792. else
  793.     ERRS2 = .T.
  794. endif
  795.  
  796. return
  797.  
  798. *
  799. ** eoproc clear
  800.  
  801.  
  802. ***
  803. * Procedure COLOR
  804. * kjs, 05/02/86
  805. * Evaluates stack for SET COLOR command, called from SET procedure.
  806. * Sets execution class macro, class execution flag(s) and command line
  807. * substitution macros.
  808. *
  809.  
  810. procedure color
  811.  
  812. private stack_ptr, to
  813.  
  814. stack_ptr = 3
  815. to = .F.
  816.  
  817. if stack_ptr <= max_ptr
  818.     if upper(stack[stack_ptr]) = "TO"
  819.         to = .T.
  820.         stack_ptr = stack_ptr + 1
  821.         do while stack_ptr <= max_ptr         && build up color string.
  822.             exp1 = exp1 + stack[stack_ptr]
  823.             stack_ptr = stack_ptr + 1
  824.         enddo
  825.     endif
  826. endif
  827.  
  828. if to
  829.     executor = "SETS"
  830.     SETS1 = .T.
  831. else
  832.     ERRS2 = .T.
  833. endif
  834.  
  835. return
  836.  
  837. *
  838. ** eoproc color
  839.  
  840.  
  841. ***
  842. * Procedure COPY
  843. * kjs, 09/16/86
  844. * Evaluates stack for COPY verb.
  845. * Simple non-conditional and non-scoped syntax.
  846. * Sets execution class macro, class execution flag(s) and command line
  847. * substitution macros.
  848. *
  849.  
  850. procedure copy
  851.  
  852. private stack_ptr, stack_item, item_ok, struc, to, target, active, error
  853.  
  854. stack_ptr = 2
  855. store .F. to struc, to, target, item_ok
  856. active = 0            && 0 = done, 1 = STRU or TO toke, 2 = target.
  857. error = 0
  858.  
  859. if error_on .and. !DBF_OPEN
  860.     error = 5
  861. else
  862.     active = 1
  863. endif
  864.  
  865. do while stack_ptr <= max_ptr .and. error = 0
  866.  
  867.     stack_item = ""
  868.     item_ok = get_stack("stack_item")
  869.  
  870.     do case
  871.         case active = 0
  872.             error = 2
  873.  
  874.         case active = 1
  875.             do case 
  876.                 case cmd_abbr(upper(stack_item), "STRUCTURE") .and. !struc
  877.                     struc = .T.
  878.                     active = 1
  879.  
  880.                 case upper(stack_item) == "TO"
  881.                     to = .T.
  882.                     active = 2
  883.  
  884.                 otherwise
  885.                     error = 2
  886.             endcase
  887.  
  888.         case active = 2
  889.             exp1 = stack_item
  890.             target = .T.
  891.             active = 0
  892.     endcase
  893. enddo
  894.  
  895. do case
  896.     case error = 2 .or. active <> 0
  897.         ERRS2 = .T.
  898.  
  899.     case error = 5
  900.         ERRS5 = .T.
  901.  
  902.     case !struc .and. to .and. target
  903.         executor = "DBF_NTX"
  904.         DBF_NTX28 = .T.
  905.  
  906.     case struc .and. to .and. target
  907.         executor = "DBF_NTX"
  908.         DBF_NTX29 = .T.
  909.  
  910.     otherwise
  911.         ERRS2 = .T.
  912. endcase
  913.  
  914. return
  915.  
  916. *
  917. ** eoproc copy
  918.  
  919.  
  920. ***
  921. * Procedure CONFIRM
  922. * kjs, 04/28/86, 10/08/86
  923. * Evaluates stack for SET CONFIRM command.  Called procedure SET.
  924. * Sets execution class macro, class execution flag(s) and command line
  925. * substitution macros.
  926. *
  927.  
  928. procedure confirm
  929.  
  930. private stack_ptr, stack_item, item_ok, toggle
  931.  
  932. stack_ptr = 3
  933. stack_item = ""
  934. store .F. to item_ok, toggle
  935.  
  936. item_ok = get_stack("stack_item")
  937.  
  938. if item_ok .and. upper(stack_item)$"ON^OFF"
  939.     toggle = .T.
  940. else
  941.     error = 2
  942. endif
  943.  
  944. if toggle
  945.     executor = "SETS"
  946.     SETS2 = .T.
  947. else
  948.     ERRS2 = .T.
  949. endif
  950.  
  951. return
  952.  
  953. *
  954. ** eoproc confirm
  955.  
  956.  
  957. ***
  958. * Procedure calls
  959. * kjs, 06/12/86
  960. * Executor for CALLS class of commands.
  961. *
  962.  
  963. procedure calls
  964.  
  965. private i, qqq
  966.  
  967. do case
  968.     case CALLS1
  969.         do &exp1
  970.         CALLS1 = .F.
  971.  
  972.     case CALLS2
  973.         for i = 0 to 9
  974.             qqq = "list"+str(i,1)
  975.             if (empty(&qqq))
  976.                 &qqq = "[]"
  977.             end
  978.         next
  979.  
  980.         do &exp1 with &list0, &list1, &list2, &list3, &list4, &list5, &list6,;
  981.             &list7, &list8, &list9
  982.         CALLS2 = .F.
  983.  
  984.     case CALLS3
  985.         run &exp1
  986.         ?
  987.         CALLS3 = .F.
  988.  
  989.     case CALLS4
  990.         call &exp1
  991.         CALLS4 = .F.
  992.  
  993.     case CALLS5
  994.         for i = 0 to 9
  995.             qqq = "list"+str(i,1)
  996.             if (empty(&qqq))
  997.                 &qqq = "[]"
  998.             end
  999.         next
  1000.  
  1001.         call &exp1 with &list0, &list1, &list2, &list3, &list4, &list5, &list6
  1002.         CALLS5 = .F.
  1003.  
  1004.     case CALLS6
  1005.         quit
  1006.         CALLS6 = .F.
  1007.  
  1008.     case CALLS7
  1009.         ** RETURN is not executed at this level **
  1010.  
  1011. endcase
  1012.  
  1013. return
  1014.  
  1015. *
  1016. ** eoproc calls
  1017.  
  1018.  
  1019. ***
  1020. * Procedure dbf_ntx
  1021. * kjs, 06/12/86
  1022. * Executor for DBF_NTX class of commands.
  1023. *
  1024.  
  1025. procedure dbf_ntx
  1026.  
  1027. private more, disp_row, i, qqq
  1028.  
  1029. do case
  1030.     case DBF_NTX1 
  1031.         use
  1032.         DBF_NTX1 = .F.
  1033.         DBF_OPEN = .F.
  1034.         NTX_OPEN = .F.
  1035.  
  1036.     case DBF_NTX2
  1037.         use &dbf_file
  1038.         DBF_NTX2 = .F.
  1039.         DBF_OPEN = .T.
  1040.         NTX_OPEN = .F.
  1041.  
  1042.     case DBF_NTX3
  1043.         use &dbf_file index &list0, &list1, &list2, &list3, &list4, &list5,;
  1044.             &list6, &list7, &list8, &list9
  1045.         DBF_NTX3 = .F.
  1046.         DBF_OPEN = .T.
  1047.         NTX_OPEN = .T.
  1048.  
  1049.     case DBF_NTX4
  1050.         use &dbf_file alias &exp2
  1051.         DBF_NTX4 = .F.
  1052.         DBF_OPEN = .T.
  1053.         NTX_OPEN = .F.
  1054.  
  1055.     case DBF_NTX5
  1056.         use &dbf_file index &list0, &list1, &list2, &list3, &list4, &list5,;
  1057.             &list6, &list7, &list8, &list9 alias &exp2
  1058.         DBF_NTX5 = .F.
  1059.         DBF_OPEN = .T.
  1060.         NTX_OPEN = .T.
  1061.  
  1062.     case DBF_NTX32
  1063.         use &dbf_file exclusive
  1064.         DBF_NTX32 = .F.
  1065.         DBF_OPEN = .T.
  1066.         NTX_OPEN = .F.
  1067.  
  1068.     case DBF_NTX33
  1069.         use &dbf_file index &list0, &list1, &list2, &list3, &list4, &list5,;
  1070.             &list6, &list7, &list8, &list9 exclusive
  1071.         DBF_NTX33 = .F.
  1072.         DBF_OPEN = .T.
  1073.         NTX_OPEN = .T.
  1074.  
  1075.     case DBF_NTX34
  1076.         use &dbf_file alias &exp2 exclusive
  1077.         DBF_NTX34 = .F.
  1078.         DBF_OPEN = .T.
  1079.         NTX_OPEN = .F.
  1080.  
  1081.     case DBF_NTX35
  1082.         use &dbf_file index &list0, &list1, &list2, &list3, &list4, &list5,;
  1083.             &list6, &list7, &list8, &list9 alias &exp2 exclusive
  1084.         DBF_NTX35 = .F.
  1085.         DBF_OPEN = .T.
  1086.         NTX_OPEN = .T.
  1087.  
  1088.     case DBF_NTX6
  1089.         ? "Indexing file on " + upper(exp1) + " to " + upper(ntx_file)
  1090.         index on &exp1 to &ntx_file
  1091.         ? "Index file creation complete"
  1092.         NTX_OPEN = .T.
  1093.         DBF_NTX6 = .F.
  1094.  
  1095.     case DBF_NTX7
  1096.         goto &exp1
  1097.         DBF_NTX7 = .F.
  1098.  
  1099.     case DBF_NTX8
  1100.         goto top
  1101.         DBF_NTX8 = .F.
  1102.  
  1103.     case DBF_NTX9
  1104.         goto bottom
  1105.         DBF_NTX9 = .F.
  1106.  
  1107.     case DBF_NTX10
  1108.         skip
  1109.         if EOF()
  1110.             ? "End of file encountered"
  1111.         endif
  1112.         if BOF()
  1113.             ? "Beginning of file encountered"
  1114.         endif
  1115.         DBF_NTX10 = .F.
  1116.  
  1117.     case DBF_NTX11
  1118.         skip &exp1
  1119.         if EOF()
  1120.             ? "End of file encountered"
  1121.         endif
  1122.         if BOF()
  1123.             ? "Beginning of file encountered"
  1124.         endif
  1125.         DBF_NTX11 = .F.
  1126.  
  1127.     case DBF_NTX12
  1128.         go top
  1129.         do list_do with .T., .F.
  1130.         DBF_NTX12 = .F.
  1131.  
  1132.     case DBF_NTX13
  1133.         go top
  1134.         for i = 0 to 9
  1135.             qqq = "list"+str(i,1)
  1136.             if (empty(&qqq))
  1137.                 &qqq = "[]"
  1138.             end
  1139.         next
  1140.  
  1141.         list &list0, &list1, &list2, &list3, &list4, &list5, &list6, &list7,;
  1142.             &list8, &list9 while inkey() <> 27
  1143.         DBF_NTX13 = .F.
  1144.  
  1145.     case DBF_NTX14
  1146.         do list_do with .T., .T.
  1147.         DBF_NTX14 = .F.
  1148.  
  1149.     case DBF_NTX15
  1150.         for i = 0 to 9
  1151.             qqq = "list"+str(i,1)
  1152.             if (empty(&qqq))
  1153.                 &qqq = "[]"
  1154.             end
  1155.         next
  1156.  
  1157.         display &list0, &list1, &list2, &list3, &list4, &list5, &list6,;
  1158.             &list7, &list8, &list9
  1159.         DBF_NTX15 = .F.
  1160.  
  1161.     case DBF_NTX16
  1162.         select &exp1
  1163.         DBF_NTX16 = .F.
  1164.  
  1165.     case DBF_NTX17
  1166.         seek &exp1
  1167.         if eof()
  1168.             ? "NOT Found"
  1169.         else
  1170.             ? "Found"
  1171.         endif
  1172.         DBF_NTX17 = .F.
  1173.  
  1174.     case DBF_NTX18
  1175.         append blank
  1176.         DBF_NTX18 = .F.
  1177.  
  1178.     case DBF_NTX19
  1179.         do do_cnd_scp with "delete_it"  && calls condition/scope logic.
  1180.         DBF_NTX19 = .F.
  1181.  
  1182.     case DBF_NTX22
  1183.         dir &exp1
  1184.         DBF_NTX22 = .F.
  1185.  
  1186.     case DBF_NTX20
  1187.         do do_cnd_scp with "recall_it"  && calls condition/scope logic.
  1188.         DBF_NTX20 = .F.
  1189.  
  1190.     case DBF_NTX21
  1191.         pack
  1192.         DBF_NTX21 = .F.
  1193.  
  1194.     case DBF_NTX23
  1195.         type &exp1
  1196.         DBF_NTX23 = .F.
  1197.  
  1198.     case DBF_NTX24
  1199.         unlock
  1200.         DBF_NTX24 = .F.
  1201.  
  1202.     case DBF_NTX25
  1203.         unlock all
  1204.         DBF_NTX25 = .F.
  1205.  
  1206.     case DBF_NTX26
  1207.         replace &var1 with &exp1
  1208.         DBF_NTX26 = .F.
  1209.  
  1210.     case DBF_NTX27
  1211.         replace all &var1 with &exp1
  1212.         DBF_NTX27 = .F.
  1213.  
  1214.     case DBF_NTX28
  1215.         copy to &exp1
  1216.         DBF_NTX28 = .F.
  1217.  
  1218.     case DBF_NTX29
  1219.         copy structure to &exp1
  1220.         DBF_NTX29 = .F.
  1221.  
  1222.     case DBF_NTX30
  1223.         erase &exp1
  1224.         DBF_NTX30 = .F.
  1225.  
  1226.     case DBF_NTX31
  1227.         append from &exp1
  1228.         DBF_NTX31 = .F.
  1229.  
  1230.   case DBF_NTX36
  1231.      ? "Are you sure? (Y/N)" 
  1232.      more = .T.
  1233.      disp_row = row()
  1234.  
  1235.      do while more
  1236.         more = !(ltrim(str(inkey(0),3))$"13^27^78^89^110^121")
  1237.         if lastkey() > 31 .and. lastkey() < 127
  1238.            @ disp_row, 21 say chr(lastkey()) 
  1239.         endif
  1240.      enddo
  1241.  
  1242.      if upper(chr(lastkey())) = "Y"
  1243.         zap
  1244.      endif
  1245.  
  1246.      DBF_NTX36 = .F.
  1247.  
  1248. endcase
  1249.  
  1250. return
  1251.  
  1252. *
  1253. ** eoproc dbf_ntx
  1254.  
  1255.  
  1256. ***
  1257. * Procedure DECIMAL
  1258. * kjs, 04/28/86, 10/08/86
  1259. * Evaluates the stack for the SET DECIMALS command.  Called SET procedure.
  1260. * Sets execution class macro, class execution flag(s) and command line
  1261. * substitution macros.
  1262. *
  1263.  
  1264. procedure decimal
  1265.  
  1266. private stack_ptr, to, null
  1267.  
  1268. stack_ptr = 3
  1269. to = .F.
  1270.  
  1271. if stack_ptr <= max_ptr
  1272.     if upper(stack[stack_ptr]) = "TO"
  1273.         to = .T.
  1274.         null = get_expr1("exp1")
  1275.     endif
  1276. endif
  1277.  
  1278. if to
  1279.     executor = "SETS"
  1280.     SETS3 = .T.
  1281. else
  1282.     ERRS2 = .T.
  1283. endif
  1284.  
  1285. return
  1286.  
  1287. *
  1288. ** eoproc decimal
  1289.  
  1290.  
  1291. ***
  1292. * Procedure DECLARE
  1293. * kjs, 04/22/86, 10/08/86
  1294. * Evaluates the stack for the DECLARE verb.
  1295. * Sets execution class macro, class execution flag(s) and command line
  1296. * substitution macros.
  1297. *
  1298.  
  1299. procedure declare
  1300.  
  1301. private stack_ptr, string
  1302.  
  1303. stack_ptr = 2
  1304. string = ""
  1305.  
  1306. if get_stack("string")
  1307.     open_ptr = at("[",string)
  1308.     close_ptr = at("]",string)
  1309.     var1 = substr(string, 1, (open_ptr - 1))
  1310.     exp1 = substr(string,(open_ptr+1),(close_ptr-open_ptr-1))
  1311.     executor = "VARS"
  1312.     VARS10 = .T.
  1313. else
  1314.     ERRS2 = .T.
  1315. endif
  1316.  
  1317. return
  1318.  
  1319. *
  1320. ** eoproc declare
  1321.  
  1322.  
  1323. ***
  1324. * Procedure DEFAULT
  1325. * kjs, 05/08/86
  1326. * Evaluates the stack for the SET DEFAULT command.  Called by SET procedure.
  1327. * Sets execution class macro, class execution flag(s) and command line
  1328. * substitution macros.
  1329. *
  1330.  
  1331. procedure default
  1332.  
  1333. private stack_ptr, to
  1334.  
  1335. stack_ptr = 3
  1336. store .F. to to, drive
  1337.  
  1338. if stack_ptr <= max_ptr
  1339.     if upper(stack[stack_ptr]) = "TO"
  1340.         to = .T.
  1341.         drive = get_expr1("exp1")
  1342.     endif
  1343. endif
  1344.  
  1345. if to .and. drive
  1346.     executor = "SETS"
  1347.     SETS4 = .T.
  1348. else
  1349.     ERRS2 = .T.
  1350. endif
  1351.  
  1352. return
  1353.  
  1354. *
  1355. ** eoproc default
  1356.  
  1357.  
  1358. ***
  1359. * Procedure DELETE
  1360. * kjs, 05/14/86
  1361. * Analyze the stack for the DELETE verb.
  1362. * Sets execution class macro, class execution flag(s) and command line
  1363. * substitution macros.
  1364. * UDF CND_SCP() used to set condition and scope control variables.
  1365. *
  1366.  
  1367. procedure delete
  1368.  
  1369. private stack_ptr, for, while, next, record, all, stack_item
  1370.  
  1371. stack_ptr = 2
  1372. store .F. to for, while, next, record, all, condition
  1373. scope = 0
  1374.  
  1375. if cnd_scp()       && no errors during condition and scope analysis.
  1376.  
  1377.     do case
  1378.         case for .or. while .or. all .or. next .or. record
  1379.             ** w/ w/o scope and/or condition. **
  1380.             if DBF_OPEN .or. !error_on
  1381.                 executor = "DBF_NTX"
  1382.                 DBF_NTX19 = .T.
  1383.             else    
  1384.                 ERRS5 = .T.
  1385.             endif
  1386.  
  1387.         case !for .and. !while .and. !all .and. !next .and. !record;
  1388.             .and. max_ptr = 1
  1389.             ** w/o scope or conditional **
  1390.             if DBF_OPEN .or. !error_on
  1391.                 executor = "DBF_NTX"
  1392.                 DBF_NTX19 = .T.
  1393.                 scope = 1     && use RECORD (scope = 1) for single delete.
  1394.                 exp3 = str(recno())
  1395.  
  1396.                 if &exp3 > lastrec()
  1397.                     ERRS6 = .T.
  1398.                     DBF_NTX19 = .F.
  1399.                 else
  1400.                     exp3 = "recno() = &exp3"
  1401.                 endif
  1402.             else
  1403.                 ERRS5 = .T.
  1404.             endif
  1405.  
  1406.         otherwise        
  1407.             ERRS2 = .T.
  1408.     endcase        
  1409.  
  1410. endif
  1411.  
  1412. return
  1413.  
  1414. *
  1415. ** eoproc delete
  1416.  
  1417.  
  1418. ***
  1419. * Procedure delete_it
  1420. * kjs, 05/14/86
  1421. * Executes a record delete.  Called by procedure DO_CND_SCP.
  1422. *
  1423.  
  1424. procedure delete_it
  1425.  
  1426. delete
  1427.  
  1428. return
  1429.  
  1430. *
  1431. ** eoproc delete_it
  1432.  
  1433.  
  1434. ***
  1435. * Procedure DELIM
  1436. * kjs, 05/07/86
  1437. * Evaluates stack for SET DELIMITERS command.  Called by procedure
  1438. * SET.
  1439. * Sets execution class macro, class execution flag(s) and command line
  1440. * substitution macros.
  1441. *
  1442.  
  1443. procedure delim
  1444.  
  1445. private stack_ptr, stack_item, to, switch, string, error, active, null
  1446.  
  1447. stack_ptr = 3
  1448. store .F. to to, switch, string, null
  1449. active = 1   && 0 = done, 1 = TO token or toggle, 2 = string/DEFAULT token.
  1450. error = 0
  1451.  
  1452. do while stack_ptr <= max_ptr .and. error = 0
  1453.  
  1454.     stack_item = ""
  1455.     null = get_stack("stack_item")
  1456.  
  1457.     do case
  1458.         case active = 0
  1459.             error = 2
  1460.  
  1461.         case active = 1
  1462.             do case 
  1463.                 case upper(stack_item) == "TO"
  1464.                     to = .T.
  1465.                     active = 2
  1466.  
  1467.                 case upper(stack_item)$"ON^OFF"
  1468.                     exp1 = stack_item
  1469.                     switch = .T.
  1470.                     active = 0
  1471.  
  1472.                 otherwise
  1473.                     error = 2
  1474.             endcase
  1475.  
  1476.         case active = 2
  1477.             exp1 = stack_item
  1478.             string = .T.
  1479.             active = 0
  1480.     endcase
  1481. enddo
  1482.  
  1483. do case
  1484.     case error = 2 .or. active <> 0
  1485.         ERRS2 = .T.
  1486.  
  1487.     case to .and. string
  1488.         executor = "SETS"
  1489.         SETS6 = .T.
  1490.  
  1491.     case switch
  1492.         executor = "SETS"
  1493.         SETS5 = .T.
  1494. endcase
  1495.  
  1496. return
  1497.  
  1498. *
  1499. ** eoproc delim
  1500.  
  1501.  
  1502. ***
  1503. * Procedure DIR
  1504. * kjs, 04/22/86
  1505. * Sets execution class macro, class execution flag(s) and command line
  1506. * substitution macros from the command line not the stack.
  1507. *
  1508.  
  1509. procedure dir
  1510.  
  1511. exp1 = substr(command, len(stack[1]) + 1)
  1512.  
  1513. executor = "DBF_NTX"
  1514. DBF_NTX22 = .T.
  1515.  
  1516. *
  1517. ** eoproc dir
  1518.  
  1519.  
  1520. ***
  1521. * Procedure DISPLAY
  1522. * kjs, 04/22/86
  1523. * Evaluates the stack for the DISPLAY verb.
  1524. * Sets execution class macro, class execution flag(s) and command line
  1525. * substitution macros.
  1526. *
  1527.  
  1528. procedure display
  1529.  
  1530. private stack_ptr
  1531.  
  1532. stack_ptr = 1
  1533.  
  1534. if DBF_OPEN .or. !error_on
  1535.     if max_ptr = 1
  1536.         executor = "DBF_NTX"
  1537.         DBF_NTX14 = .T.
  1538.     else
  1539.         if get_list("E")
  1540.             executor = "DBF_NTX"
  1541.             DBF_NTX15 = .T.
  1542.         else
  1543.             ERRS2 = .T.
  1544.         endif
  1545.     endif
  1546. else
  1547.     ERRS5 = .T.
  1548. endif
  1549.  
  1550. return
  1551.  
  1552. *
  1553. ** eoproc display
  1554.  
  1555.  
  1556. ***
  1557. * Procedure DO
  1558. * kjs, 05/28/86, 10/08/86
  1559. * Evaluates the stack for the DO verb.
  1560. * Sets execution class macro, class execution flag(s) and command line
  1561. * substitution macros.
  1562. *
  1563.  
  1564. procedure do
  1565.  
  1566. private stack_ptr, stack_item, item_ok, xproc, with, params, active, error
  1567.  
  1568. stack_ptr = 2
  1569. store .F. to xproc, with, params, item_ok
  1570. active = 1            && 0 = done, 1 = procedure, 2 = WITH toke and params.
  1571. error = 0
  1572.  
  1573. do while stack_ptr <= max_ptr .and. error = 0
  1574.  
  1575.     stack_item = ""
  1576.     stack_item = stack[stack_ptr]
  1577.  
  1578.     do case
  1579.         case active = 0
  1580.             error = 2
  1581.  
  1582.         case active = 1
  1583.             exp1 = stack_item
  1584.             xproc = .T.
  1585.             stack_ptr = stack_ptr + 1
  1586.             if stack_ptr > max_ptr
  1587.                 active = 0
  1588.             else
  1589.                 active = 2
  1590.             endif
  1591.  
  1592.         case active = 2
  1593.             if upper(stack_item) = "WITH"
  1594.                 with = .T.
  1595.                 params = get_list("E")
  1596.                 if params
  1597.                     active = 0
  1598.                 else
  1599.                     error = 2
  1600.                 endif
  1601.             else
  1602.                 error = 2
  1603.             endif
  1604.     endcase
  1605. enddo
  1606.  
  1607. do case
  1608.     case error = 2 .or. active <> 0
  1609.         ERRS2 = .T.
  1610.  
  1611.     case xproc .and. !with .and. !params
  1612.         executor = "CALLS"
  1613.         CALLS1 = .T.
  1614.  
  1615.     case xproc .and. with .and. params
  1616.         executor = "CALLS"
  1617.         CALLS2 = .T.
  1618. endcase
  1619.  
  1620. return
  1621.  
  1622. *
  1623. ** eoproc do
  1624.  
  1625.  
  1626. ***
  1627. * Procedure do_cnd_scp
  1628. * kjs, 05/09/86
  1629. * Executes logic for conditional and scoped commands.  Called by executor
  1630. * procedures.  Calls to procedures containing single iterations of command
  1631. * being executed.
  1632. *
  1633.  
  1634. procedure do_cnd_scp
  1635.  
  1636. parameters action_proc
  1637.  
  1638. private more, count, do_it
  1639. more = .T.
  1640. count = 0
  1641.  
  1642. if rewind_dbf
  1643.     go top
  1644. endif
  1645.  
  1646. do while more .and. !EOF()
  1647.     do_it = .F.
  1648.      
  1649.     if scope > 0                    && handles scoping stuff.
  1650.         do case
  1651.             case scope = 1          && record.
  1652.                 if &exp3
  1653.                     do_it = .T.
  1654.                     more = .F.
  1655.                 endif
  1656.  
  1657.             case scope = 2          && all.
  1658.                 do_it = .T.
  1659.  
  1660.             case scope = 3          && next.
  1661.                 count = count + 1
  1662.                 if count <= &exp3
  1663.                     do_it = .T.
  1664.                 else
  1665.                     do_it = .F.
  1666.                     more = .F.
  1667.                 endif
  1668.  
  1669.         endcase
  1670.     endif
  1671.  
  1672.     if condition                    && handles conditional stuff.
  1673.  
  1674.         if "" <> exp1
  1675.             if &exp1                && FOR condition.
  1676.                 do_it = .T.
  1677.             else
  1678.                 do_it = .F.
  1679.             endif
  1680.         endif
  1681.  
  1682.         if "" <> exp2
  1683.             if &exp2                && WHILE condition.
  1684.                 do_it = .T.
  1685.             else
  1686.                 do_it = .F.
  1687.                 more = .F.
  1688.             endif
  1689.         endif
  1690.     endif
  1691.  
  1692.     if do_it
  1693.         do &action_proc             && call single iteration of command.
  1694.     endif
  1695.  
  1696.     if more
  1697.         skip
  1698.     endif
  1699.  
  1700. enddo
  1701.  
  1702. return
  1703.  
  1704. *
  1705. ** eoproc do_cnd_scp
  1706.  
  1707.  
  1708. ***
  1709. * Procedure ERASE
  1710. * kjs, 09/23/86
  1711. * Sets execution class macro, class execution flag(s) and command line
  1712. * substitution macros from the command line.
  1713. *
  1714.  
  1715. procedure erase
  1716.  
  1717. private error
  1718.  
  1719. error = 0
  1720.  
  1721. exp1 = substr(command, len(stack[1]) + 1)
  1722.  
  1723. if !empty(exp1)
  1724.     if file(stack_item) .or. !error_on
  1725.         exp1 = stack_item
  1726.     else
  1727.         error = 13
  1728.     endif
  1729. endif
  1730.  
  1731. if error = 13
  1732.     ERRS13 = .T.
  1733. else
  1734.     executor = "DBF_NTX"
  1735.     DBF_NTX30 = .T.
  1736. endif
  1737.  
  1738. return
  1739.  
  1740. *
  1741. ** eoproc erase
  1742.  
  1743.  
  1744. ***
  1745. * Procedure errs
  1746. * kjs, 06/12/86
  1747. * Executor for the ERRS class of commands, the DOT error message system.
  1748. *
  1749.  
  1750. procedure errs
  1751.  
  1752. do case
  1753.     case ERRS1
  1754.         ? "Unrecognized command, F1 for Help."
  1755.         ERRS1 = .F.
  1756.  
  1757.     case ERRS2
  1758.         ? "Syntax error, F1 for Help."
  1759.         ERRS2 = .F.
  1760.  
  1761.     case ERRS3
  1762.         ? "Undefined expression."
  1763.         ERRS3 = .F.
  1764.  
  1765.     case ERRS4
  1766.         ? "Undefined variable : "+"&exp1"
  1767.         ERRS4 = .F.
  1768.  
  1769.     case ERRS5
  1770.         ? "Database NOT in use."
  1771.         ERRS5 = .F.
  1772.  
  1773.     case ERRS6
  1774.         ? "Record out of range."
  1775.         ERRS6 = .F.
  1776.  
  1777.     case ERRS7
  1778.         ? "Data file NOT found."
  1779.         ERRS7 = .F.
  1780.  
  1781.     case ERRS8
  1782.         ? "Unbalanced delimiters."
  1783.         ERRS8 = .F.
  1784.  
  1785.     case ERRS9
  1786.         ? "Index file NOT in use"
  1787.         ERRS9 = .F.
  1788.  
  1789.     case ERRS10
  1790.         ? "Not implemented"
  1791.         ERRS10 = .F.
  1792.  
  1793.     case ERRS11
  1794.         ? "Index file NOT found"
  1795.         ERRS11 = .F.
  1796.  
  1797.     case ERRS12
  1798.         ? "Illegal goto value"
  1799.         ERRS12 = .F.
  1800.  
  1801.     case ERRS13
  1802.         ? "File NOT found"
  1803.         ERRS13 = .F.
  1804.  
  1805.     case ERRS14
  1806.         ? "Invalid function key number, 2 - 40"
  1807.         ERRS14 = .F.
  1808.  
  1809.     case ERRS15
  1810.         ? "Missing key word"
  1811.         ERRS15 = .F.
  1812. endcase
  1813.  
  1814. return
  1815.  
  1816. *
  1817. ** eoproc errs
  1818.  
  1819.  
  1820. ***
  1821. * Procedure ESCAPE
  1822. * kjs, 05/24/86
  1823. * Evaluates stack for the SET ESCAPE command. Called by SET procedure.
  1824. * Sets execution class macro, class execution flag(s) and command line
  1825. * substitution macros.
  1826. *
  1827.  
  1828. procedure escape
  1829.  
  1830. stack_ptr = 3
  1831.  
  1832. if stack_ptr <= max_ptr
  1833.     exp1 = upper(stack[stack_ptr])
  1834.     if "&exp1"$"ON^OFF"
  1835.         executor = "SETS"
  1836.         SETS7 = .T.
  1837.     else
  1838.         ERRS2 = .T.
  1839.     endif
  1840. else
  1841.     ERRS2 = .T.
  1842. endif
  1843.  
  1844. return
  1845.  
  1846. *
  1847. ** eoproc escape
  1848.  
  1849.  
  1850. ***
  1851. * Procedure EXACT
  1852. * kjs, 05/24/86
  1853. * Evaluates the stack for SET EXACT command.  Called by SET procedure.
  1854. * Sets execution class macro, class execution flag(s) and command line
  1855. * substitution macros.
  1856. *
  1857.  
  1858. procedure exact
  1859.  
  1860. stack_ptr = 3
  1861.  
  1862. if stack_ptr <= max_ptr
  1863.     exp1 = upper(stack[stack_ptr])
  1864.     if "&exp1"$"ON^OFF"
  1865.         executor = "SETS"
  1866.         SETS20 = .T.
  1867.     else 
  1868.         ERRS2 = .T.
  1869.     endif
  1870. else
  1871.     ERRS2 = .T.
  1872. endif
  1873.  
  1874. return
  1875.  
  1876. *
  1877. ** eoproc exact
  1878.  
  1879.  
  1880. ***
  1881. * Procedure EXCLUSIVE
  1882. * kjs, 07/28/86
  1883. * Evaluates the stack for the SET EXCLUSIVE command.  Called from
  1884. * procedure SET.
  1885. * Sets execution class macro, class execution flag(s) and command
  1886. * line substitution macros.
  1887. *
  1888.  
  1889. procedure exclusive
  1890.  
  1891. stack_ptr = 3
  1892.  
  1893. if stack_ptr <= max_ptr
  1894.     exp1 = upper(stack[stack_ptr])
  1895.     if "&exp1"$"ON^OFF"
  1896.         executor = "SETS"
  1897.         SETS19 = .T.
  1898.     else
  1899.         ERRS2 = .T.
  1900.     endif
  1901. else
  1902.     ERRS2 = .T.
  1903. endif
  1904.  
  1905. return
  1906.  
  1907. *
  1908. ** eoproc exclusive
  1909.  
  1910.  
  1911. ***
  1912. * Procedure fill_lists
  1913. * kjs, 05/06/86
  1914. * Called from procedure DOT.  Fills the verb_list, lex_list, set_list and
  1915. * set_proc search strings.
  1916. *
  1917.  
  1918. procedure fill_lists
  1919.  
  1920. verb_list =    "         .!        .?        .??       .@        .ACCEPT   "+;
  1921.     ".APPEND   .CLEAR    .CLS      .DECLARE  .DELETE   .DIRECTORY.DISPLAY  "+;
  1922.     ".DO       .EXIT     .GO       .GOTO     .INDEX    .INPUT    .LIST     "+;
  1923.     ".PACK     .QUIT     .READ     .RECALL   .RELEASE  .RETURN   .RUN      "+;
  1924.     ".SEEK     .SELECT   .SET      .SKIP     .TYPE     .USE      .WAIT     "+;
  1925.     ".CALL     .UNLOCK   .REPLACE  .COPY     .ERASE    .ZAP      "
  1926.  
  1927. lex_list =     "         RUN       QUES1     QUES2     AT        ACCEPT    "+;
  1928.     "APPEND    CLEAR     CLEAR     DECLARE   DELETE    DIR       DISPLAY   "+;
  1929.     "DO        QUIT      GOTO      GOTO      INDEX     INPUT     LIST      "+;
  1930.     "PACK      QUIT      RREAD     RECALL    RELEASE   QUIT      RUN       "+;
  1931.     "SEEK      SELECT    SSET      SKIP      TYPE      USE       WWAIT     "+;
  1932.     "CALL      UNLOCK    REPLACE   COPY      ERASE     ZAP       "
  1933.  
  1934. set_list =      "          .COLOR     .CONFIRM   .DECIMALS  .DEFAULT   "+;
  1935.     ".DELIMITERS.EXACT     .ESCAPE    .EXCLUSIVE .FILTER    .FIXED     "+;
  1936.     ".FUNCTION  .INDEX     .INTENSITY .KEY       .ORDER     .PATH      "+;
  1937.     ".RELATION  .UNIQUE    "
  1938.  
  1939. set_proc =      "          COLOR      CONFIRM    DECIMAL    DEFAULT    "+;
  1940.     "DELIM      EXACT      ESCAPE     EXCLUSIVE  FILTER     FIXED      "+;
  1941.     "FUNC_SET   INDEX_SET  INTENSITY  KEY        ORDER      PATH       "+;
  1942.     "RELATE     UNIQUE     "    
  1943.  
  1944. return
  1945.  
  1946. *
  1947. ** eoproc fill_lists
  1948.  
  1949.  
  1950. ***
  1951. * Procedure FILTER
  1952. * kjs, 05/07/86
  1953. * Evaluates the stack for the SET FILTER command.  Called by procedure SET.
  1954. * Sets execution class macro, class execution flag(s) and command line
  1955. * substitution macros.
  1956. *
  1957.  
  1958. procedure filter
  1959.  
  1960. private stack_ptr, stack_item, to, filter, error
  1961.  
  1962. stack_ptr = 3
  1963. stack_item = ""
  1964. error = 0
  1965. store .F. to to, filter
  1966.  
  1967. if DBF_OPEN .or. if(error_on, DBF_OPEN, .T.)
  1968.     if get_stack("stack_item")
  1969.         to = (upper(stack_item) = "TO")
  1970.         filter = get_stack("exp1")
  1971.     else
  1972.         error = 2
  1973.     endif
  1974. else
  1975.     error = 5
  1976. endif
  1977.  
  1978. do case
  1979.     case error = 5
  1980.         ERRS5 = .T.
  1981.  
  1982.     case error = 2 .or. !to .and. !filter
  1983.         ERRS2 = .T.
  1984.  
  1985.     case to .and. filter
  1986.         executor = "SETS"
  1987.         SETS17 = .T.
  1988.  
  1989.     case to .and. !filter
  1990.         executor = "SETS"
  1991.         SETS18 = .T.
  1992. endcase
  1993.  
  1994. return
  1995.  
  1996. *
  1997. ** eoproc filter
  1998.  
  1999.  
  2000. ***
  2001. * Procedure FIXED
  2002. * kjs, 04/28/86
  2003. * Evaluates the stack for the SET FIXED command, called by procedure SET.
  2004. * Sets execution class macro, class execution flag(s) and command line
  2005. * substitution macros.
  2006. *
  2007.  
  2008. procedure fixed
  2009.  
  2010. stack_ptr = 3
  2011.  
  2012. if stack_ptr <= max_ptr
  2013.     exp1 = upper(stack[stack_ptr])
  2014.     if "&exp1"$"ON^OFF"
  2015.         executor = "SETS"
  2016.         SETS8 = .T.
  2017.     else
  2018.         ERRS2 = .T.
  2019.     endif
  2020. else
  2021.     ERRS2 = .T.
  2022. endif
  2023.  
  2024. return
  2025.  
  2026. *
  2027. ** eoproc fixed
  2028.  
  2029.  
  2030. ***
  2031. * Procedure FUNC
  2032. * kjs, 05/07/86
  2033. * Evaluates the stack for the SET FUNCTION command, called by procedure SET.
  2034. * Sets execution class macro, class execution flag(s) and command line
  2035. * substitution macros.
  2036. *
  2037.  
  2038. procedure func_set
  2039.  
  2040. private stack_ptr, stack_item, string, to, key, error, active, null
  2041.  
  2042. stack_ptr = 3
  2043. store .F. to key, to, string, null
  2044. error = 0
  2045. active = 1  && 0 = error, 1 = function number, 2 = TO token, 3 = string.
  2046.  
  2047. do while stack_ptr <= max_ptr
  2048.  
  2049.     stack_item = ""
  2050.     null = get_stack("stack_item")
  2051.  
  2052.     if upper(stack_item) = "TO"
  2053.         if active = 2    && expected TO token.
  2054.             to = .T.
  2055.             active = 3
  2056.         else
  2057.             error = 2
  2058.         endif
  2059.     else
  2060.         do case
  2061.             case active = 0                && unexpected something.
  2062.                 error = 2
  2063.  
  2064.             case active = 1                && expecting key number.
  2065.                 exp1 = stack_item
  2066.                 if val(exp1) > 1 .and. val(exp1) < 41
  2067.                     key = .T.
  2068.                 else
  2069.                     error = 14
  2070.                 endif
  2071.                 active = 2
  2072.  
  2073.             case active = 3                && expecting string.
  2074.                 exp2 = stack_item
  2075.                 string = .T.
  2076.                 active = 0
  2077.         endcase
  2078.     endif
  2079. enddo
  2080.  
  2081. do case
  2082.     case error = 2
  2083.         ERRS2 = .T.
  2084.  
  2085.     case error = 14
  2086.         ERRS14 = .T.
  2087.  
  2088.     case key .and. to .and. string
  2089.         executor = "SETS"
  2090.         SETS9 = .T.
  2091.  
  2092.     otherwise
  2093.         ERRS2 = .T.
  2094. endcase
  2095.  
  2096. return
  2097.  
  2098. *
  2099. ** eoproc func
  2100.  
  2101.  
  2102. ***
  2103. * Procedure GOTO
  2104. * kjs, 04/22/86
  2105. * Evaluates the stack for the GO or GOTO verb.
  2106. * Sets execution class macro, class execution flag(s) and command line
  2107. * substitution macros.
  2108. *
  2109.  
  2110. procedure goto
  2111.  
  2112. private stack_ptr, stack_item, bottom, top, error
  2113.  
  2114. stack_ptr = 2
  2115. stack_item = ""
  2116. store .F. to bottom, top
  2117. error = 0
  2118.  
  2119. if DBF_OPEN .or. if(error_on, DBF_OPEN, .T.)  && check for open data file.
  2120.     if get_stack("stack_item")                && stack item exists.
  2121.  
  2122.         top = (upper(stack_item) == "TOP")
  2123.         bottom = cmd_abbr(upper(stack_item), "BOTTOM")
  2124.  
  2125.         if !top .and. !bottom
  2126.  
  2127.             exp1 = stack_item
  2128.  
  2129.             if error_on                       && check legal goto value.
  2130.                 do case
  2131.                     case &exp1 > lastrec()    && too big.
  2132.                         error = 6
  2133.                         
  2134.                     case &exp1 < 0            && too small.
  2135.                         error = 12
  2136.                 endcase
  2137.             endif
  2138.         endif
  2139.     else
  2140.         error = 2
  2141.     endif
  2142. else
  2143.     error = 5
  2144. endif
  2145.  
  2146. do case
  2147.     case error = 2
  2148.         ERRS2 = .T.
  2149.  
  2150.     case error = 5
  2151.         ERRS5 = .T.
  2152.  
  2153.     case error = 6
  2154.         ERRS6 = .T.
  2155.  
  2156.     case error = 12
  2157.         ERRS12 = .T.
  2158.  
  2159.     case !top .and. !bottom
  2160.         executor = "DBF_NTX"
  2161.         DBF_NTX7 = .T.
  2162.  
  2163.     case top
  2164.         executor = "DBF_NTX"
  2165.         DBF_NTX8 = .T.
  2166.  
  2167.     case bottom
  2168.         executor = "DBF_NTX"
  2169.         DBF_NTX9 = .T.
  2170. endcase
  2171.  
  2172. return
  2173.  
  2174. *
  2175. ** eoproc goto
  2176.  
  2177.  
  2178. ***
  2179. * Procedure help
  2180. * kjs, 11/10/85
  2181. * Help for DOT.
  2182. *
  2183.  
  2184. procedure help
  2185.  
  2186. parameters call_proc, line_num, call_var
  2187.  
  2188. set key 5 to
  2189.  
  2190. if call_proc = "HELP"
  2191.     return
  2192. endif
  2193.  
  2194. row = row()
  2195. col = col()
  2196.  
  2197. save screen
  2198. clear
  2199.  
  2200. text
  2201.                           Commands supported by DOT
  2202.  
  2203.   <F1> - Help
  2204.   <>  - History mode.  Up to [max_hist] commands are saved.  After
  2205.          [max_hist] commands have been saved, each new command is added
  2206.          to the end of the history array and the top command is thrown
  2207.          away.
  2208.  
  2209.          <>     - move backward through commands.
  2210.          <>     - move forward through commands.
  2211.          <ESC>   - returns without selecting a command.
  2212.          <─┘>   - executes the selection.
  2213.  
  2214.   @ <row>,<col> 
  2215.      [say <exp> [picture <clause>]]
  2216.      [get <exp> [picture <clause>] 
  2217.      [range <exp, exp>] [valid <exp>]]
  2218.      [clear]
  2219.   @ t, l, b, r BOX <string>
  2220.   ! or RUN <DOS command or file>
  2221.   ?  [<exp>]
  2222.   ?? [<exp>]
  2223.   <var> = <exp>              
  2224.  
  2225. endtext
  2226.  
  2227. wait "Strike any key for more help, <ESC> to return"
  2228.  
  2229. if lastkey() = 27
  2230.     set key 5 to history
  2231.     clear
  2232.     restore screen
  2233.     return
  2234. endif
  2235.  
  2236. clear
  2237.  
  2238. text
  2239.                           More commands supported by DOT
  2240.  
  2241.   accept [<string>] to <memvar>
  2242.   append blank
  2243.   call <procedure> [with <param1>[,<parameter list>]]
  2244.   clear
  2245.   cls
  2246.   copy [structure] to <filename>
  2247.   dir [<drive>][<path>][<skeleton>]
  2248.   display [<exp>[,<expression list>]]
  2249.   delete [<scope>][FOR/WHILE <expression>].
  2250.   do <procedure> [with <param1>[,<parameter list>]]
  2251.   erase <file name>.<extension>
  2252.   exit
  2253.   go[to] <exp>/TOP/BOTTOM
  2254.   index on <key expression> to <ntxfile>
  2255.   input [<string>] to <var> 
  2256.   list [<exp>[,<expression list>]]
  2257.   pack
  2258.   quit
  2259.   read
  2260.   recall [<scope>] [FOR/WHILE <expression>].
  2261.   release <var>
  2262.  
  2263. endtext
  2264.  
  2265. wait "Strike any key for more help, <ESC> to return"
  2266.  
  2267. if lastkey() = 27
  2268.     set key 5 to history
  2269.     clear
  2270.     restore screen
  2271.     return
  2272. endif
  2273.  
  2274. clear
  2275.  
  2276. text
  2277.                           More commands supported by DOT
  2278.  
  2279.   replace <fieldname> with <expression>
  2280.   return            ** Returns to previous level **
  2281.   seek <exp>
  2282.   select <exp>/<alias>  ** variables not usable **
  2283.   set color to <expression>
  2284.   set decimals to <expression>
  2285.   set default to <drive:>
  2286.   set delimiters <ON/OFF>
  2287.   set delimiters to [<string>]/[DEFAULT]
  2288.   set filter to [<filter expression>]
  2289.   set escape <ON/OFF>
  2290.   set exact <ON/OFF>
  2291.   set exclusive <ON/OFF>
  2292.   set fixed <ON/OFF>
  2293.   set function <function key number> to <string>
  2294.   set intensity <ON/OFF>
  2295.   set index to [<ntxfile>[,<ntxlist>]]]
  2296.   set key <ascii key number> to <string>
  2297.   set path to [<path expression>]
  2298.   set order to [<expN>]
  2299.   set relation to [<key expression> into <alias>]
  2300.  
  2301. endtext
  2302.  
  2303. wait "Strike any key for more help, <ESC> to return"
  2304.  
  2305. if lastkey() = 27
  2306.     set key 5 to history
  2307.     clear
  2308.     restore screen
  2309.     return
  2310. endif
  2311.  
  2312. clear
  2313.  
  2314. text
  2315.                           More commands supported by DOT
  2316.  
  2317.   skip [<exp>]
  2318.   type <file name>.<extension>
  2319.   unlock [ALL]
  2320.   use [<filename> [index <ntxfile>[,<ntxlist>]]][alias <alias name>]
  2321.       exclusive
  2322.   wait [[<string>][to <var>]]
  2323.   zap
  2324.  
  2325.                                    Comments
  2326.  
  2327.   1. Command MUST be entered as shown in HELP or error may be generated.
  2328.   2. Lists can contain up to 10 items. CALL or DO use up to 7 items.
  2329.   3. The SET FUNCTION command does not allow [F1] to be reset.
  2330.      Range [2] to [40]
  2331.   4. The SET KEY command does not allow [28] and [24] keys to be reset.
  2332.      Range [-39] to [387].
  2333.   5. The SET KEY command overrides the SET FUNCTION key.
  2334.   6. SET KEY should ONLY be used with VALID procedure names.
  2335.   7. If a GET is pending, DO NOT use History [] to execute a READ or
  2336.      the GET will be cleared.
  2337.  
  2338. endtext
  2339.  
  2340. wait "Strike any key for more help, <ESC> to return"
  2341.  
  2342. if lastkey() = 27
  2343.     set key 5 to history
  2344.     clear
  2345.     restore screen
  2346.     return
  2347. endif
  2348.  
  2349. clear
  2350.  
  2351. text
  2352.                                    Comments
  2353.  
  2354.   8. FOR and WHILE are NON-exclusive phrases.  WHILE takes precedence.
  2355.   9. When more than one scoping key word is present, control will be
  2356.      given to the last key word in the command line.
  2357.  10. Input and Display sections can use different I/O environments when
  2358.      SETs are issued.  See main DOT procedure.
  2359.  11. SAFETY is NOT on, BE FOREWARNED.
  2360.  12. Macros are expanded before being placed on stack so DOT may behave
  2361.      differently than a Clipper program with macros.
  2362.  
  2363.  
  2364.                               Flow Chart
  2365.  
  2366.   The next page contains a simple flow chart of the internal structure of
  2367.   the DOT test utility.  Upper case words represent the names of
  2368.   PROCEDURES called by the main DOT procedure.  Several macros are used
  2369.   to call procedures that will vary based on the contents of the stack.
  2370.   These cases are noted as such and do not use the upper case convention.
  2371.  
  2372. endtext
  2373.  
  2374. wait "Strike any key for more help, <ESC> to return"
  2375.  
  2376. if lastkey() = 27
  2377.     set key 5 to history
  2378.     clear
  2379.     restore screen
  2380.     return
  2381. endif
  2382.  
  2383. clear
  2384. text
  2385. DOT────>────── (initialize flags, execution and control variables)
  2386.                    
  2387.                FILL_LIST    ** initialize search string variables.
  2388.                    
  2389.   ┌─────>───── (initialize stack array) 
  2390.   │                
  2391.   │             INPUT_LN    ** put cursor at bottom of screen.
  2392.   │                
  2393.   │             (input)     ** accept the command line from the console.
  2394.   │                
  2395.   │             INPUT_LN    ** return to display portion of screen.
  2396.   │                
  2397.                 PARSE      ** place components of command line on stack.
  2398.   │                
  2399.   │             SET_LEX     ** set analysis procedure macro "lex_proc".
  2400.   │                
  2401.   │            (analyze)    ** do analyze procedure macro "lex_proc".
  2402.   │                
  2403.   │             HIST_PUT    ** put command into history array.
  2404.   │                
  2405.   │            (execute)    ** do execution procedure macro "executor".
  2406.   │                
  2407.   └─────<───── (reset command line substitution macro variables)
  2408. endtext
  2409.  
  2410. wait "Strike any key for more help, <ESC> to return"
  2411.  
  2412. if lastkey() = 27
  2413.     set key 5 to history
  2414.     clear
  2415.     restore screen
  2416.     return
  2417. endif
  2418.  
  2419. clear
  2420. text
  2421.                              DOT assistance programs
  2422.  
  2423.   what_key   : Returns the numeric value of a key. <ALT-Q> aborts.
  2424.   hist_purge : Empties the history array.
  2425.   set_sets   : Reset all the SET commands listed to their DEFAULT
  2426.                setting.
  2427.  
  2428.                            Internal Control Variables
  2429.  
  2430.   bottom_on = .T.  -  Places the input window at the bottom of the screen.
  2431.   error_on  = .T.  -  Checks for DBF, NTX ON/OFF or existence.
  2432.   max_hist  = 20   -  Maximum number of history item stored before
  2433.                       overwrites of earlier 'saved' commands starts.
  2434.  
  2435. endtext
  2436.  
  2437. wait "Strike any key to continue."
  2438.  
  2439. clear
  2440.  
  2441. set key 5 to history
  2442. restore screen
  2443. return
  2444.  
  2445. *
  2446. ** eoproc help
  2447.  
  2448.  
  2449. ***
  2450. * Procedure hist_purge
  2451. * kjs, 04/16/86
  2452. * Purges the history array.
  2453. *
  2454.  
  2455. procedure hist_purge
  2456.  
  2457. do while hist_max > 0
  2458.     history[hist_max] = ""
  2459.     hist_max = hist_max - 1
  2460. enddo
  2461. hist_ptr = 0
  2462.  
  2463. return
  2464.  
  2465. *
  2466. ** eoproc hist_purge
  2467.  
  2468.  
  2469. ***
  2470. * Procedure hist_put
  2471. * kjs, 04/15/86
  2472. * Stores command into the history array
  2473. *
  2474.  
  2475. procedure hist_put
  2476.  
  2477. if hist_max < max_hist
  2478.     hist_max = hist_max + 1
  2479. else 
  2480.     for i = 2 to max_hist 
  2481.         history[i-1] = history[i]
  2482.     next
  2483. endif
  2484.  
  2485. history[hist_max] = command
  2486.  
  2487. return
  2488.  
  2489. *
  2490. ** eoproc hist_put
  2491.  
  2492.  
  2493. ***
  2494. * Procedure history
  2495. * kjs, 04/15/86
  2496. * Allows user to select from the list of history'd commands.
  2497. *
  2498.  
  2499. procedure history
  2500.  
  2501. parameters call_proc, call_line, call_var
  2502.  
  2503. private key, hist_ptr, curr_row, curr_col, cmd_line
  2504.  
  2505. if hist_max > 0 .and. call_proc <> "HISTORY"
  2506.  
  2507.     set intensity on
  2508.     clear gets
  2509.  
  2510.     key = 0
  2511.     hist_ptr = hist_max
  2512.     curr_row = row()
  2513.     curr_col = col()
  2514.  
  2515.     set key 5 to stuff_up
  2516.     set key 24 to stuff_dn
  2517.  
  2518.     do while .T.
  2519.         cmd_line = history[hist_ptr] + space(77 - len(history[hist_ptr]))
  2520.         @ curr_row, curr_col get cmd_line
  2521.         read
  2522.  
  2523.         key = lastkey()
  2524.  
  2525.         do case
  2526.             case key = 5
  2527.                 ** up-arrow, backwards **
  2528.                 hist_ptr = hist_ptr - 1
  2529.                 if hist_ptr <= 0
  2530.                     hist_ptr = hist_max
  2531.                 endif
  2532.     
  2533.             case key = 24
  2534.                 ** down-arrow, forward **
  2535.                 hist_ptr = hist_ptr + 1
  2536.                 if hist_ptr > hist_max
  2537.                     hist_ptr = 1
  2538.                 endif
  2539.  
  2540.             case key = 13 .or. key = 27
  2541.                 if key = 13
  2542.                     keyboard trim(cmd_line) + chr(13)
  2543.                 endif
  2544.                 @ curr_row, curr_col
  2545.                 set intensity &inten_stat
  2546.                 set key 5 to history
  2547.                 set key 24 to
  2548.                 return
  2549.         endcase
  2550.     enddo
  2551. endif
  2552.  
  2553. *
  2554. ** eoproc history
  2555.  
  2556.  
  2557. ***
  2558. * Procedure INDEX
  2559. * kjs, 03/21/86
  2560. * Evaluates the stack for the INDEX verb.
  2561. * Sets execution class macro, class execution flag(s) and command line
  2562. * substitution macros.
  2563. *
  2564.  
  2565. procedure index
  2566.  
  2567. private stack_ptr, stack_item, item_ok, on, to, key, file, active, error
  2568.  
  2569. stack_ptr = 2
  2570. store .F. to on, to, key, file
  2571. active = 1    && 0 = error, 1 = key, 2 = file.
  2572. error = 0
  2573.  
  2574. if error_on .and. !DBF_OPEN  && if file checking is on and file is not open.
  2575.     error = 5
  2576. endif
  2577.  
  2578. do while stack_ptr <= max_ptr .and. error = 0
  2579.     stack_item = ""
  2580.     item_ok = get_stack("stack_item")
  2581.  
  2582.     do case
  2583.         case upper(stack_item) = "ON" .and. !on
  2584.             on = .T.
  2585.             active = 1
  2586.  
  2587.         case upper(stack_item) = "TO" .and. !to
  2588.             to = .T.
  2589.             active = 2
  2590.  
  2591.         otherwise
  2592.             do case
  2593.                 case active = 1
  2594.                     key = .T.
  2595.                     exp1 = stack_item
  2596.                     if !file
  2597.                         active = 2
  2598.                     else
  2599.                         active = 0
  2600.                     endif
  2601.  
  2602.                 case active = 2
  2603.                     file = .T.
  2604.                     ntx_file = stack_item
  2605.                     if !key
  2606.                         active = 1
  2607.                     else
  2608.                         active = 0
  2609.                     endif
  2610.  
  2611.                 otherwise
  2612.                     error = 2
  2613.             endcase
  2614.     endcase
  2615. enddo
  2616.  
  2617. do case
  2618.     case error = 2
  2619.         ERRS2 = .T.
  2620.  
  2621.     case error = 5
  2622.         ERRS5 = .T.
  2623.     
  2624.     case on .and. to .and. key .and. file
  2625.         executor = "DBF_NTX"
  2626.         DBF_NTX6 = .T.
  2627.  
  2628.     otherwise
  2629.         ERRS2 = .T.
  2630. endcase
  2631.  
  2632. return
  2633.  
  2634. *
  2635. ** eoproc index
  2636.  
  2637.  
  2638. ***
  2639. * Procedure INDEX_set
  2640. * kjs, 05/01/86
  2641. * Evaluates stack for SET INDEX TO command.  Called by procedure SET.
  2642. * Sets execution class macro, class execution flag(s) and command line
  2643. * substitution macros.
  2644. *
  2645.  
  2646. procedure index_set
  2647.  
  2648. private stack_ptr, stack_item, item_ok, to, file, error
  2649.  
  2650. stack_ptr = 3
  2651. stack_item = ""
  2652. store .F. to item_ok, to, file
  2653. error = 0
  2654.  
  2655. if error_on .and. !DBF_OPEN        && check for open data file.
  2656.     error = 5
  2657. else
  2658.     stack_item = stack[stack_ptr]
  2659.  
  2660.     if (upper(stack_item) == "TO")
  2661.         to = .T.
  2662.         file = get_list("NF")
  2663.  
  2664.         if !file                   && error occurred in building list.
  2665.             if empty(list0)        && list is empty, turn indexes off.
  2666.                 file = .T.
  2667.             else                   && index file not found.
  2668.                 error = 11
  2669.             endif
  2670.         endif
  2671.     else
  2672.         error = 2
  2673.     endif
  2674. endif
  2675.  
  2676. do case
  2677.     case error = 2
  2678.         ERRS2 = .T.
  2679.  
  2680.     case error = 5
  2681.         ERRS5 = .T.
  2682.  
  2683.     case error = 11
  2684.         ERRS11 = .T.
  2685.  
  2686.     case to .and. file
  2687.         executor = "SETS"
  2688.         SETS10 = .T.
  2689. endcase
  2690.  
  2691. return
  2692.  
  2693. *
  2694. ** eoproc index_set
  2695.  
  2696.  
  2697. ***
  2698. * Procedure INPUT
  2699. * kjs, 04/11/86
  2700. * Evaluates stack for INPUT verb.
  2701. * Sets execution class macro, class execution flag(s) and command line
  2702. * substitution macros.
  2703. *
  2704.  
  2705. procedure input
  2706.  
  2707. private stack_ptr, string, to, dest, stack_item
  2708.  
  2709. stack_ptr = 1
  2710. store .F. to string, to, dest
  2711.  
  2712. do while stack_ptr <= max_ptr
  2713.     stack_item = upper(stack[stack_ptr])
  2714.     do case
  2715.         case stack_item = "INPU"
  2716.             string = get_expr1("exp1")
  2717.             if upper(exp1) = "TO"
  2718.                 string = .F.
  2719.                 exp1 = ""
  2720.                 stack_ptr = stack_ptr - 1
  2721.             endif
  2722.  
  2723.         case stack_item = "TO"
  2724.             to = .T.
  2725.             dest = get_expr1("var1")
  2726.         otherwise
  2727.             stack_ptr = stack_ptr + 1
  2728.     endcase
  2729. enddo
  2730.  
  2731. if !err()
  2732.     do case
  2733.         case to .and. dest .and. !string
  2734.             executor = "VARS"
  2735.             VARS3 = .T.
  2736.             VARS9 = .T.
  2737.  
  2738.         case to .and. dest .and. string
  2739.             executor = "VARS"
  2740.             VARS4 = .T.
  2741.             VARS9 = .T.
  2742.  
  2743.         otherwise
  2744.             ERRS2 = .T.
  2745.     endcase
  2746. endif
  2747.  
  2748. return
  2749.  
  2750. *
  2751. ** eoproc input
  2752.  
  2753.  
  2754. ***
  2755. * Procedure input_ln
  2756. * kjs/br, 04/16/86
  2757. * Places the input line on the bottom of screen and manages the
  2758. * placement of the end of output diamond.
  2759. *
  2760.  
  2761. procedure input_ln
  2762.  
  2763. parameters when
  2764.  
  2765. if when = "B"
  2766.     save_row = row()
  2767.     save_col = col()
  2768.  
  2769.     ?? chr(4)                && display cursor position marker.
  2770.  
  2771.     @ MaxRow(), 0 say ""
  2772.  
  2773.     do while (save_row > MaxRow()-2)
  2774.         ?
  2775.         save_row = save_row - 1
  2776.     enddo
  2777.  
  2778.     @ MaxRow()-1, 0 clear
  2779.     @ MaxRow()-1, 0 say cmd_line
  2780.     @ MaxRow()-1, 0 say ""
  2781. else
  2782.     @ MaxRow()-1, 0 clear
  2783.     @ save_row, save_col say " "
  2784.     @ save_row, save_col say ""
  2785. endif
  2786.  
  2787. return
  2788.  
  2789. *
  2790. ** eoproc input_ln
  2791.  
  2792.  
  2793. ***
  2794. * Procedure INTENSITY
  2795. * kjs, 04/28/86
  2796. * Evaluates the stack for the SET INTENSITY command.  Called by the 
  2797. * SET procedure.
  2798. * Sets execution class macro, class execution flag(s) and command line
  2799. * substitution macros.
  2800. *
  2801.  
  2802. procedure intensity
  2803.  
  2804. stack_ptr = 2
  2805.  
  2806. if get_expr1("exp1")
  2807.     if exp1$"ON^OFF"
  2808.         executor = "SETS"
  2809.         SETS11 = .T.
  2810.     else
  2811.         ERRS2 = .T.
  2812.     endif
  2813. else
  2814.     ERRS2 = .T.
  2815. endif
  2816.  
  2817. return
  2818.  
  2819. *
  2820. ** eoproc intensity
  2821.  
  2822.  
  2823. ***
  2824. * Procedure KEY
  2825. * kjs, 05/07/86
  2826. * Evaluates the stack for the SET KEY command.  Called from procedure
  2827. * SET.
  2828. * Sets execution class macro, class execution flag(s) and command line
  2829. * substitution macros.
  2830. * Does not allow [F1] or [] to be reset.
  2831. *
  2832.  
  2833. procedure key
  2834.  
  2835. private stack_ptr, string, to, key, null, stack_item
  2836.  
  2837. stack_ptr = 2
  2838. store .F. to key, to, null
  2839.  
  2840. do while stack_ptr <= max_ptr
  2841.     stack_item = upper(stack[stack_ptr])
  2842.     do case
  2843.         case stack_item = "KEY"
  2844.             key = get_expr1("exp1")
  2845.             if key .and. val(exp1) > -40 .and. val(exp1) < 388;
  2846.                 .and. val(exp1) <> 28 .and. val(exp1) <> 24
  2847.                 key = .T.
  2848.             endif
  2849.  
  2850.         case stack_item = "TO"
  2851.             to = .T.
  2852.             null = get_expr1("exp2")
  2853.  
  2854.         otherwise
  2855.             stack_ptr = stack_ptr + 1
  2856.     endcase
  2857. enddo
  2858.  
  2859. if !err()
  2860.     if key .and. to
  2861.         executor = "SETS"
  2862.         SETS14 = .T.
  2863.     else
  2864.         ERRS2 = .T.
  2865.     endif
  2866. endif
  2867.  
  2868. return
  2869.  
  2870. *
  2871. ** eoproc key
  2872.  
  2873.  
  2874. ***
  2875. * Procedure LIST
  2876. * kjs, 04/22/86
  2877. * Evaluates stack for the LIST verb.
  2878. * Sets execution class macro, class execution flag(s) and command line
  2879. * substitution macros.
  2880. *
  2881.  
  2882. procedure list
  2883.  
  2884. private stack_ptr
  2885.  
  2886. stack_ptr = 1
  2887.  
  2888. if DBF_OPEN .or. !error_on
  2889.     if max_ptr = 1
  2890.         executor = "DBF_NTX"
  2891.         DBF_NTX12 = .T.
  2892.     else
  2893.         if get_list("E")
  2894.             executor = "DBF_NTX"
  2895.             DBF_NTX13 = .T.
  2896.         else
  2897.             ERRS2 = .T.
  2898.         endif
  2899.     endif
  2900. else
  2901.     ERRS5 = .T.
  2902. endif
  2903.  
  2904. return
  2905.  
  2906. *
  2907. ** eoproc list
  2908.  
  2909.  
  2910. ***
  2911. * Procedure list_do
  2912. * kjs, 04/10/86
  2913. * Emulates the LIST/DISPLAY command, called LIST executor.
  2914. *
  2915. * Usage : list_do <logical 1>, <logical 2>
  2916. * Where :    <logical 1> = record number display flag.
  2917. *         :    <logical 2> = LIST/DISPLAY flag. .T. = DISPLAY mode
  2918. *
  2919.  
  2920. procedure list_do
  2921.  
  2922. parameters recno_on, is_display
  2923.  
  2924. private disp_count, count, header, l_part1, l_part2, l_part3, use_part2,;
  2925.     use_part3
  2926.  
  2927. if recno_on
  2928.     header = "[Record#  "
  2929.     l_part1 = "str(recno(),7)+space(2)"
  2930. else
  2931.     header = "["
  2932.     l_part1 = "space(0)"
  2933. endif
  2934.  
  2935. l_part2 = "space(0)"
  2936. l_part3 = "space(0)"
  2937.  
  2938. use_part2 = .F.
  2939. use_part3 = .F.
  2940.  
  2941. count = 1
  2942.  
  2943. do while "" <> fieldname(count)
  2944.     header = header + spacer_h(fieldname(count))
  2945.     if len(l_part1) < 150
  2946.         l_part1 = l_part1 + "+" + fld_form(fieldname(count)) + "+space(" +;
  2947.             spacer_l(fieldname(count)) + ")"
  2948.     else
  2949.         if len(l_part2) < 150
  2950.             l_part2 = l_part2 + "+" + fld_form(fieldname(count)) + "+space(" +;
  2951.                 spacer_l(fieldname(count)) + ")"
  2952.         else
  2953.             l_part3 = l_part3 + "+" + fld_form(fieldname(count)) + "+space(" +;
  2954.                 spacer_l(fieldname(count)) + ")"
  2955.         endif
  2956.     endif
  2957.     count = count + 1
  2958. enddo
  2959.  
  2960. header = header + "]"
  2961.  
  2962. use_part2 = !empty(&l_part2)
  2963. use_part3 = !empty(&l_part3)
  2964.  
  2965. ? &header
  2966.  
  2967. if !eof()
  2968.     for i = 1 to if(!is_display, lastrec(), 1)
  2969.         ? &l_part1
  2970.  
  2971.         if use_part2
  2972.             ?? &l_part2
  2973.             if use_part3
  2974.                 ?? &l_part3
  2975.             endif
  2976.         endif
  2977.  
  2978.         if !is_display
  2979.             skip
  2980.         endif
  2981.  
  2982.         if inkey() = 27
  2983.             return        
  2984.         endif
  2985.     next
  2986. endif
  2987.  
  2988. return
  2989.  
  2990. *
  2991. ** eoproc list_do
  2992.  
  2993.  
  2994. ***
  2995. * Procedure ORDER
  2996. * kjs, 09/30/86
  2997. * Evaluates stack for the SET ORDER command. Called from SET procedure.
  2998. * Sets execution class macro, class execution flag(s) and command line
  2999. * substitution macros.
  3000. *
  3001.  
  3002. procedure order
  3003.  
  3004. private stack_ptr, stack_item, to, exp, null
  3005.  
  3006. stack_ptr = 3
  3007.  
  3008. store .F. to to, exp, null
  3009.  
  3010. do while stack_ptr <= max_ptr
  3011.     stack_item = ""
  3012.     null = get_stack("stack_item")
  3013.  
  3014.     if upper(stack_item) = "TO" .and. !to
  3015.         to = .T.
  3016.     else
  3017.         exp1 = stack_item
  3018.         exp = .T.
  3019.     endif
  3020. enddo
  3021.  
  3022. do case
  3023.     case !(DBF_OPEN) .and. error_on
  3024.         ERRS5 = .T.
  3025.  
  3026.     case !(NTX_OPEN) .and. error_on
  3027.         ERRS9 = .T.
  3028.  
  3029.     case to .and. exp
  3030.         executor = "SETS"
  3031.         SETS21 = .T.
  3032.  
  3033.     case to .and. !exp
  3034.         executor = "SETS"
  3035.         SETS22 = .T.
  3036.     
  3037.     otherwise
  3038.         ERRS2 = .T.
  3039.  
  3040. endcase
  3041.  
  3042. return
  3043.  
  3044. *
  3045. ** eoproc order
  3046.  
  3047.  
  3048. ***
  3049. * Procedure PACK
  3050. * kjs, 05/02/86
  3051. * Evaluates the stack for PACK verb.
  3052. * Sets execution class macro, class execution flag(s) and command line
  3053. * substitution macros.
  3054. *
  3055.  
  3056. procedure pack
  3057.  
  3058. if max_ptr = 1
  3059.     if DBF_OPEN .or. !error_on
  3060.         executor = "DBF_NTX"
  3061.         DBF_NTX21 = .T.
  3062.     else
  3063.         ERRS5 = .T.
  3064.     endif
  3065. else
  3066.     ERRS2 = .T.
  3067. endif
  3068.  
  3069. return
  3070.  
  3071. *
  3072. ** eoproc pack
  3073.  
  3074.  
  3075. ***
  3076. * Procedure parse
  3077. * kjs, 05/20/86
  3078. * breaks command line into tokens and populates stack.
  3079. *
  3080.  
  3081. procedure parse
  3082.  
  3083. parameters stack_max
  3084.  
  3085. private line_len, scan_ptr, parse_more, tokens, collect_it, scan_char,;
  3086.     next_char, inc_before, inc_after, start_char, stop_char, item_count,;
  3087.     more_char
  3088.  
  3089. command = trim(ltrim(command))
  3090.  
  3091. if !empty(command)
  3092.     line_len = len(command)
  3093.     scan_ptr = 1
  3094.     parse_more = .T.
  3095.     tokens = " +-*/%<>#,!@.$^?=[()]'" + ["]
  3096.     stack_ptr = 1
  3097.     stack[1] = ""
  3098.     collect_it = .F.
  3099.     inc_before = .F.
  3100.     inc_after = .F.
  3101. else
  3102.     parse_more = .F.
  3103. endif
  3104.  
  3105. do while parse_more
  3106.  
  3107.     scan_char = substr(command, scan_ptr, 1)
  3108.  
  3109.     do case
  3110.         case !scan_char$tokens .and. "" <> scan_char
  3111.             ** if the scan character is NOT one of the parsed characters **
  3112.             collect_it = .T.
  3113.  
  3114.         case "" = scan_char
  3115.             ** if scan character is NULL, stop the parser. **
  3116.             parse_more = .F.
  3117.  
  3118.         case scan_char = " "
  3119.             ** if the scan character is a blank, check if stack element is **
  3120.             ** empty. If not, set the pre-collection stack increment flag **
  3121.             ** to true.                                                     ** 
  3122.  
  3123.             if "" <> stack[stack_ptr]
  3124.                 inc_before = .T.
  3125.             endif
  3126.  
  3127.         case scan_char$"+-*/%<>#,!@.$^?="
  3128.             ** If the scan character is one of the parsed elements set the **
  3129.             ** collector flag true, initialize the next character variable, **
  3130.             ** and check if either the pre or post collection flags need to **
  3131.             ** be set.                                                        **
  3132.  
  3133.             collect_it = .T.
  3134.  
  3135.             if stack[stack_ptr] <> scan_char
  3136.                 if "" <> stack[stack_ptr]
  3137.                     inc_before = .T.
  3138.                 endif
  3139.             endif
  3140.  
  3141.             next_char = if((scan_ptr+1) <= line_len,;
  3142.                 substr(command, scan_ptr+1, 1), "")
  3143.             if !next_char$tokens .and. "" <> next_char
  3144.                 inc_after = .T.
  3145.             endif
  3146.  
  3147.         case scan_char$"[('" .or. scan_char = ["]
  3148.             ** if the scan character is a string delimiter or a **
  3149.             ** grouping operator, check for any empty stack element **
  3150.             ** then check for balanced delimiters or groupers. **
  3151.  
  3152.             if "" <> stack[stack_ptr]
  3153.                 stack_ptr = stack_ptr + 1
  3154.                 stack[stack_ptr] = ""
  3155.             endif
  3156.  
  3157.             start_char = scan_char
  3158.  
  3159.             if scan_char = "("
  3160.                 stop_char = ")"
  3161.             else
  3162.                 if scan_char = "["
  3163.                     stop_char = "]"
  3164.                 else
  3165.                     stop_char = scan_char
  3166.                 endif
  3167.             endif
  3168.  
  3169.             item_count = 0
  3170.             more_char = .T.
  3171.  
  3172.             do while more_char            
  3173.                 stack[stack_ptr] = stack[stack_ptr] + scan_char
  3174.  
  3175.                 if start_char <> stop_char
  3176.                     if scan_char = start_char
  3177.                         item_count = item_count + 1
  3178.                     else
  3179.                         if scan_char = stop_char
  3180.                             item_count = item_count - 1
  3181.                         endif
  3182.                     endif
  3183.                 else
  3184.                     if item_count > 0
  3185.                         if scan_char = stop_char
  3186.                             item_count = item_count - 1
  3187.                         endif
  3188.                     else
  3189.                         item_count = 1
  3190.                     endif
  3191.                 endif
  3192.  
  3193.                 if item_count = 0 .or. "" = scan_char
  3194.                     more_char = .F.
  3195.                 else
  3196.                     scan_ptr = scan_ptr + 1
  3197.                     scan_char = substr(command, scan_ptr, 1)
  3198.                 endif
  3199.             enddo
  3200.             
  3201.             if scan_ptr > line_len
  3202.                 ERRS8 = .T.
  3203.             else
  3204.                 next_char = substr(command, scan_ptr + 1,1)
  3205.                 if !next_char$tokens .and. "" <> next_char
  3206.                     inc_after = .T.
  3207.                 endif
  3208.             endif
  3209.  
  3210.     endcase
  3211.      
  3212.     if inc_before
  3213.         stack_ptr = stack_ptr + 1
  3214.         stack[stack_ptr] = ""
  3215.         inc_before = .F.
  3216.     endif
  3217.  
  3218.     if collect_it                    && add current char to stack.
  3219.         stack[stack_ptr] = stack[stack_ptr] + scan_char
  3220.         collect_it = .F.
  3221.     endif
  3222.  
  3223.     if inc_after                     && increment after adding char.
  3224.         stack_ptr = stack_ptr + 1
  3225.         stack[stack_ptr] = ""
  3226.         inc_after = .F.
  3227.     endif
  3228.  
  3229.     scan_ptr = scan_ptr + 1
  3230.  
  3231. enddo
  3232.  
  3233. return
  3234.  
  3235. *
  3236. ** eoproc parse
  3237.  
  3238.  
  3239. ***
  3240. * Procedure PATH
  3241. * kjs, 05/07/86
  3242. * Evaluates stack for SET PATH command.  Called from SET procedure.
  3243. * Sets execution class macro, class execution flag(s) and command line
  3244. * substitution macros.
  3245. *
  3246.  
  3247. procedure path
  3248.  
  3249. private stack_ptr, to, null
  3250.  
  3251. stack_ptr = 3
  3252. store .F. to to, null
  3253.  
  3254. if upper(stack[stack_ptr]) = "TO"
  3255.     to = .T.
  3256.     null = get_expr1("exp1")
  3257. endif
  3258.  
  3259. if to
  3260.     executor = "SETS"
  3261.     SETS12 = .T.
  3262. else
  3263.     ERRS2 = .T.
  3264. endif
  3265.  
  3266. return
  3267.  
  3268. *
  3269. ** eoproc path
  3270.  
  3271.  
  3272. ***
  3273. * Procedure ques1
  3274. * kjs, 04/22/86
  3275. * Evaluates stack for single question mark (?).
  3276. * Sets execution class macro, class execution flag(s) and command line
  3277. * substitution macros.
  3278. *
  3279.  
  3280. procedure ques1
  3281.  
  3282. private stack_ptr
  3283.  
  3284. stack_ptr = 2
  3285.  
  3286. if get_stack("exp1")
  3287.     executor = "SCRN"
  3288.     SCRN25 = .T.
  3289. else
  3290.     executor = "SCRN"
  3291.     SCRN24 = .T.
  3292. endif
  3293.  
  3294. return 
  3295.  
  3296. *
  3297. ** eoproc ques1
  3298.     
  3299.  
  3300. ***
  3301. * Procedure ques2
  3302. * kjs, 04/22/86
  3303. * Evaluates stack for double question marks (??).
  3304. * Sets execution class macro, class execution flag(s) and command line
  3305. * substitution macros.
  3306. *
  3307.  
  3308. procedure ques2
  3309.  
  3310. private stack_ptr
  3311.  
  3312. stack_ptr = 1
  3313.  
  3314. if get_expr1("exp1")
  3315.     executor = "SCRN"
  3316.     SCRN27 = .T.
  3317. else
  3318.     executor = "SCRN"
  3319.     SCRN26 = .T.
  3320. endif
  3321.  
  3322. return 
  3323.  
  3324. *
  3325. ** eoproc ques2
  3326.  
  3327.  
  3328. ***
  3329. * Procedure QUIT
  3330. * kjs, 04/22/86
  3331. * called from analyze, analyzes the stack for the QUIT, EXIT or
  3332. * RETURN verb.
  3333. *
  3334.  
  3335. procedure quit
  3336.  
  3337. if max_ptr = 1
  3338.     executor = "CALLS"
  3339.     if stack[1]$"QUIT EXIT"
  3340.         CALLS6 = .T.
  3341.     else
  3342.         CALLS7 = .T.
  3343.     endif
  3344. else
  3345.     ERRS2 = .T.
  3346. endif
  3347.  
  3348. return
  3349.  
  3350. *
  3351. ** eoproc quit
  3352.  
  3353.  
  3354. ***
  3355. * Procedure rREAD
  3356. * kjs, 04/22/86
  3357. * Evaluates stack for READ verb. 
  3358. * Sets execution class macro, class execution flag(s) and command line
  3359. * substitution macros.
  3360. *
  3361.  
  3362. procedure rread
  3363.  
  3364. executor = "SCRN"
  3365. SCRN28 = .T.
  3366.  
  3367. return
  3368.  
  3369. *
  3370. ** eoproc rread
  3371.  
  3372.  
  3373. ***
  3374. * Procedure RECALL
  3375. * kjs, 05/02/86
  3376. * Evaluates the stack for RECALL verb.  Calls the condition and
  3377. * scope analyzer CND_SCP to set condition and scope flags and
  3378. * expressions.
  3379. * Sets execution class macro, class execution flag(s) and command line
  3380. * substitution macros.
  3381. *
  3382.  
  3383. procedure recall
  3384.  
  3385. private stack_ptr, for, while, next, record, all, stack_item
  3386.  
  3387. stack_ptr = 2
  3388. store .F. to for, while, next, record, all, condition
  3389. scope = 0
  3390.  
  3391. if cnd_scp()    && no errors during generic condition and scope analysis.
  3392.     do case 
  3393.         case for .or. while .or. all .or. next .or. record
  3394.             ** w/ w/o scope and/or condition. **
  3395.             if DBF_OPEN .or. !error_on
  3396.                 executor = "DBF_NTX"
  3397.                 DBF_NTX20 = .T.
  3398.             else    
  3399.                 ERRS5 = .T.
  3400.             endif
  3401.  
  3402.         case !for .and. !while .and. !all .and. !next .and. !record;
  3403.             .and. max_ptr = 1
  3404.             ** w/o scope or conditional **
  3405.             if DBF_OPEN .or. !error_on
  3406.                 executor = "DBF_NTX"
  3407.                 DBF_NTX20 = .T.
  3408.                 scope = 1       && use RECORD (scope = 1) for single recall.
  3409.                 exp3 = str(recno())
  3410.  
  3411.                 if &exp3 > lastrec() .and. error_on
  3412.                     ERRS6 = .T.
  3413.                     DBF_NTX20 = .F.
  3414.                 else
  3415.                     exp3 = "recno() = &exp3"
  3416.                 endif
  3417.             else
  3418.                 ERRS5 = .T.
  3419.             endif
  3420.  
  3421.         otherwise        
  3422.             ERRS2 = .T.
  3423.     endcase        
  3424. endif
  3425.  
  3426. return
  3427.  
  3428. *
  3429. ** eoproc recall
  3430.  
  3431.  
  3432. ***
  3433. * Procedure recall_it
  3434. * kjs, 05/14/86
  3435. * Called by do_cnd_scp called from DBF_NTX execution procedure.
  3436. *
  3437.  
  3438. procedure recall_it
  3439.  
  3440. recall
  3441.  
  3442. return
  3443.  
  3444. *
  3445. ** eoproc recall_it
  3446.  
  3447.  
  3448. ***
  3449. * Procedure RELATE
  3450. * kjs, 05\23\86
  3451. * Evaluates stack for SET RELATION command.  Called from SET procedure.
  3452. * Sets execution class macro, class execution flag(s) and command line
  3453. * substitution macros.
  3454. *
  3455.  
  3456. procedure relate
  3457.  
  3458. private stack_ptr, to, exp, alias, stack_item
  3459.  
  3460. stack_ptr = 3
  3461. store .F. to to, exp, alias
  3462.  
  3463. do while stack_ptr <= max_ptr
  3464.     stack_item = upper(stack[stack_ptr])
  3465.     do case
  3466.         case stack_item = "TO"
  3467.             to = .T.
  3468.             exp = get_expr1("exp1")
  3469.  
  3470.         case stack_item = "INTO"
  3471.             alias = get_expr1("exp2")
  3472.  
  3473.         otherwise
  3474.             stack_ptr = stack_ptr + 1
  3475.     endcase
  3476. enddo
  3477.  
  3478. if !err()
  3479.     do case
  3480.         case to .and. exp .and. alias .and. if(error_on, DBF_OPEN, .T.)
  3481.             executor = "SETS"
  3482.             SETS16 = .T.
  3483.  
  3484.         case to .and. !exp .and. !alias .and. if(error_on, DBF_OPEN, .T.)
  3485.             executor = "SETS"
  3486.             SETS15 = .T.
  3487.  
  3488.         case if(error_on, !DBF_OPEN, .F.)
  3489.             ERRS5 = .T.
  3490.  
  3491.         otherwise
  3492.             ERRS2 = .T.
  3493.     endcase
  3494. endif
  3495.  
  3496. return
  3497.  
  3498. *
  3499. ** eoproc relate
  3500.  
  3501.  
  3502. ***
  3503. * Procedure RELEASE
  3504. * kjs, 04/22/86
  3505. * Evaluates stack for the RELEASE verb.
  3506. * Sets execution class macro, class execution flag(s) and command line
  3507. * substitution macros.
  3508. *
  3509.  
  3510. procedure release
  3511.  
  3512. private stack_ptr
  3513.  
  3514. stack_ptr = 2
  3515.  
  3516. if max_ptr = 2
  3517.     var1 = stack[stack_ptr]
  3518.     if type("&var1") <> "U"
  3519.         executor = "VARS"
  3520.         VARS11 = .T.
  3521.     else
  3522.         ERRS3 = .T.
  3523.     endif
  3524. else
  3525.     ERRS2 = .T.
  3526. endif
  3527.  
  3528. return
  3529.  
  3530. *
  3531. ** eoproc release
  3532.  
  3533.  
  3534. ***
  3535. * Procedure REPLACE
  3536. * kjs, 09/16/86
  3537. * Evaluates stack for the REPLACE command.
  3538. * Sets execution class macro, class execution flag(s) and command line
  3539. * substitution macros.
  3540. *
  3541.  
  3542. procedure replace
  3543.  
  3544. private stack_ptr, stack_item, dest, with, source, all, null
  3545.  
  3546. stack_ptr = 2
  3547. store .F. to dest, with, source, all
  3548.  
  3549. do while stack_ptr <= max_ptr
  3550.  
  3551.     stack_item = ""
  3552.     null = get_stack("stack_item")
  3553.  
  3554.     do case
  3555.         case upper(stack_item) = "ALL"
  3556.             all = .T.
  3557.  
  3558.         case upper(stack_item) = "WITH"
  3559.             with = .T.
  3560.  
  3561.         otherwise
  3562.             if "" == var1
  3563.                 var1 = stack_item
  3564.                 dest = .T.
  3565.             else
  3566.                 exp1 = stack_item
  3567.                 source = .T.
  3568.             endif
  3569.     endcase
  3570. enddo
  3571.  
  3572. do case
  3573.     case !DBF_OPEN .and. error_on
  3574.         ERRS5 = .T.
  3575.  
  3576.     case dest .and. with .and. source .and. !all
  3577.         executor = "DBF_NTX"
  3578.         DBF_NTX26 = .T.
  3579.  
  3580.     case dest .and. with .and. source .and. all
  3581.         executor = "DBF_NTX"
  3582.         DBF_NTX27 = .T.
  3583.  
  3584.     otherwise
  3585.         ERRS2 = .T.
  3586. endcase
  3587.  
  3588. return
  3589.  
  3590. *
  3591. ** eoproc replace
  3592.  
  3593.  
  3594. ***
  3595. * Procedure RUN
  3596. * kjs, 04/22/86
  3597. * Evaluates stack for the RUN or ! verb.
  3598. * Sets execution class macro, class execution flag(s) and command line
  3599. * substitution macros.
  3600. *
  3601.  
  3602. procedure run
  3603.  
  3604. exp1 = substr(command, len(stack[1]) + 1)
  3605.  
  3606. if !empty(exp1)
  3607.     executor = "CALLS"
  3608.     CALLS3 = .T.
  3609. else
  3610.     ERRS2 = .T.
  3611. endif
  3612.  
  3613. return
  3614.  
  3615. *
  3616. ** eoproc run
  3617.  
  3618.  
  3619. ***
  3620. * Procedure SEEK
  3621. * kjs, 04/22/86
  3622. * Evaluates stack for the SEEK verb.
  3623. * Sets execution class macro, class execution flag(s) and command line
  3624. * substitution macros.
  3625. *
  3626.  
  3627. procedure seek
  3628.  
  3629. private stack_ptr
  3630.  
  3631. stack_ptr = 1
  3632.  
  3633. if DBF_OPEN .or. !error_on
  3634.     if NTX_OPEN .or. !error_on
  3635.         if get_expr1("exp1")
  3636.             executor = "DBF_NTX"
  3637.             DBF_NTX17 = .T.
  3638.         else
  3639.             ERRS2 = .T.
  3640.         endif
  3641.     else
  3642.         ERRS9 = .T.
  3643.     endif
  3644. else
  3645.     ERRS5 = .T.
  3646. endif
  3647.  
  3648. return
  3649.  
  3650. *
  3651. ** eoproc seek
  3652.  
  3653.  
  3654. ***
  3655. * Procedure SELECT
  3656. * kjs, 04/22/86
  3657. * Evaluates stack for the SELECT verb.
  3658. * Sets execution class macro, class execution flag(s) and command line
  3659. * substitution macros.
  3660. *
  3661.  
  3662. procedure select
  3663.  
  3664. private stack_ptr, select, expr_type
  3665.  
  3666. stack_ptr = 1
  3667. select = .F.
  3668. expr_type = ""
  3669.  
  3670. if get_expr1("exp1")
  3671.     if select(exp1) > 0
  3672.         select = .T.
  3673.     else
  3674.         expr_type = type(exp1)
  3675.  
  3676.         if expr_type = "N"
  3677.             if val(exp1) <= 250 .and. val(exp1) >= 0
  3678.                 select = .T.
  3679.             endif
  3680.         endif
  3681.     endif
  3682. endif
  3683.  
  3684. if select
  3685.     executor = "DBF_NTX"
  3686.     DBF_NTX16 = .T.
  3687. else
  3688.     ERRS2 = .T.
  3689. endif
  3690.  
  3691. return
  3692.  
  3693. *
  3694. ** eoproc select
  3695.  
  3696.  
  3697. ***
  3698. * Procedure SSET
  3699. * kjs, 10/07/86
  3700. * Evaluates the next key word in SET command.  Checks abbreviation of
  3701. * key word.  Key ok, [do_sets] procedure macro is set.  Key fail or not
  3702. * found, set unknown command error flag ERRS1.
  3703. *
  3704.  
  3705. procedure sset
  3706.  
  3707. private stack_ptr, seek_strng, position, do_sets, error
  3708.  
  3709. stack_ptr = 2
  3710. do_sets = ""
  3711. error = 0
  3712.  
  3713. seek_strng = upper(stack[stack_ptr])
  3714. position = at("." + seek_strng, set_list)
  3715.  
  3716. if position > 0
  3717.     if cmd_abbr(seek_strng, trim(substr(set_list, (position + 1), 10)))
  3718.         do_sets = substr(set_proc, position, 10)
  3719.     else
  3720.         error = 1
  3721.     endif
  3722. else
  3723.     error = 1
  3724. endif
  3725.  
  3726. if error = 1
  3727.     ERRS1 = .T.
  3728. else
  3729.     do &do_sets
  3730. endif
  3731.  
  3732. return
  3733.  
  3734. *
  3735. ** eoproc set
  3736.  
  3737.  
  3738. ***
  3739. * Procedure sets
  3740. * kjs, 06/12/86
  3741. * executes the SETS class of commands
  3742. *
  3743.  
  3744. procedure sets
  3745.  
  3746. do case
  3747.     case SETS1
  3748.         set color to &exp1
  3749.         color_stat = exp1
  3750.         SETS1 = .F.
  3751.  
  3752.     case SETS2
  3753.         set confirm &exp1
  3754.         confr_stat = exp1
  3755.         SETS2 = .F.
  3756.  
  3757.     case SETS3
  3758.         set decimal to &exp1
  3759.         SETS3 = .F.
  3760.  
  3761.     case SETS4
  3762.         set default to &exp1
  3763.         SETS4 = .F.
  3764.  
  3765.     case SETS5
  3766.         set delimiters &exp1
  3767.         delim_stat = exp1
  3768.         SETS5 = .F.
  3769.  
  3770.     case SETS6
  3771.         set delimiters to &exp1
  3772.         SETS6 = .F.
  3773.  
  3774.     case SETS7
  3775.         set escape &exp1
  3776.         SETS7 = .F.
  3777.  
  3778.     case SETS8
  3779.         set fixed &exp1
  3780.         SETS8 = .F.
  3781.  
  3782.     case SETS9
  3783.         set function &exp1 to &exp2
  3784.         SETS9 = .F.
  3785.  
  3786.     case SETS10
  3787.         set index to &list0, &list1, &list2, &list3, &list4, &list5,;
  3788.             &list6, &list7, &list8, &list9
  3789.         SETS10 = .F.
  3790.  
  3791.         if empty(list0)
  3792.             NTX_OPEN = .F.
  3793.         else
  3794.             NTX_OPEN = .T.
  3795.         endif
  3796.  
  3797.     case SETS11
  3798.         set intensity &exp1
  3799.         inten_stat = exp1
  3800.         SETS11 = .F.
  3801.  
  3802.     case SETS12
  3803.         set path to &exp1
  3804.         SETS12 = .F.
  3805.  
  3806.     case SETS13
  3807.         set unique &exp1
  3808.         SETS13 = .F.
  3809.  
  3810.     case SETS14
  3811. * CAUTION:  5.0 A31
  3812. *        set key &exp1 to &exp2
  3813.         SETS14 = .F.
  3814.  
  3815.     case SETS15
  3816.         set relation to
  3817.         SETS15 = .F.
  3818.  
  3819.     case SETS16
  3820.         relation = exp1
  3821.         alias = exp2
  3822.         set relation to &relation into &alias
  3823.         SETS16 = .F.
  3824.  
  3825.     case SETS17
  3826.         filter = exp1
  3827.         set filter to &filter
  3828.         SETS17 = .F.
  3829.  
  3830.     case SETS18
  3831.         filter = ""
  3832.         set filter to
  3833.         SETS18 = .F.
  3834.  
  3835.     case SETS19
  3836.         set exclusive &exp1
  3837.         SETS19 = .F.
  3838.  
  3839.     case SETS20
  3840.         set exact &exp1
  3841.         exact_stat = exp1
  3842.         SETS20 = .F.
  3843.  
  3844.     case SETS21
  3845.         set order to &exp1
  3846.         SETS21 = .F.
  3847.  
  3848.     case SETS22
  3849.         set order to
  3850.         SETS22 = .F.
  3851. endcase
  3852.  
  3853. return
  3854.  
  3855. *
  3856. ** eoproc sets
  3857.  
  3858.  
  3859. ***
  3860. * Procedure set_lex
  3861. * kjs, 04/22/86
  3862. * Locates the verb in verb_list string and initializes "lex_proc" macro with 
  3863. * the corresponding procedure name found in the lex_list string.
  3864. * Calls CMD_ABBR().
  3865. *
  3866.  
  3867. procedure set_lex
  3868.  
  3869. private seek_strng, verb_string, position
  3870.  
  3871. if assign_chk()
  3872.     lex_proc = "ASSIGN"
  3873. else
  3874.     seek_strng = upper(stack[1])
  3875.     position = at("." + seek_strng, verb_list)
  3876.     if position > 0
  3877.         verb_string = trim(substr(verb_list, position + 1, 9))
  3878.         if cmd_abbr(seek_strng, verb_string)
  3879.             lex_proc = substr(lex_list, position, 10)
  3880.         else
  3881.             lex_proc = "UNKNOWN"
  3882.         endif
  3883.     else
  3884.         lex_proc = "UNKNOWN"
  3885.     endif
  3886. endif
  3887.  
  3888. return
  3889.  
  3890. *
  3891. ** eoproc set_lex
  3892.  
  3893.  
  3894. ***
  3895. * Procedure set_sets
  3896. * kjs, 05/08/86
  3897. * Called from interactive prompt.  Resets the SET commands to their
  3898. * DEFAULT settings.
  3899. *
  3900.  
  3901. procedure set_sets
  3902.  
  3903. set alternate OFF
  3904. set alternate to
  3905. set bell OFF
  3906. set color to
  3907. set confirm OFF
  3908. set console ON
  3909. set decimal to 2
  3910. set default to
  3911. set deleted OFF
  3912. set delimiters OFF
  3913. set delimiters to
  3914. set device to SCREEN
  3915. set escape ON
  3916. set exact OFF
  3917. set exclusive ON
  3918. set filter to
  3919. set fixed OFF
  3920. set format to
  3921.  
  3922. for i = 2 to 40
  3923.     set function i to ""
  3924. next
  3925.  
  3926. set index to
  3927. set intensity ON
  3928.  
  3929. for i = -39 to 387
  3930. *    set key i to ""
  3931. * CAUTION:  5.0 A31  (this was illegal anyway)
  3932.     set key i to
  3933. next
  3934.  
  3935. set order to 1
  3936. set print OFF
  3937. set path to
  3938. set relation to
  3939. set scoreboard ON
  3940. set unique OFF
  3941.  
  3942. inten_stat = "ON"
  3943. color_stat = "7/0"
  3944. delim_stat = "OFF"
  3945. confr_stat = "OFF"
  3946. exact_stat = "OFF"
  3947.  
  3948. return
  3949.  
  3950. *
  3951. ** eoproc set_sets
  3952.  
  3953.  
  3954. ***
  3955. * Procedure SKIP
  3956. * kjs, 04/22/86
  3957. * Evaluates stack for SKIP verb.
  3958. * Sets execution class macro, class execution flag(s) and command line
  3959. * substitution macros.
  3960. *
  3961.  
  3962. procedure skip
  3963.  
  3964. private stack_ptr
  3965.  
  3966. stack_ptr = 1
  3967.         
  3968. if DBF_OPEN .or. !error_on
  3969.     if get_expr1("exp1")
  3970.         if is_n_expr(&exp1)
  3971.             if if(error_on, &exp1 <= lastrec(), .T.)
  3972.                 executor = "DBF_NTX"
  3973.                 DBF_NTX11 = .T.
  3974.             else
  3975.                 ERRS6 = .T.
  3976.             endif
  3977.         else
  3978.             ERRS3 = .T.
  3979.         endif
  3980.     else
  3981.         executor = "DBF_NTX"
  3982.         DBF_NTX10 = .T.
  3983.     endif
  3984. else
  3985.     ERRS5 = .T.
  3986. endif
  3987.  
  3988. return
  3989.  
  3990. *
  3991. ** eoproc skip
  3992.  
  3993.  
  3994. ***
  3995. * Procedure stuff_up
  3996. * kjs, 04/26/86
  3997. * Clears the get list when an up-arrow is depressed.
  3998. * Called from HISTORY procedure. 
  3999. *
  4000.  
  4001. procedure stuff_up
  4002.  
  4003. parameters call_proc, call_line, call_var
  4004.  
  4005. if call_proc <> "STUFF_UP"
  4006.     clear gets
  4007. endif
  4008.  
  4009. return
  4010.  
  4011. *
  4012. ** eoproc stuff_up
  4013.  
  4014.  
  4015. ***
  4016. * Procedure stuff_dn
  4017. * kjs, 04/26/86
  4018. * Clears the get list when a down-arrow is depressed.
  4019. * Called from HISTORY procedure.
  4020.  
  4021. procedure stuff_dn
  4022.  
  4023. parameters call_proc, call_line, call_var
  4024.  
  4025. if call_proc <> "STUFF_DN"
  4026.     clear gets
  4027. endif
  4028.  
  4029. return
  4030.  
  4031. *
  4032. ** eoproc stuff_dn
  4033.  
  4034.  
  4035. ***
  4036. * Procedure scrn
  4037. * kjs, 06/12/86
  4038. * executes the SCRN class commands
  4039. *
  4040.  
  4041. procedure scrn
  4042.  
  4043. do case
  4044.     case SCRN1
  4045.         @ &coord1, &coord2    
  4046.         SCRN1 = .F.
  4047.  
  4048.     case SCRN2
  4049.         @ &coord1, &coord2 clear
  4050.         SCRN2 = .F.
  4051.  
  4052.     case SCRN3
  4053.         @ &coord1, &coord2 say &say_exp
  4054.         SCRN3 = .F.
  4055.  
  4056.     case SCRN4
  4057.         @ &coord1, &coord2 say &say_exp picture &say_pict
  4058.         SCRN4 = .F.
  4059.  
  4060.     case SCRN5
  4061.         @ &coord1, &coord2 get &get_exp
  4062.         SCRN5 = .F.
  4063.  
  4064.     case SCRN6
  4065.         @ &coord1, &coord2 get &get_exp picture &get_pict
  4066.         SCRN6 = .F.
  4067.  
  4068.     case SCRN7
  4069.         range1 = rng_exp1
  4070.         range2 = rng_exp2
  4071.         @ &coord1, &coord2 get &get_exp range &range1, &range2
  4072.         SCRN7 = .F.
  4073.  
  4074.     case SCRN8
  4075.         @ &coord1, &coord2 get &get_exp valid &valid_exp
  4076.         SCRN8 = .F.
  4077.  
  4078.     case SCRN10
  4079.         @ &coord1, &coord2 get &get_exp picture &get_pict valid &valid_exp
  4080.         SCRN10 = .F.
  4081.  
  4082.     case SCRN11
  4083.         range1 = rng_exp1
  4084.         range2 = rng_exp2
  4085.         @ &coord1, &coord2 get &get_exp picture &get_pict range &range1,;
  4086.             &range2
  4087.         SCRN11 = .F.
  4088.  
  4089.     case SCRN13
  4090.         @ &coord1, &coord2 say &say_exp get &get_exp
  4091.         SCRN13 = .F.
  4092.  
  4093.     case SCRN14
  4094.         @ &coord1, &coord2 say &say_exp picture &say_pict get &get_exp
  4095.         SCRN14 = .F.
  4096.  
  4097.     case SCRN15
  4098.         @ &coord1, &coord2 say &say_exp picture &say_pict get &get_exp;
  4099.             picture &get_pict
  4100.         SCRN15 = .F.
  4101.  
  4102.     case SCRN16
  4103.         range1 = rng_exp1
  4104.         range2 = rng_exp2
  4105.         @ &coord1, &coord2 say &say_exp picture &say_pict get &get_exp;
  4106.             picture &get_pict range &range1, &range2
  4107.         SCRN16 = .F.
  4108.  
  4109.     case SCRN17
  4110.         @ &coord1, &coord2 say &say_exp picture &say_pict get &get_exp;
  4111.             picture &get_pict valid &valid_exp
  4112.         SCRN17 = .F.
  4113.  
  4114.     case SCRN19
  4115.         @ &coord1, &coord2 say &say_exp get &get_exp picture &get_pict
  4116.         SCRN19 = .F.
  4117.  
  4118.     case SCRN20
  4119.         range1 = rng_exp1
  4120.         range2 = rng_exp2
  4121.         @ &coord1, &coord2 say &say_exp get &get_exp picture &get_pict;
  4122.             range &range1, &range2
  4123.         SCRN20 = .F.
  4124.  
  4125.     case SCRN21
  4126.         @ &coord1, &coord2 say &say_exp get &get_exp picture &get_pict;
  4127.             valid &valid_exp
  4128.         SCRN21 = .F.
  4129.  
  4130.     case SCRN22
  4131.         @ &coord1, &coord2, &coord3, &coord4 box &box_exp
  4132.         SCRN22 = .F.
  4133.  
  4134.     case SCRN23
  4135.         clear
  4136.         SCRN23 = .F.
  4137.  
  4138.     case SCRN24
  4139.         ?
  4140.         SCRN24 = .F.
  4141.  
  4142.     case SCRN25
  4143.         ? &exp1
  4144.         SCRN25 = .F.
  4145.  
  4146.     case SCRN26
  4147.         ??
  4148.         SCRN26 = .F.
  4149.  
  4150.     case SCRN27
  4151.         ?? &exp1
  4152.         SCRN27 = .F.
  4153.  
  4154.     case SCRN28
  4155.         cur_row = row()
  4156.         read
  4157.         @ cur_row+1, 1
  4158.         SCRN28 = .F.
  4159. endcase
  4160.  
  4161. return
  4162.  
  4163. *
  4164. ** eoproc scrn
  4165.  
  4166.  
  4167. ***
  4168. * Procedure TYPE
  4169. * kjs, 04/22/86
  4170. * Evaluates stack for TYPE verb.
  4171. * Sets execution class macro, class execution flag(s) and command line
  4172. * substitution macros.
  4173. *
  4174.  
  4175. procedure type
  4176.  
  4177. private stack_ptr
  4178.  
  4179. stack_ptr = 1
  4180.  
  4181. if get_expr1("exp1")
  4182.     executor = "DBF_NTX"
  4183.     DBF_NTX23 = .T.
  4184. else
  4185.     ERRS2 = .T.
  4186. endif
  4187.  
  4188. return
  4189.  
  4190. *
  4191. ** eoproc type
  4192.  
  4193.  
  4194. ***
  4195. * Procedure unknown
  4196. * kjs, 09/23/86
  4197. * If command cannot be found this routine is called to set unknown
  4198. * error flag.
  4199. *
  4200.  
  4201. procedure unknown
  4202.  
  4203. ERRS1 = .T.
  4204.  
  4205. return
  4206.  
  4207. *
  4208. ** eoproc unknown
  4209.  
  4210.  
  4211. ***
  4212. * Procedure UNLOCK
  4213. * kjs, 07/28/86
  4214. * Evaluates stack for UNLOCK verb.
  4215. * Sets execution class macro, class execution flag(s) and command line
  4216. * substitution macros.
  4217. *
  4218.  
  4219. procedure unlock
  4220.  
  4221. private stack_ptr
  4222.  
  4223. stack_ptr = 1
  4224.  
  4225. if max_ptr = 1
  4226.     executor = "DBF_NTX"
  4227.     DBF_NTX24 = .T.
  4228. else
  4229.     if max_ptr = 2 .and. upper(stack[2]) = "ALL"
  4230.         executor = "DBF_NTX"
  4231.         DBF_NTX25 = .T.
  4232.     else
  4233.         ERRS1 = .T.
  4234.     endif
  4235. endif
  4236.  
  4237. return
  4238.  
  4239. *
  4240. ** eoproc unlock
  4241.                       
  4242.  
  4243. ***
  4244. * Procedure USE
  4245. * kjs, 04/22/86
  4246. * Evaluates stack for USE verb.
  4247. * Sets execution class macro, class execution flag(s) and command line
  4248. * substitution macros.
  4249. *
  4250.  
  4251. procedure use 
  4252.  
  4253. private stack_ptr, file, dbf, index, ntx, alias, name, excl,;
  4254.   stack_item
  4255.  
  4256. stack_ptr = 1
  4257. store .F. to file, dbf, index, ntx, alias, name, excl
  4258.  
  4259. do while stack_ptr <= max_ptr .and. !err()
  4260.  
  4261.     stack_item = upper(stack[stack_ptr])
  4262.  
  4263.     do case 
  4264.         case "USE" = stack_item
  4265.             if get_expr1("dbf_file")
  4266.                 file = .T.
  4267.                 dbf = if(error_on, file("&dbf_file..DBF"), .T.)
  4268.             endif
  4269.  
  4270.         case cmd_abbr(stack_item, "INDEX")
  4271.             index = .T.
  4272.             ntx = get_list("NF")
  4273.  
  4274.         case cmd_abbr(stack_item, "ALIAS")
  4275.             alias = .T.
  4276.             name = get_expr1("exp2")
  4277.  
  4278.         case cmd_abbr(stack_item, "EXCLUSIVE")
  4279.             excl = .T.
  4280.             stack_ptr = stack_ptr + 1
  4281.  
  4282.         otherwise
  4283.             ERRS2 = .T.
  4284.     endcase
  4285. enddo
  4286.  
  4287. if !err()
  4288.     do case
  4289.         case !file .and. !dbf .and. !index .and. !ntx .and. !alias;
  4290.             .and. !excl
  4291.             *** Close the current selected data file. ***
  4292.             executor = "DBF_NTX"
  4293.             DBF_NTX1 = .T.
  4294.  
  4295.         case file .and. dbf .and. !index .and. !ntx .and. !alias;
  4296.             .and. !excl
  4297.             executor = "DBF_NTX"
  4298.             DBF_NTX2 = .T.
  4299.  
  4300.         case file .and. dbf .and. index .and. ntx .and. !alias;
  4301.             .and. !excl
  4302.             executor = "DBF_NTX"
  4303.             DBF_NTX3 = .T.
  4304.  
  4305.         case file .and. dbf .and. alias .and. name .and. !index;
  4306.             .and. !ntx .and. !excl
  4307.             executor = "DBF_NTX"
  4308.             DBF_NTX4 = .T.
  4309.  
  4310.         case file .and. dbf .and. index .and. ntx .and. alias;
  4311.             .and. name .and. !excl
  4312.             executor = "DBF_NTX"
  4313.             DBF_NTX5 = .T.
  4314.  
  4315.         case file .and. dbf .and. !index .and. !ntx .and. !alias;
  4316.             .and. excl
  4317.             executor = "DBF_NTX"
  4318.             DBF_NTX32 = .T.
  4319.  
  4320.         case file .and. dbf .and. index .and. ntx .and. !alias;
  4321.             .and. excl
  4322.             executor = "DBF_NTX"
  4323.             DBF_NTX33 = .T.
  4324.  
  4325.         case file .and. dbf .and. alias .and. name .and. !index;
  4326.             .and. !ntx .and. excl
  4327.             executor = "DBF_NTX"
  4328.             DBF_NTX34 = .T.
  4329.  
  4330.         case file .and. dbf .and. index .and. ntx .and. alias;
  4331.             .and. name .and. excl
  4332.             executor = "DBF_NTX"
  4333.             DBF_NTX35 = .T.
  4334.  
  4335.         case file .and. !dbf .and. !index .and. !ntx .and. error_on
  4336.             ERRS7 = .T.
  4337.  
  4338.         case file .and. dbf .and. index .and. !ntx .and. error_on
  4339.             ERRS11 = .T.
  4340.  
  4341.         otherwise
  4342.             ERRS2 = .T.
  4343.     endcase
  4344. endif
  4345. return
  4346.  
  4347. *
  4348. ** eoproc use 
  4349.  
  4350.  
  4351. ***
  4352. * Procedure vars
  4353. * kjs, 06/12/86
  4354. * executes the VARS class of commands
  4355. *
  4356.  
  4357. procedure vars
  4358.  
  4359. do case
  4360.     case VARS1
  4361.         accept to &var1
  4362.         VARS1 = .F.
  4363.  
  4364.     case VARS2
  4365.         accept &exp1 to &var1
  4366.         VARS2 = .F.
  4367.  
  4368.     case VARS3
  4369.         input to &var1
  4370.         VARS3 = .F.
  4371.  
  4372.     case VARS4
  4373.         input &exp1 to &var1
  4374.         VARS4 = .F.
  4375.  
  4376.     case VARS5
  4377.         wait
  4378.         VARS5 = .F.
  4379.  
  4380.     case VARS6
  4381.         wait to &var1
  4382.         VARS6 = .F.
  4383.  
  4384.     case VARS7
  4385.         wait &exp1 to &var1
  4386.         VARS7 = .F.
  4387.  
  4388.     case VARS8
  4389.         wait &exp1
  4390.         VARS8 = .F.
  4391. endcase
  4392.  
  4393. return
  4394.  
  4395. *
  4396. ** eoproc var
  4397.  
  4398.  
  4399. ***
  4400. * Procedure what_key
  4401. * kjs, 04/16/86
  4402. * displays ascii decimal value of a key
  4403. *
  4404.  
  4405. procedure what_key
  4406.  
  4407. private key, trash
  4408.  
  4409. save screen
  4410.  
  4411. clear
  4412. key = 0
  4413.  
  4414. do while key <> 272
  4415.     trash = inkey()
  4416.     key = lastkey()
  4417.     @ 10,10 say str(key,4) + " <ALT-Q> returns (272)."
  4418.     for col = 40 to 60 step 1
  4419.         @ 10, col say ""
  4420.     next
  4421.     for col = 40 to 60 step 2
  4422.         @ 10, col say ""
  4423.     next
  4424. enddo
  4425.  
  4426. restore screen
  4427.  
  4428. return
  4429.  
  4430. *
  4431. ** eoproc what_key
  4432.  
  4433.  
  4434. ***
  4435. * Procedure wWAIT
  4436. * kjs, 04/11/86
  4437. * Evaluates stack for WAIT verb.
  4438. * Sets execution class macro, class execution flag(s) and command line
  4439. * substitution macros.
  4440. *
  4441.  
  4442. procedure wwait
  4443.  
  4444. private stack_ptr, string, to, dest, stack_item
  4445.  
  4446. stack_ptr = 1
  4447. store .F. to string, to, dest
  4448.  
  4449. do while stack_ptr <= max_ptr
  4450.     stack_item = upper(stack[stack_ptr])
  4451.     do case
  4452.         case stack_item = "WAIT"
  4453.             string = get_expr1("exp1")
  4454.             if upper(exp1) = "TO"
  4455.                 string = .F.
  4456.                 exp1 = ""
  4457.                 stack_ptr = stack_ptr - 1
  4458.             endif
  4459.  
  4460.         case stack_item = "TO"
  4461.             to = .T.
  4462.             dest = get_expr1("var1")
  4463.  
  4464.         otherwise
  4465.             stack_ptr = stack_ptr + 1
  4466.     endcase
  4467. enddo
  4468.  
  4469. if !err()
  4470.     do case
  4471.         case !to .and. !dest .and. !string
  4472.             executor = "VARS"
  4473.             VARS5 = .T.
  4474.  
  4475.         case to .and. dest .and. !string
  4476.             executor = "VARS"
  4477.             VARS6 = .T.
  4478.             VARS9 = .T.
  4479.  
  4480.         case to .and. dest .and. string
  4481.             executor = "VARS"
  4482.             VARS7 = .T.
  4483.             VARS9 = .T.
  4484.  
  4485.         case !to .and. !dest .and. string
  4486.             executor = "VARS"
  4487.             VARS8 = .T.
  4488.  
  4489.         otherwise
  4490.             ERRS2 = .T.
  4491.     endcase
  4492. endif
  4493.  
  4494. return
  4495.  
  4496. *
  4497. ** eoproc wwait
  4498.  
  4499.  
  4500. ***
  4501. * Procedure ZAP
  4502. * kjs, 10/24/86
  4503. * Evaluates stack for ZAP verb. 
  4504. * Sets execution class macro, class execution flag.
  4505. *
  4506.  
  4507. procedure zap
  4508.  
  4509. if error_on .and. !DBF_OPEN
  4510.   ERRS5 = .T.
  4511. else
  4512.   if stack_ptr = 1
  4513.      executor = "DBF_NTX"
  4514.      DBF_NTX36 = .T.
  4515.   else
  4516.      ERRS2 = .T.
  4517.   endif
  4518. endif
  4519.  
  4520. return
  4521.  
  4522. *
  4523. ** eoproc ZAP
  4524.  
  4525.  
  4526. *********************************
  4527. * End of procedures for dot.prg *
  4528. *********************************
  4529.  
  4530. *********************
  4531. * Functions for Dot *
  4532. *********************
  4533.  
  4534.  
  4535. ***
  4536. * Function assign_chk
  4537. * kjs, 09/23/86
  4538. * Check command for assignment operator.
  4539. *
  4540. *    Usage :    assign_chk()
  4541. *
  4542. *     Returns:
  4543. *        .T. - assignment operator found after first identifier.
  4544. *        .F. - no operator found.
  4545. *
  4546. * Called from SET_LEX procedure.
  4547. *
  4548.  
  4549. function assign_chk
  4550.  
  4551. private stack_item, status
  4552.  
  4553. stack_item = ""
  4554. status = .F.
  4555.  
  4556. if max_ptr >= 2
  4557.   stack_item = stack[2]
  4558. endif
  4559.  
  4560. if substr(stack[1],1,1)$"_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  4561.   if stack_item == "="
  4562.         status = .T.
  4563.   else
  4564.      if substr(stack_item,1,1) == "["   && if no close brace error in parser.
  4565.         if max_ptr >= 3
  4566.            if stack[3] == "="
  4567.               status = .T.
  4568.            endif
  4569.         endif 
  4570.      endif
  4571.   endif
  4572. endif
  4573.  
  4574. return (status)
  4575.  
  4576. *
  4577. ** eofunc assign_chk
  4578.  
  4579.  
  4580. ***
  4581. * Function cmd_abbr
  4582. * kjs, 04/17/86
  4583. * Checks verb for correct abbreviation.
  4584. *
  4585. *    Usage   : cmd_abbr(<string1>, <string2>)
  4586. *
  4587. *        <string1> - upper of verb to check.
  4588. *        <string2> - upper full spelling of verb.
  4589. *
  4590. *     Returns :
  4591. *        .T. - s1 ok.
  4592. *        .F. - s1 NOT ok.
  4593. *
  4594. *    Notes      :
  4595. * 
  4596. *        1. DIR is an exception to the four char abbreviation definition.        
  4597. *
  4598.  
  4599. function cmd_abbr
  4600.  
  4601. parameters s1, s2
  4602.  
  4603. private status, s1_len, abbr_len
  4604.  
  4605. status = .F.
  4606. s1_len = len(s1)
  4607. abbr_len = len(s2)
  4608.  
  4609. if abbr_len > 4
  4610.     abbr_len = 4
  4611. endif
  4612.  
  4613. s1 = "." + s1
  4614. s2 = "." + s2
  4615.  
  4616. if s1$s2 .and. s1_len >= abbr_len .or. s1 == ".DIR"
  4617.     status = .T.
  4618. endif
  4619.  
  4620. return (status)
  4621.  
  4622. *
  4623. ** eofunc cmd_abbr
  4624.  
  4625.  
  4626. ***
  4627. * Function cnd_scp
  4628. * kjs, 05/01/86
  4629. * Evaluates the stack for condition and scope.  Called from procedures that
  4630. * need to analyze conditions and/or scope key words.
  4631. *
  4632. *    Usage :    cnd_scp()
  4633. *
  4634. *     Returns:
  4635. *        .T. - if no error occurred in analysis.
  4636. *        .F. - error occurred.
  4637. *
  4638. *    Control variables effected:
  4639. *        Strings   -   condition
  4640. *                      scope
  4641. *
  4642. *        Logicals  -   for
  4643. *                      while
  4644. *                      record
  4645. *                      all
  4646. *                      next
  4647. *                      rewind_dbf
  4648. *                      to
  4649. *                      source
  4650. *
  4651. *        Numerics  -   scope
  4652. *
  4653.  
  4654. function cnd_scp
  4655.  
  4656. rewind_dbf = .F.
  4657.  
  4658. do while stack_ptr <= max_ptr .and. !err()
  4659.  
  4660.     stack_item = upper(stack[stack_ptr])
  4661.  
  4662.     do case
  4663.         case stack_item = "FOR"
  4664.             condition = get_expr1("exp1")
  4665.             if condition
  4666.                 for = .T.
  4667.                 rewind_dbf = .T.
  4668.             else
  4669.                 ERRS2 = .T.
  4670.             endif
  4671.  
  4672.         case cmd_abbr(stack_item, "WHILE")
  4673.             condition = get_expr1("exp2")
  4674.             if condition
  4675.                 while = .T.
  4676.                 rewind_dbf = .F.
  4677.             else
  4678.                 ERRS2 = .T.
  4679.             endif
  4680.  
  4681.         case cmd_abbr(stack_item, "RECORD")
  4682.             if get_expr1("exp3") .and. is_num(&exp3)
  4683.                 if &exp3 <= lastrec()
  4684.                     record = .T.
  4685.                     scope = 1
  4686.                     rewind_dbf = .F.
  4687.                     exp3 = "recno() = &exp3"
  4688.                 else
  4689.                     ERRS6 = .T.
  4690.                 endif
  4691.             else
  4692.                 ERRS2 = .T.
  4693.             endif
  4694.  
  4695.         case stack_item = "ALL"
  4696.             all = .T.
  4697.             scope = 2
  4698.             rewind_dbf = .T.
  4699.             stack_ptr = stack_ptr + 1
  4700.  
  4701.         case stack_item = "NEXT"
  4702.             if get_expr1("exp3") .and. is_num(&exp3)
  4703.                 next = .T.
  4704.                 scope = 3
  4705.                 rewind_dbf = .F.
  4706.             else    
  4707.                 ERRS2 = .T.
  4708.             endif
  4709.  
  4710.         case stack_item = "TO"
  4711.             if get_expr1("dest")
  4712.                 to = .T.
  4713.             else
  4714.                 ERRS2 = .T.
  4715.             endif
  4716.  
  4717.         case stack_item = "FROM"
  4718.             if get_expr1("source")
  4719.                 source = .T.
  4720.             else
  4721.                 ERRS2 = .T.
  4722.             endif
  4723.  
  4724.         otherwise
  4725.             stack_ptr = stack_ptr + 1
  4726.     endcase
  4727. enddo
  4728.  
  4729. return (!err())
  4730.  
  4731. *
  4732. ** eoproc cnd_scp
  4733.  
  4734.  
  4735. ***
  4736. * Function err
  4737. * Check for error status flags set.
  4738. *
  4739. *    Usage : err()
  4740. *
  4741. *    Returns:
  4742. *        .T. - if any of the error flags are set.
  4743. *
  4744.  
  4745. function err
  4746.  
  4747. private status
  4748.  
  4749. status = .F.
  4750.  
  4751. if error_on
  4752.     if ERRS1 .or. ERRS2 .or. ERRS3 .or. ERRS4 .or. ERRS5 .or. ERRS6 .or. ERRS7;
  4753.         .or. ERRS8 .or. ERRS9 .or. ERRS10 .or. ERRS11 .or. ERRS12 .or. ERRS13;
  4754.         .or. ERRS14 .or. ERRS15
  4755.         status = .T.
  4756.     endif
  4757. endif
  4758.  
  4759. return (status)
  4760.  
  4761. *
  4762. ** eofunc err
  4763.  
  4764.  
  4765. ***
  4766. * Function fld_form
  4767. * kjs, 04/24/86
  4768. * Provides the correct column formatting for any given field type.
  4769. * Called by the list_do procedure.
  4770. *
  4771. *    Usage     : fld_form(<character expression>)
  4772. *
  4773. *        <character expression> - name of field to provide formatting
  4774. *                                 for.
  4775. *
  4776. *     Returns :
  4777. *        Output format string for fieldname.
  4778. *
  4779.  
  4780. function fld_form
  4781.  
  4782. parameters fld_name
  4783.  
  4784. private type, fld_form
  4785.  
  4786. type = type("&fld_name")
  4787.  
  4788. do case
  4789.     case type = "C"
  4790.         fld_form = fld_name
  4791.  
  4792.     case type = "D"
  4793.         fld_form = "dtoc(&fld_name)"
  4794.  
  4795.     case type = "L"
  4796.         fld_form = [if((&fld_name), ".T.", ".F.")]
  4797.  
  4798.     case type = "M"
  4799.         fld_form = ["Memo      "]
  4800.  
  4801.     case type = "N"
  4802.         fld_form = "str(&fld_name)"
  4803. endcase
  4804.  
  4805. return (fld_form)
  4806.  
  4807. *
  4808. ** eofunc fld_form
  4809.  
  4810.  
  4811. ***
  4812. * Function get_expr1()
  4813. * kjs, 04/09/86
  4814. * Fills the passed variable.
  4815. *
  4816. *    Usage   : get_expr1(<var_name>)
  4817. *
  4818. *        <var_name> -  contains name of target variable.
  4819. *
  4820. *    Returns :
  4821. *        .T. - variable is NOT empty.
  4822. *        .F. - variable is empty.
  4823. *
  4824. *    Notes   :
  4825. *
  4826. *            1. Increments stack pointer before getting stack item.
  4827. *            2. Leaves the stack pointer at the next item on stack.  
  4828. *            
  4829.  
  4830. function get_expr1
  4831.  
  4832. parameters var_name
  4833.  
  4834. private current, next, get_more
  4835.  
  4836. current = ""
  4837. next = ""
  4838. get_more = .F.
  4839. stack_ptr = stack_ptr + 1
  4840.  
  4841. if stack_ptr <= max_ptr
  4842.     &var_name = &var_name + stack[stack_ptr]
  4843.     stack_ptr = stack_ptr + 1
  4844.  
  4845.     if current <> ","
  4846.         if stack_ptr <= max_ptr
  4847.             next = stack[stack_ptr]
  4848.  
  4849.             if &var_name$"+-!.\" .or. substr(next,1,1)$"|+-/%*<>=#.!$^(["
  4850.                 get_more = .T.
  4851.             endif
  4852.  
  4853.         endif
  4854.     endif
  4855. endif
  4856.  
  4857. do while get_more
  4858.  
  4859.     get_more = .F.
  4860.     current = stack[stack_ptr]
  4861.     &var_name = &var_name + current
  4862.     stack_ptr = stack_ptr + 1
  4863.  
  4864.     if stack_ptr <= max_ptr
  4865.         next = stack[stack_ptr]
  4866.         if current$"|+-/%*<>=#.!$^==" .and. next <> "," .or.;
  4867.             substr(next,1,1)$"|+-/%*<>=#.!$^([" .and. current <> ","
  4868.              get_more = .T.
  4869.         endif
  4870.     endif
  4871.  
  4872. enddo
  4873.  
  4874. return ("" <> &var_name)
  4875.  
  4876. *
  4877. ** eofunc get_expr1
  4878.  
  4879.  
  4880. ***
  4881. * Function get_list
  4882. * Gets a list of expression from the stack.  List variables start at 1.
  4883. *
  4884. *    Usage  :  get_list(<control string>)
  4885. *
  4886. *        <control string> - indicates that the list contains....
  4887. *
  4888. *                    "E"     - expressions.
  4889. *                    "NF" - index files.
  4890. *
  4891. *    Returns :
  4892. *        .T. - list filled successfully, or if "NF" and empty.
  4893. *        .F. - list is empty or error occurred.
  4894. *
  4895. *    Notes   :
  4896. *
  4897. *        1. If string = "NF" and error_on = .F. no index file
  4898. *           checking is done.
  4899. *        2. Increments stack pointer before getting something from the
  4900. *           stack.
  4901. *        3. Leaves stack pointer at next item on stack.
  4902. *
  4903.  
  4904. function get_list
  4905.  
  4906. parameters list_type
  4907.  
  4908. private get_more, count, list_ok, stack_item, null
  4909.  
  4910. if stack_ptr <= max_ptr
  4911.     list_ok = .T.
  4912.     get_more = .T.
  4913.     count = "0"
  4914.     stack_item = ""
  4915. else
  4916.     get_more = .F.
  4917.     if list_type = "NF"
  4918.         list_ok = .T.
  4919.     else
  4920.         list_ok = .F.
  4921.     endif
  4922. endif
  4923.  
  4924. do while get_more
  4925.     get_more = .F.
  4926.     stack_item = ""
  4927.  
  4928.     null = get_expr1("stack_item")
  4929.  
  4930.     if stack_item <> ","
  4931.         if list_type = "NF"
  4932.             list_ok = if(error_on, file("&stack_item..NTX"), .T.)
  4933.         endif
  4934.         if list_ok
  4935.             store stack_item to list&count
  4936.             count = str(val(count)+1,1)
  4937.         endif
  4938.     endif
  4939.  
  4940.     if stack_ptr <= max_ptr .and. val(count) < 10 .and. list_ok
  4941.         if stack[stack_ptr] = ","
  4942.             get_more = .T.
  4943.         endif
  4944.     endif
  4945. enddo
  4946.  
  4947. return (list_ok)
  4948.  
  4949. *
  4950. ** eofunc get_list
  4951.  
  4952.  
  4953. ***
  4954. * Function get_stack
  4955. * kjs, 04/09/86
  4956. * Fills the variable passed in var_name.
  4957. *
  4958. *     Usage    : get_stack(<var_name>)
  4959. *
  4960. *        <var_name> - literal name of variable to store expression to.
  4961. *
  4962. *    Returns:
  4963. *        .T. - if NOT null
  4964. *        .F. - if null.
  4965. *
  4966. *    Notes:
  4967. *
  4968. *        1. Does NOT increment the stack pointer before getting 
  4969. *           something from the stack.
  4970. *         2. Leaves the stack pointer at the next item on the stack.  
  4971. *
  4972.  
  4973. function get_stack
  4974.  
  4975. parameters var_name
  4976.  
  4977. private current, next, get_more
  4978.  
  4979. current = ""
  4980. next = ""
  4981. get_more = .F.
  4982.  
  4983. if stack_ptr <= max_ptr
  4984.  
  4985.     &var_name = stack[stack_ptr]
  4986.     current = &var_name
  4987.     stack_ptr = stack_ptr + 1
  4988.  
  4989.     if stack_ptr <= max_ptr
  4990.         next = upper(stack[stack_ptr])
  4991.     endif
  4992.  
  4993.     if current <> ","
  4994.         if current$"+-!\*.?" .or. substr(next,1,1)$"|+-/%*<>=#!$^([?*."
  4995.             get_more = .T.
  4996.         endif
  4997.     endif
  4998. endif
  4999.  
  5000. do while get_more
  5001.  
  5002.     get_more = .F.
  5003.     current = stack[stack_ptr]
  5004.     &var_name = &var_name + current
  5005.     stack_ptr = stack_ptr + 1
  5006.  
  5007.     if stack_ptr <= max_ptr
  5008.         next = stack[stack_ptr]
  5009.         if substr(current,1,1)$"|+-/%*<>=#.!$^=?" .and. next <> "," .or.;
  5010.             substr(next,1,1)$"|+-/%*<>=#.!$^([?" .and. current <> ","
  5011.              get_more = .T.
  5012.         endif
  5013.     endif
  5014.  
  5015. enddo
  5016.  
  5017. return (!(&var_name == ""))
  5018.  
  5019. *
  5020. ** eofunc get_stack
  5021.  
  5022.  
  5023. ***
  5024. * Function is_n_expr
  5025. * kjs, 04/09/85
  5026. * Checks the contents of eval_item for numeric type.
  5027. *
  5028. *     Usage     : is_n_expr(<eval_item>)
  5029. *
  5030. *         <eval_item> - macro expanded string.
  5031. *
  5032. *    Returns : 
  5033. *        .T. - item is numeric.
  5034. *        .F. - item is NOT numeric.
  5035. *
  5036.  
  5037. function is_n_expr
  5038.  
  5039. parameters eval_item
  5040.  
  5041. return (type("eval_item")$"N")
  5042.  
  5043. *
  5044. ** eofunc is_n_expr
  5045.  
  5046.  
  5047. ***
  5048. * Function is_num
  5049. * kjs, 04/11/86
  5050. * checks if a string contains only numbers.
  5051. *
  5052. *     Usage     : is_num(<eval_item>)
  5053. *
  5054. *         <eval_item> - macro expanded string.
  5055. *
  5056. *    Returns : 
  5057. *        .T. - item is string of numbers.
  5058. *        .F. - item is NOT a string of numbers.
  5059. *
  5060. *
  5061.  
  5062. function is_num
  5063.  
  5064. parameters string
  5065.  
  5066. private status, len, counter
  5067.  
  5068. if type("string")$"NC"
  5069.     if type("string") = "N"
  5070.         string = str(string)
  5071.     endif
  5072.  
  5073.     string = ltrim(string)
  5074.     status = .T.
  5075.     len = len(string)
  5076.     counter = 1
  5077.  
  5078.     do while counter <= len .and. status
  5079.         if !substr(string,counter,1)$"0123456789"
  5080.             status = .F.
  5081.         endif
  5082.         counter = counter + 1
  5083.     enddo
  5084. else
  5085.     status = .F.
  5086. endif
  5087.  
  5088. return (status)
  5089.  
  5090. *
  5091. ** eofunc is_num
  5092.  
  5093.  
  5094. ***
  5095. * Function spacer_h
  5096. * kjs, 04/23/86
  5097. * Build a string for a list/display header.
  5098. * Called by the list_do procedure.
  5099. *
  5100. *     Usage     : spacer_h(<field name>)
  5101. *
  5102. *        <field name> - name of the field to format.
  5103. *
  5104. *    Returns :
  5105. *        Character string containing field name plus the number of
  5106. *        blanks to pad the column out.
  5107. *
  5108. *    Notes   :
  5109. *
  5110. *        1. Called from procedure list_do.
  5111. *
  5112.  
  5113. function spacer_h
  5114.  
  5115. parameter fld_name
  5116.  
  5117. private type, string
  5118.  
  5119. type = type("&fld_name")
  5120. string = ""
  5121.  
  5122. do case
  5123.     case type = "C"
  5124.         string = fld_name + space(if(len(fld_name) >= len(&fld_name), 1,;
  5125.             (len(&fld_name) - len(fld_name)) + 1))
  5126.  
  5127.     case type = "D"
  5128.         string = fld_name + space(if((len(fld_name) >= 8), 1,;
  5129.             (8 - len(fld_name)) + 1))
  5130.  
  5131.     case type = "L"
  5132.         string = fld_name + space(if((len(fld_name) >= 3), 1,;
  5133.             (3 - len(fld_name)) + 1))
  5134.  
  5135.     case type = "M"
  5136.         string = fld_name + space(if((len(fld_name) = 10), 1,;
  5137.             (10 - len(fld_name)) + 1))
  5138.  
  5139.     case type = "N"
  5140.         string = space(if((len(fld_name) >= len(str(&fld_name))), 0,;
  5141.             (len(str(&fld_name)) - len(fld_name)))) + fld_name + space(1)
  5142. endcase
  5143.  
  5144. return (string)
  5145.  
  5146. *
  5147. ** eofunc spacer_h
  5148.  
  5149.  
  5150. ***
  5151. * Function spacer_l
  5152. * kjs, 04/23/86
  5153. * Calculate the number of characters to pad a list/display line.
  5154. * Called by the list_do procedure.
  5155. *
  5156. *     Usage     : spacer_h(<field name>)
  5157. *
  5158. *        <field name> - name of the field pad.
  5159. *
  5160. *    Returns :
  5161. *        Number of spaces needed to pad out a column in a screen
  5162. *        output line.
  5163. *
  5164. *    Notes   :
  5165. *
  5166. *        1. Called from procedure list_do.
  5167. *
  5168.  
  5169. function spacer_l
  5170.  
  5171. parameters fld_name
  5172.  
  5173. private type, blanks
  5174.  
  5175. type = type("&fld_name")
  5176. blanks = 0
  5177.  
  5178. do case
  5179.     case type = "C"
  5180.         blanks = if(len(&fld_name) >= len(fld_name), 1,;
  5181.             (len(fld_name) - len(&fld_name)) + 1)
  5182.  
  5183.     case type = "D"
  5184.         blanks = if(8 >= len(fld_name), 1, (len(fld_name) - 8) + 1)
  5185.  
  5186.     case type = "L"
  5187.         blanks = if(3 >= len(fld_name), 1, (len(fld_name) - 3) + 1)
  5188.  
  5189.     case type = "M"
  5190.         blanks = if(10 >= len(fld_name), 1, (len(fld_name) - 10) + 1)
  5191.  
  5192.     case type = "N"
  5193.         blanks = if((len(str(&fld_name)) >= len(fld_name)), 1,;
  5194.             (len(fld_name) - len(str(&fld_name)) + 1))
  5195. endcase
  5196.  
  5197. return (ltrim(str(blanks,2)))
  5198.  
  5199. *
  5200. ** eofunc spacer_l
  5201.  
  5202.  
  5203.  
  5204. ***
  5205. *    5.0 error handler for Dot...
  5206. *
  5207.  
  5208. #include "error.ch"
  5209.  
  5210. #define NTRIM(n)        ( LTrim(Str(n)) )
  5211.  
  5212.  
  5213.  
  5214. ***
  5215. *    DotError()
  5216. *
  5217. static func DotError(e)
  5218.  
  5219.     local i, cMessage, aOptions, nChoice
  5220.     local bSaveErrorBlock
  5221.  
  5222.  
  5223.     // switch to system error handler (in case of error in here)
  5224.     bSaveErrorBlock := ErrorBlock(SysErrorBlock)
  5225.  
  5226.  
  5227.     // for network open error, set NETERR() and alert user
  5228.     if ( e:genCode == EG_OPEN .and. e:osCode == 32 )
  5229.         NetErr(.t.)
  5230.     end
  5231.  
  5232.     // for lock error during APPEND BLANK, set NETERR() and alert user
  5233.     if ( e:genCode == EG_APPENDLOCK .and. e:canDefault )
  5234.         NetErr(.t.)
  5235.     end
  5236.  
  5237.  
  5238.     // build error message
  5239.     cMessage := ErrorMessage(e)
  5240.  
  5241.  
  5242.     // build options array
  5243.     aOptions := {"Break", "Quit"}
  5244.  
  5245.     if (e:canRetry)
  5246.         AAdd(aOptions, "Retry")
  5247.     end
  5248.  
  5249.     if (e:canDefault)
  5250.         AAdd(aOptions, "Default")
  5251.     end
  5252.  
  5253.  
  5254.     // put up alert box
  5255.     nChoice := 0
  5256.     while ( nChoice == 0 )
  5257.  
  5258.         if ( Empty(e:osCode) )
  5259.             nChoice := Alert( cMessage, aOptions )
  5260.  
  5261.         else
  5262.             nChoice := Alert( cMessage + ;
  5263.                             ";(DOS Error " + NTRIM(e:osCode) + ")", ;
  5264.                             aOptions )
  5265.         end
  5266.  
  5267.     end
  5268.  
  5269.  
  5270.     // switch back to our error handler before leaving
  5271.     ErrorBlock(bSaveErrorBlock)
  5272.  
  5273.  
  5274.     // do as instructed
  5275.     if ( !Empty(nChoice) )
  5276.  
  5277.         if ( aOptions[nChoice] == "Break" )
  5278.             Break(e)
  5279.  
  5280.         elseif ( aOptions[nChoice] == "Retry" )
  5281.             return (.t.)
  5282.  
  5283.         elseif ( aOptions[nChoice] == "Default" )
  5284.  
  5285.             // default for division by zero is zero
  5286.             if ( e:genCode == EG_ZERODIV )
  5287.                 return (0)
  5288.  
  5289.             end
  5290.  
  5291.             return (.f.)
  5292.  
  5293.         end
  5294.  
  5295.     end
  5296.  
  5297.  
  5298.     // display message and quit
  5299.     if ( !Empty(e:osCode) )
  5300.         cMessage += " (DOS Error " + NTRIM(e:osCode) + ") "
  5301.     end
  5302.  
  5303.  
  5304.     ? cMessage
  5305.     ErrorLevel(1)
  5306.     QUIT
  5307.  
  5308. return (.f.)
  5309.  
  5310.  
  5311.  
  5312. /***
  5313. *    ErrorMessage()
  5314. */
  5315. static func ErrorMessage(e)
  5316.  
  5317.     local cMessage
  5318.  
  5319.  
  5320.     // start error message
  5321.     cMessage := if( e:severity > ES_WARNING, "Error ", "Warning " )
  5322.  
  5323.  
  5324.     // add subsystem name if available
  5325.     if ( ValType(e:subsystem) == "C" )
  5326.         cMessage += e:subsystem()
  5327.     else
  5328.         cMessage += "???"
  5329.     end
  5330.  
  5331.  
  5332.     // add subsystem's error code if available
  5333.     if ( ValType(e:subCode) == "N" )
  5334.         cMessage += ("/" + NTRIM(e:subCode))
  5335.     else
  5336.         cMessage += "/???"
  5337.     end
  5338.  
  5339.  
  5340.     // add error description if available
  5341.     if ( ValType(e:description) == "C" )
  5342.         cMessage += ("  " + e:description)
  5343.     end
  5344.  
  5345.  
  5346.     // add either filename or operation
  5347.     if ( !Empty(e:filename) )
  5348.         cMessage += (": " + e:filename)
  5349.  
  5350.     elseif ( !Empty(e:operation) )
  5351.         cMessage += (": " + e:operation)
  5352.  
  5353.     end
  5354.  
  5355.  
  5356.     return (cMessage)
  5357.  
  5358. *
  5359. *
  5360. ** eof dot.prg
  5361.  
  5362.