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