home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FPC355_4.ZIP / TCOMSAMP.ZIP / PASCAL.SEQ < prev    next >
Encoding:
Text File  |  1991-02-06  |  28.2 KB  |  807 lines
  1. \\ PASCAL.SEQ       Tiny Pascal     Copyright 1987-91       Tom Zimmer
  2.  
  3.   Here is the latest version of my Tiny Pascal Implimentation in Forth.
  4.  
  5.   It doesn't do all that much, but it does translate the simple example
  6. included with the compiler (PASX.PAS) from PASCAL to Forth.
  7.  
  8.   The PASCAL translator is Compiled as follows:
  9.  
  10.         TCOM PASCAL /OPT /NOINIT <enter>
  11.  
  12.   Once PASCAL has been compiled, you can use it to translate the pascal
  13. example file PASX.PAS into Forth with the following command line:
  14.  
  15.         PASCAL PASX.PAS <enter>
  16.  
  17. The Pascal translator will output Forth source to the console. To direct
  18. the translators output to a file use standard I/O redirection as in:
  19.  
  20.         TPAS PASX.PAS >PASX.SEQ enter
  21.  
  22. A file PASX.SEQ will be created containing the Forth source for PASX.PAS.
  23.  
  24.   P.S. Don't redirect the output to the same file as the input, or you
  25. will lose your original source.
  26.  
  27. {
  28.  
  29. : pasquery      ( -- )          \ get a line from the input file
  30.  
  31. \ Add these lines to echo each the pascal source line to the output as
  32. \ a Forth comment line appended to the Forth source line generated by
  33. \ this Pascal source line.
  34. \               outbuf c@ 2 >
  35. \               if      0 ?nline
  36. \                       55 #out @ - 0max 0
  37. \                       ?do     "  " ?echotype
  38. \                       loop    " \ " ?echotype
  39. \                       outbuf count 2- ?echotype
  40. \               then
  41.  
  42.                 lineread count dup #tib ! tib swap cmove
  43.                 >in off                         \ reset >IN
  44.                 $2020 tib #tib @ + 2- ! ;       \ change crlf to blanks
  45.  
  46. : charread      ( -- c1 )       \ get a character from the input file
  47.                 >in @ #tib @ >=                 \ if at line end,
  48.                 if      begin   pasquery        \ get a line of source
  49.                                 #tib @ 0=       \ if tib empty?
  50.                         while   inlength @ 0=   \ and read buffer empty?
  51.                                 if abort then   \ then end of file, leave
  52.                         repeat                  \ else repeat till we have
  53.                                                 \ more source to parse
  54.                         ?keypause
  55.                 then
  56.                 tib >in @ + c@                  \ -- c1
  57.                 incr> >in ;
  58.  
  59. 0 value no-const-or-vars        0 value chrpr
  60. 0 value typ                     0 value char-           0 value arraysize
  61. 0 value varcnt                  0 value ptyp
  62. 0 value parcnt                  0 value ptr             0 value echoing
  63.  
  64. : echoon        ( --- )                 \ enable console echo of output
  65.                 on> echoing ;
  66.  
  67. : echooff       ( --- )                 \ disable console echo of output
  68.                 off> echoing ;
  69.  
  70. : ?echo         ( c1 --- )              \ emit if echoing is on
  71.                 echoing
  72.                 if      emit
  73.                 else    drop incr> #out
  74.                 then    ;
  75.  
  76. : ?echotype     ( a1 n1 --- )           \ type if echoing is on
  77.                 echoing
  78.                 if      type
  79.                 else    +!> #out drop
  80.                 then    ;
  81.  
  82. : ?echospaces   ( n1 --- )              \ spaces if echoing is on
  83.                 echoing
  84.                 if      spaces
  85.                 else    +!> #out
  86.                 then    ;
  87.  
  88. : ?echo.        ( n1 --- )              \ . (dot) if echoing is on
  89.                 echoing
  90.                 if      .
  91.                 else    (.) 1+ +!> #out drop
  92.                 then    ;
  93.  
  94. : ?echocr       ( --- )                 \ cr if echoing is on
  95.                 echoing
  96.                 if      cr
  97.                 else    off> #out
  98.                 then    ;
  99.  
  100.  80 array a$
  101. 160 array var$
  102.  
  103. defer limtyp
  104.  
  105. : clrbuf        ( a1 --- )              \ clear buffer
  106.                 dup 69 erase dup 65 blank 0 swap c! ;
  107.  
  108. : tokenpron     ( --- ) on> chrpr ;      \ token printing on
  109.  
  110. : tokenproff    ( --- ) off> chrpr ;     \ token printing off
  111.  
  112. : ?emit         ( c1 --- c1 )
  113.                 dup bl  <> chrpr and
  114.                 if      dup ?echo
  115.                 then   ;
  116.  
  117. : a-z           ( c1 --- f1 )
  118.                 bl or 'a' 'z' between ;
  119.  
  120. : a-f           ( c1 --- f1 )
  121.                 bl or 'a' 'f' between ;
  122.  
  123. : not0-f        ( c1 --- f1 )
  124.                 bl or dup  '0' 'f' between 0=           \ not 0 to f
  125.                       swap '9' 'a' between or ;         \ or  9 to a
  126.  
  127. : nota-zor0-9   ( c1 --- f1 )
  128.                 bl or dup  '0' 'z' between 0=
  129.                       swap '9' 'a' within  or ;
  130.  
  131. :: typck        ( n1 --- f1 )
  132.                 CREATE C, DOES> C@ typ = ;
  133.  
  134.  0 typck keyword?        1 typck ident?
  135.  2 typck ==?             3 typck char?
  136.  4 typck #?              5 typck :=?
  137.  6 typck :?              7 typck <?
  138.  8 typck <=?             9 typck <>?
  139. 10 typck >=?            11 typck >?
  140. 12 typck string?        14 typck (?
  141. 15 typck )?
  142.  
  143. :: keyck        ( n1 --- f1 )
  144.                 CREATE C, DOES> C@ ptr = keyword? and ;
  145.  
  146.  0 keyck and?            1 keyck array?
  147.  2 keyck begin?          3 keyck newline?
  148.  4 keyck case?           5 keyck const?
  149.  6 keyck div?            7 keyck do???
  150.  8 keyck downto?         9 keyck else?
  151. 10 keyck endd?          11 keyck for?
  152. 12 keyck func?          13 keyck if?
  153. 14 keyck integer?       15 keyck mem?
  154. 16 keyck mod?           17 keyck not?
  155. 18 keyck of?            19 keyck or?
  156. 20 keyck proc?          21 keyck read?
  157. 22 keyck repeat?        23 keyck shl?
  158. 24 keyck shr?           25 keyck then?
  159. 26 keyck to?            27 keyck type?
  160. 28 keyck until?         29 keyck var?
  161. 30 keyck while?         31 keyck write?
  162. 32 keyck in?
  163.  
  164. code inset      ( a1 n1 -- )
  165.                 pop cx
  166.                 push #tib                       mov #tib bx
  167.                 push >in                        mov >in  # 0 word
  168.                 push 'tib       lodsw           mov 'tib ax
  169.                 load_bx
  170.                 jmp cx          end-code
  171.  
  172. code insave     ( -- )
  173.                 pop cx
  174.                 push #tib
  175.                 push >in
  176.                 push 'tib
  177.                 jmp cx          end-code
  178.  
  179. code inrec      ( -- )
  180.                 pop cx
  181.                 pop 'tib
  182.                 pop >in
  183.                 pop #tib
  184.                 jmp cx          end-code
  185.  
  186. :: crck         ( c1 -- f1 )
  187.                 CREATE C, DOES> C@ char- = char? and ;
  188.  
  189. ';' crck ;?     '.' crck .?     '[' crck [?     ']' crck ]?
  190. '*' crck *?     '-' crck -?     '+' crck +?     ',' crck ,?
  191. '#' crck ##?
  192.  
  193.                 \ compile a word which check match on its own first
  194.                 \ character.
  195.  
  196. : a$=a$+char    ( c1 --- )
  197.                 a$ count + c! 1 a$ c+! ;
  198.  
  199. : var$move      ( --- )
  200.                 a$ count var$ count + swap 1+ cmove
  201.                 a$ 1+
  202.                 begin   1+ dup c@ bl =
  203.                 until   incr> varcnt
  204.                 1+ a$ 1+ - var$ c+! ;
  205.  
  206. : to-or-downto?? to? downto? or 0= abort" <-To Expected !" ;
  207. : ident??       ident? 0=       abort" <-Identifier Expected !" ;
  208. : keyword??     keyword? 0=     abort" <-Keyword Expected !" ;
  209. : :??           :?      0=      abort" <-':' Expected !" ;
  210. : (??           (?      0=      abort" <-'(' Expected !" ;
  211. : )??           )?      0=      abort" <-')' Expected !" ;
  212. : :=??          :=?     0=      abort" <-':=' Expected !" ;
  213. : ==??          ==?     0=      abort" <-'=' Expected !" ;
  214. : ;??           ;?      0=      abort" <-';' Expected !" ;
  215. : .??           .?      0=      abort" <-'.' Expected !" ;
  216. : [??           [?      0=      abort" <-'[' Expected !" ;
  217. : ]??           ]?      0=      abort" <-']' Expected !" ;
  218. : found??       0= abort" Error in variable create process" ;
  219.  
  220. : #??           #?      0=      abort" <-Number Expected !" ;
  221. : #a??          #?      0=      abort" <-No Consts or Vars Allowed here !" ;
  222. : integer??     integer? 0=     abort" <-Integer Expected !" ;
  223. : until??       until?  0=      abort" <-Until Expected !" ;
  224. : mem??         mem?    0=      abort" <-Incorrect Keyword !" ;
  225. : do??          do???   0=      abort" <-Do Expected !" ;
  226. : to??          to?     0=      abort" <-To Expected !" ;
  227. : of??          of?     0=      abort" <-Of Expected !" ;
  228. : end??         endd?   0=      abort" <-End Expected !" ;
  229. : then??        then?   0=      abort" <-Then Expected !" ;
  230. : string??      string? 0=      abort" <-Number Expected !" ;
  231. : no-const-or-vars??   no-const-or-vars
  232.                      abort" No Consts or Vars Allowed here !" ;
  233.  
  234. : \=            ( c1 --- f1 ) ascii \ = ;
  235.  
  236. : '=            ( c1 --- f1 ) ascii ' = ;
  237.  
  238. : get$          ( c1/a1 --- c2 ) \ pass a1 the cfa of test rtn
  239.                 is limtyp        \ and get string till tst pass
  240.                 a$ clrbuf
  241.                 begin   a$=a$+char charread dup limtyp
  242.                         over 0= or
  243.                 until   ;
  244.  
  245. : crout         ( --- ) ?echocr ;
  246. : crout+        ( --- ) crout 8 ?echospaces ;
  247. : crout++       ( --- ) crout 16 ?echospaces ;
  248.  
  249. : bslsh         ( c1 --- )      \ dump text till '\'
  250.                 ['] \= get$ drop
  251.                 bl a$ 2+ c!     \ clear * to a blank
  252.                 a$ count 1- ?echotype 1 ?echospaces crout+ ;
  253.  
  254. : a$>#          ( --- n1 )
  255.                 a$ number? 2drop ;
  256.  
  257. : skipblanks    ( --- c1 )
  258.                 bl
  259.                 begin   drop charread dup bl -
  260.                 until   ;
  261.  
  262. : string      ( c1 --- )
  263.               drop bl ['] '= get$ drop 0 a$=a$+char 12 =: typ ;
  264.  
  265. : numbr       ( c1 --- n1 )
  266.               ['] not0-f get$ drop 4 =: typ >in decr a$># ;
  267.  
  268. : coln          ( c1 --- )
  269.                 drop    6 =: typ charread '=' =
  270.                 if      5 =: typ
  271.                 else    decr> >in
  272.                 then   ;
  273.  
  274. : gthan         ( c1 --- )
  275.                 drop    charread '=' =
  276.                 if      10 =: typ
  277.                 else    11 =: typ
  278.                         decr> >in
  279.                 then   ;
  280.  
  281. : lthan         ( c1 --- )
  282.                 drop    charread dup '>' =
  283.                 if      drop    9 =: typ
  284.                 else    '=' =
  285.                         if      8 =: typ
  286.                         else    7 =: typ
  287.                                 decr> >in
  288.                         then
  289.                 then   ;
  290.  
  291. create kw-table
  292. ," and    "    ," array  "    ," begin  "    ," newline"
  293. ," case   "    ," const  "    ," div    "    ," do     "
  294. ," downto "    ," else   "    ," end    "    ," for    "
  295. ," func   "    ," if     "    ," integer"    ," mem    "
  296. ," mod    "    ," not    "    ," of     "    ," or     "
  297. ," proc   "    ," read   "    ," repeat "    ," shl    "
  298. ," shr    "    ," then   "    ," to     "    ," type   "
  299. ," until  "    ," var    "    ," while  "    ," write  "
  300. ," in     "
  301. 33 constant table-size
  302.  
  303. : a$srch        ( -- f1 )
  304.                 false
  305.                 table-size 0
  306.                 do      a$ 1+ i 8 * kw-table + count caps-comp 0=
  307.                         if      0= i =: ptr leave
  308.                         then
  309.                 loop    ;
  310.  
  311. : a-ident       ( c1 --- )
  312.                 dup a-z
  313.                 if      ['] nota-zor0-9 get$ drop
  314.                         decr> >in
  315.                         a$srch 0= 1 and =: typ
  316.                         r>drop               \ pop out of def above
  317.                 then   ;
  318.  
  319. : a-#           ( c1 --- n1 )
  320.                 dup not0-f 0=
  321.                 if      numbr                   \ -- n1
  322.                         r>drop               \ pop out of def above
  323.                 then   ;
  324.  
  325. : a-:           ( c1 --- )
  326.                 dup ':' =
  327.                 if      coln
  328.                         r>drop
  329.                 then ;
  330.  
  331. : a-<           ( c1 --- )
  332.                 dup '<' =
  333.                 if      lthan
  334.                         r>drop
  335.                 then ;
  336.  
  337. : a->           ( c1 --- )
  338.                 dup '>' =
  339.                 if      gthan
  340.                         r>drop
  341.                 then ;
  342.  
  343. : a-$           ( c1 --- )
  344.                 dup ascii ' =
  345.                 if      string
  346.                         r>drop
  347.                 then ;
  348.  
  349. : a-(           ( c1 --- )
  350.                 dup '(' =
  351.                 if      drop
  352.                         14 =: typ
  353.                         r>drop
  354.                 then ;
  355.  
  356. : a-)           ( c1 --- )
  357.                 dup ')' =
  358.                 if      drop
  359.                         15 =: typ
  360.                         r>drop
  361.                 then ;
  362.  
  363. : a-=           ( c1 --- )
  364.                 dup '=' =
  365.                 if      drop
  366.                         2 =: typ
  367.                         r>drop
  368.                 then ;
  369.  
  370. : token         ( --- c1 )
  371.                 begin
  372.                         begin skipblanks ?dup
  373.                         until dup '\' =                 \ ignore comments
  374.                 while   bslsh
  375.                 repeat  a-ident a-#     a-:
  376.                         a-<     a->     a-$
  377.                         a-(     a-)     a-=
  378.                         3 =: typ                \ other characters
  379.                           =: char- ;
  380.  
  381. : ?nline      ( n1 --- )
  382.                 @> #out + cols 10 - >
  383.                 if      crout++ then ;
  384.  
  385. : "out          ( a1 --- )
  386.                 127 and dup ?nline
  387.                 ?echotype 1 ?echospaces ;
  388.  
  389. : $out          ( a1 --- )      count "out ;
  390. : chrout        ( c1 --- )      ?echo 1 ?echospaces ;
  391. : cout          ( c1 --- )      1 ?nline ?echo ;
  392. : ##out         ( n1 --- )      6 ?nline ?echo. ;
  393.  
  394. 128 constant maxcon     32 constant b/con
  395. 128 constant maxvar     32 constant b/var
  396.  
  397. 0 value con#            0 value pcons
  398. 0 value var#            0 value pvars
  399.  
  400. : >c_name       ( n1 -- a1 )
  401.                 b/con * pcons + 2+ ;
  402.  
  403. : >v_name       ( n1 -- a1 )
  404.                 b/var * pvars + 2+ ;
  405.  
  406. : pconstant     ( n1 | <name> -- )
  407.                 con# b/con * pcons + swap over !        \ drop in the value
  408.                 bl word swap 2+ over c@ 1+ b/con 2- min cmove
  409.                 incr> con# ;
  410.  
  411. : pvariable     ( | <name> -- )
  412.                 var# b/var * pvars + dup off            \ drop in a zero
  413.                 bl word swap 2+ over c@ 1+ b/var 2- min cmove
  414.                 incr> var# ;
  415.  
  416. : $incon        ( a1 -- a2 f1 )
  417.                 false swap
  418.                 pcons con# b/con * bounds
  419.                 ?do     i 2+ over dup c@ 1+ caps-comp 0=
  420.                         if      2drop true i 2+ leave
  421.                         then
  422.          b/con +loop    swap ;
  423.  
  424. : $invar        ( a1 -- a2 f1 )
  425.                 false swap
  426.                 pvars var# b/var * bounds
  427.                 ?do     i 2+ over dup c@ 1+ caps-comp 0=
  428.                         if      2drop true i 2+ leave
  429.                         then
  430.          b/var +loop    swap ;
  431.  
  432. : pdefined      ( | <name> -- a1 f1 )   \ is following name defined in
  433.                                         \ constant or variable table?
  434.                 bl word $incon ?dup ?exit $invar ;
  435.  
  436. : a$constant    ( --- a1 )      \ make a constant, return name
  437.                 a$ count inset -1 pconstant inrec
  438.                 con# 1- >c_name ;
  439.  
  440. : a$place       ( --- a1 )
  441.                 a$ count inset pdefined inrec 0=
  442.                 if      drop  a$constant
  443.                 then   ;
  444.  
  445. : a$variable    ( --- a1 )
  446.                 a$ count inset pdefined inrec 0=
  447.                 if      drop
  448.                         a$ count inset pvariable inrec
  449.                         var# 1- >v_name
  450.                 then    ;
  451.  
  452. : a$find??      ( --- a1 )
  453.                 a$ count inset pdefined inrec 0=
  454.                 if      cr ." ** Unspecified Identifier ->" count type
  455.                         a$constant crout+
  456.                 then   ;
  457.  
  458. : create-constant       ( --- )
  459.                 begin   a$constant >r
  460.                         token   ==??
  461.                         token   ( --- n1 ) #??
  462.                         dup     here 2- !
  463.                         crout   ##out " CONSTANT" "out r> $out
  464.                         token   ;??
  465.                         token   ident? 0=
  466.                 until   ;
  467.  
  468. : const- ( --- )
  469.          no-const-or-vars?? token ident?? create-constant ;
  470.  
  471. : makevars      ( --- f1 )
  472.                 integer??
  473.                 var$ count inset varcnt >r
  474.                 begin   pvariable crout " VARIABLE" "out
  475.                         var# 1- >v_name $out
  476.                         decr> varcnt
  477.                         varcnt 1 <
  478.                 until   r> =: varcnt
  479.                 inrec   token ;? dup
  480.                 if      drop token ident? then   0=  ;
  481.  
  482. : makearrays    ( --- f1 )
  483.                 token   [??  token
  484.                 #a??    2* =: arraysize
  485.                 token   ]??             token   of??
  486.                 token   integer??       token   ;??
  487.                 var$ count inset
  488.                 begin   pvariable crout " VARIABLE" "out
  489.                         var# 1- >v_name $out
  490.                         arraysize 2- ##out " ALLOT" "out
  491.                         decr> varcnt
  492.                         varcnt 1 <
  493.                 until   inrec token   ident? 0=  ;
  494.  
  495. : var-          ( --- )
  496.                 no-const-or-vars?? token
  497.                 begin   off> varcnt 0 var$ c!
  498.                         begin   ident?? var$move token ,?
  499.                         while   token
  500.                         repeat  :??
  501.                         token   array?
  502.                         if      makearrays
  503.                         else    makevars
  504.                         then
  505.                 until   ;
  506.  
  507. : par-pass      ( a1 --- )
  508.                 >r var- crout " :" "out r> $out
  509.                 var$ count inset varcnt =: parcnt
  510.                 begin   pdefined found??
  511.                         decr> varcnt
  512.                         varcnt 1 <
  513.                 until   inrec   parcnt =: varcnt
  514.                 begin   $out " !" "out
  515.                         decr> varcnt varcnt 1 <
  516.                 until   )?? token ;
  517.  
  518. : proc-         ( --- )
  519.                 token   ident?? on> ptyp a$place ( --- a1 )
  520.                 token   (?
  521.                 if       off> ptyp par-pass
  522.                          on> no-const-or-vars
  523.                 then     ;??     token   block- " ;" "out
  524.                 on> ptyp ;??     token   block- ;
  525.  
  526. : begin-        ( --- )
  527.                 begin   token   statment   ;? 0=
  528.                 until   end??   token ;
  529.  
  530. : par-to-stk    ( --- )
  531.                 begin   token   expr-      ,? 0=
  532.                 until   )??     token ;
  533.  
  534. : variable?     ( a1 --- f1 )   \ is name addr a1 in the array of variables?
  535.                 pvars dup b/var maxvar * + between ;
  536.  
  537. : variable??    ( a1 --- )      \ error if not a variable
  538.                 dup variable? 0=
  539.                 if      cr ." Assignment to NON-Variable->"
  540.                         count beep type cr
  541.                 else    drop
  542.                 then   ;
  543.  
  544. : varconout     ( a1 --- )
  545.                 dup $out variable?
  546.                 if      " @" "out
  547.                 then   ;       \ test if this is a variable
  548.  
  549. : constant-     ( --- )
  550.                 ident?
  551.                 if      a$find?? ( --- a1 ) token [?
  552.                         if      $out  token expr-
  553.                                 " 2* + @" "out ]?? token
  554.                         else    (?   if      par-to-stk  $out
  555.                                      else    varconout
  556.                                      then
  557.                         then
  558.                 else    #?
  559.                         if      ##out    token
  560.                         else    " ascii" "out a$place $out token
  561.                         then
  562.                 then   ;
  563.  
  564.                 \ returns string for operator if true
  565. : +-or?         ( --- <a1> <n1> f1 )
  566.                 -?  if  " -"  true exit then
  567.                 +?  if  " +"  true exit then
  568.                 or? if  " or" true exit then false ;
  569.  
  570. : term-oper?    ( --- <a1>/f1 )
  571.                 div? if " div" true exit then
  572.                 mod? if " mod" true exit then
  573.                 and? if " and" true exit then
  574.                 shl? if " shl" true exit then
  575.                 shr? if " shr" true exit then
  576.                   *? if " *"   true exit then false ;
  577.  
  578. : factor-       ( --- )
  579.                 not?
  580.                 if      token   factor-         \ recurse here
  581.                         " 0=" "out
  582.                 then   keyword?
  583.                 if      mem??   token [?? token expr- ]??
  584.                         " @" "out token
  585.                 else    (?
  586.                         if      token expr- )?? token
  587.                         else    constant-
  588.                         then
  589.                 then   ;
  590.  
  591.  
  592. : term-         ( --- )
  593.                 factor-  term-oper?             \ -- <a1> f1
  594.                 if
  595.                         begin   token factor-
  596.                                 $out           \ string is passed in
  597.                                 term-oper? 0=
  598.                         until
  599.                 then   ;
  600.  
  601. : simp-expr     ( --- )
  602.                 -?
  603.                 if      token   term-   " negate" "out
  604.                 else    +?
  605.                         if      token
  606.                         then   term-
  607.                 then   +-or?
  608.                 if
  609.                         begin   token simp-expr "out +-or? 0=
  610.                         until
  611.                 then   ;
  612.  
  613. : in-           ( --- )
  614.                 [??  " dup" "out token simp-expr
  615.                      " ="   "out ,?
  616.                 if
  617.                         begin  token crout++ " over" "out
  618.                                 simp-expr    " = or" "out ,? 0=
  619.                         until
  620.                 then   ]??          " nip" "out
  621.                 token   ;
  622.  
  623. : expr-         ( --- )
  624.                 simp-expr
  625.                 ==? if  token simp-expr " ="  "out then
  626.                  <? if  token simp-expr " <"  "out then
  627.                  >? if  token simp-expr " >"  "out then
  628.                 <>? if  token simp-expr " <>" "out then
  629.                 <=? if  token simp-expr " <=" "out then
  630.                 >=? if  token simp-expr " >=" "out then
  631.                 in? if  token in-                   then ;
  632.  
  633. : var-assign    ( --- )
  634.                 ident?? a$find?? token (?
  635.                 if      par-to-stk
  636.                 then   dup>r variable?
  637.                 if      [?
  638.                         if      token expr-
  639.                                 " 2* + " "out
  640.                                 ]??   token
  641.                         then    :=??
  642.                         token   expr- r> $out " !" "out
  643.                 else    r> $out
  644.                 then   ;
  645.  
  646. : if-           ( --- )
  647.                 token   expr-   then??
  648.                         crout+ " IF     " "out token statment else?
  649.                 if      crout+ " ELSE   " "out token statment
  650.                 then    crout+ " THEN   " "out ;
  651.  
  652. : cases-        ( -- )
  653.                 " dup" "out token constant- " ="    "out ,?
  654.                 if      begin token crout++ " over" "out
  655.                                 constant-   " = or" "out ,? 0=
  656.                         until
  657.                 then    :??
  658.                 crout+  " IF     " "out token statment
  659.                 crout+  " ELSE   " "out ;
  660.  
  661. : case-         ( --- )
  662.                 token   expr-   of??  crout+ " CASE    " "out
  663.                 begin   cases-
  664.                         ;? 0=
  665.                 until   " drop" "out else?
  666.                 if      token   statment
  667.                 then    end??   crout+ " ENDCASE" "out token ;
  668.  
  669. : while-        ( --- )
  670.                         crout+ " BEGIN  " "out token expr- do???
  671.                 if      crout+ " WHILE  " "out token statment
  672.                         crout+ " REPEAT " "out
  673.                 then   ;
  674.  
  675. : repeat-       ( --- )
  676.                 crout+  " BEGIN  " "out
  677.                 begin   token statment ;? 0=
  678.                 until   until?? token expr-
  679.                 crout+  " UNTIL  " "out ;
  680.  
  681. : for-          ( --- )
  682.                 token   ident?? a$find?? >r token :=??
  683.                 token   expr-   to-or-downto?? r> to?
  684.                 if       1 >r
  685.                 else    -1 >r
  686.                 then    >r
  687.                 token   expr-   do??    r>  r@ ##out >r
  688.                         " + swap" "out crout+ " DO     " "out
  689.                 token   " I" "out r> $out " !" "out statment
  690.                         r> ##out crout+ " +LOOP  " "out ;
  691.  
  692. : a$compile     ( --- )
  693.                 '.' cout '"' chrout
  694.                 a$ count 1 /string dup ?nline ?echotype '"' chrout ;
  695.  
  696. : write-        ( --- )
  697.                 token   (??
  698.                 begin   token   string?
  699.                         if      a$compile token
  700.                         else    ##?
  701.                                 if      token expr-     " ."    "out
  702.                                 else    expr-           " emit" "out
  703.                                 then
  704.                         then    ,? 0=
  705.                 until   )?? token ;
  706.  
  707. \ : #input        ( --- n1 )
  708. \                 query bl word number? 0=
  709. \                 abort" Must be a NUMBER" drop ;
  710.  
  711. : read-         ( --- )
  712.                 token   (??
  713.                 begin   token   ##?
  714.                         if      " #input"       "out token
  715.                         else    " key dup emit" "out
  716.                         then    ident?? a$find??
  717.                                 dup variable?? $out
  718.                                 " !" "out token ,? 0=
  719.                 until   )?? token ;
  720.  
  721. : mem-          ( --- )
  722.                 token   [??     token   expr-   ]??
  723.                 token   :=??    token   expr- " swap !" "out ;
  724.  
  725. : newlin-       ( -- )
  726.                 " cr" "out token ;
  727.  
  728. : do-statment   ( --- )
  729.                 ptr 31 and exec:        \ statment interpretation table
  730. noop    noop    begin-  newlin- case-   noop    noop    noop
  731. noop    noop    noop    for-    noop    if-     noop    mem-
  732. noop    noop    noop    noop    noop    read-   repeat- noop
  733. noop    noop    noop    noop    noop    noop    while-  write- ;
  734.  
  735. : statment     ( --- )
  736.                 keyword?
  737.                 if      do-statment
  738.                 else    var-assign
  739.                 then   ;
  740.  
  741. : begin-1       ( <a1> --- )    \ a1 exists if ptyp is on & is in HEAD SPACE.
  742.                 ptyp
  743.                 if      crout " :" "out ( a1 --- ) $out
  744.                 then   begin- ;
  745.  
  746. 0 value  ?stp
  747.  
  748. : stp   on> ?stp ;
  749.  
  750. : do-block      ( --- )
  751.                 ptr 31 and exec:    \ block interpretation table
  752. stp     stp     begin-1 stp     stp     const-  stp     stp
  753. stp     stp     stp     stp     proc-   stp     stp     stp
  754. stp     stp     stp     stp     proc-   stp     stp     stp
  755. stp     stp     stp     stp     stp     var-    stp     stp ;
  756.  
  757. : block-        ( <a1> --- )    \ a1 exists if ptyp is on
  758.                 keyword?
  759.                 if      off> ?stp
  760.                         begin   do-block ?stp
  761.                         until
  762.                 then   ;
  763.  
  764. : pas_init      ( -- )
  765.                 #tib off        >in off
  766.                 off> con#       off> var#
  767.                 echoon ;
  768.  
  769. : program       ( --- )
  770.                 pas_init
  771.                 off> no-const-or-vars
  772.                 token                   \ pickup "Program" and discard
  773.                 token   ident?? a$place ( --- a1 )
  774.                 token   (?  on> ptyp
  775.                 if      par-pass on> no-const-or-vars
  776.                         off> ptyp
  777.                 then   ;??
  778.                 token   block-
  779.                 " ; " "out .??
  780.                 crout crout ;
  781.  
  782. : init_arrays       ( -- )
  783.                 pcons ?exit
  784.                 maxcon b/con * dup ds:alloc =: pcons pcons swap erase
  785.                 maxvar b/var * dup ds:alloc =: pvars pvars swap erase
  786.                 var$ off a$ off ;
  787.  
  788. : main2         ( -- )
  789.                 init_arrays
  790.                 lineread_init
  791.                 bl word lrhndl $>handle
  792.                 lrhndl hopen abort" Couldn't open file."
  793.                 ibreset
  794.                 program ;
  795.  
  796. : main          ( -- )
  797.                 DECIMAL                         \ always select decimal
  798.                 CAPS ON                         \ ignore cAsE
  799.                 ?DS: SSEG !                     \ init search segment
  800.                 DOSIO_INIT                      \ init EMIT, TYPE & SPACES
  801.                 $FFF0 SET_MEMORY                \ default to 64k code space
  802.                 DOS_TO_TIB                      \ move command tail to TIB
  803.                 main2 ;
  804.  
  805. }
  806.  
  807.