home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / tforth.seq < prev    next >
Text File  |  1990-04-24  |  9KB  |  258 lines
  1. \ FRTH.SEQ              Interpretive Forth Experiment     by Tom Zimmer
  2.  
  3. 0 value  headseg
  4. handle   headhndl
  5. 0 value  headlen
  6. 0 value  headdp
  7. 0 value  wordcnt
  8.  
  9. : read_1line    ( a1 n1 -- )
  10.                 headseg -rot ?ds: tib rot 1- dup #tib ! cmovel >in off
  11.                 ?ds: sseg !
  12.                 bl word number? nip 0=
  13.                 if      drop
  14.                         0 headseg headdp !L exit
  15.                 then
  16.                 headseg headdp !L
  17.                 2 +!> headdp
  18.                 bl word 1+ c@ 128 and headseg headdp c!L
  19.                 incr> headdp
  20.                 here 1+ dup c@ 127 and swap c!
  21.                 ?ds: here dup c@ 1+ headseg headdp rot cmovel
  22.                 here c@ 1+ +!> headdp ;
  23.  
  24. : read_symtbl   ( -- )
  25.                 $1000 alloc 8 =
  26.                 abort" Could not allocate space for symbols" nip =: headseg
  27.                 me@ me$ headhndl $>handle
  28.                 " SYM" ">$ headhndl $>ext
  29.                 headhndl hopen
  30.                 if      cr ." Couldn't open symbol file "
  31.                         headhndl count type abort
  32.                 then
  33.                 0 $FFF0 headhndl headseg exhread =: headlen
  34.                 off> headdp
  35.                 save> base hex
  36.                 0 headlen
  37.                 begin   headseg sseg !
  38.                         2dup $0A scan 2dup 2>r nip - dup
  39.                 while   read_1line
  40.                         2r> 1 /string
  41.                 repeat  2drop 2r> 2drop
  42.                 restore> base
  43.                 ?ds: sseg ! ;
  44.  
  45. : FIND          ( adr  -- cfa flag )
  46.                 dup c@ 0= if false exit then
  47.                 headseg save!> sseg
  48.                 >r 0
  49.                 begin   headseg over 2dup @L 0<> >r
  50.                         3 + 1 rpick swap over c@ 1+ compare r> and
  51.                 while   over 3 + c@L 4 + +
  52.                 repeat  swap 2dup @L ?dup
  53.                 if      -rot 2+ c@L ?dup 0= if 1 then
  54.                 else    2drop here false
  55.                 then    r>drop
  56.                 restore> sseg ;
  57.  
  58. : DEFINED       ( -- here 0 | cfa [ -1 | 1 ] )
  59.                 BL WORD  ?UPPERCASE  FIND   ;
  60.  
  61. : ltype         ( seg a1 n1 -- )
  62.                 bounds
  63.                 ?do     dup i c@L emit
  64.                         ?keypause
  65.                 loop    drop ;
  66.  
  67. : .1name        ( a1 -- )
  68.                 save> base hex
  69.                 >r
  70.                 headseg r@ @L 4 u.r space
  71.                 headseg r@ 4 + headseg r> 3 + c@L ltype tab ?cr
  72.                 restore> base ;
  73.  
  74. : words         ( -- )
  75.                 cr
  76.                 off> wordcnt
  77.                 20 save!> tabsize
  78.                 65 save!> rmargin
  79.                 0 >r
  80.                 begin   headseg r@ @L 0<>
  81.                 while   r@ .1name
  82.                         incr> wordcnt
  83.                         r> headseg over 3 + c@L 4 + + >r
  84.                 repeat  r>drop
  85.                 restore> rmargin
  86.                 restore> tabsize
  87.                 cr wordcnt . ." Total words " ;
  88.  
  89. \ These seemingly silly definitions, make library macros available to
  90. \ the interpretive Forth environment.
  91.  
  92. \ While these are techically re-definitions, any references to these words
  93. \ either before they are defined, or after, will still use the library
  94. \ defined macro.
  95.  
  96. : @             ( a1 -- n1 )    @ ;
  97. : !             ( n1 a1 -- )    ! ;
  98. : C@            ( a1 -- n1 )    C@ ;
  99. : C!            ( n1 a1 -- )    C! ;
  100. : @-T           ( a1 -- n1 )    ?cs: swap @L ;
  101. : !-T           ( n1 a1 -- )    ?cs: swap !L ;
  102. : C@-T          ( a1 -- n1 )    ?cs: swap C@L ;
  103. : C!-T          ( n1 a1 -- )    ?cs: swap C!L ;
  104.  
  105. : DP            ( -- a1 )       DP ;
  106. : HERE          ( -- a1 )       DP @ ;
  107. : DECIMAL       ( -- )          DECIMAL ;
  108. : HEX           ( -- )          HEX ;
  109. : DUP           ( ? )           DUP ;
  110. : DROP          ( ? )           DROP ;
  111. : OVER          ( ? )           OVER ;
  112. : SWAP          ( ? )           SWAP ;
  113. : 2DROP         ( ? )           2DROP ;
  114. : EXECUTE       ( N1 -- )       EXECUTE ;
  115. : ?CS:          ( ? )           ?CS: ;
  116. : ?DS:          ( ? )           ?DS: ;
  117. : TIB           ( ? )           TIB ;
  118. : +             ( ? )           + ;
  119. : -             ( ? )           - ;
  120. : *             ( ? )           * ;
  121. : /             ( ? )           / ;
  122. : MOD           ( ? )           MOD ;
  123. : +!            ( ? )           +! ;
  124. : 0=            ( ? )           0= ;
  125. : 1+            ( ? )           1+ ;
  126. : 2+            ( ? )           2+ ;
  127. : INCR          ( ? )           INCR ;
  128. : DECR          ( ? )           DECR ;
  129. : RP@           ( ? )           RP@ 2+ ;
  130. : SP@           ( ? )           SP@ ;
  131.  
  132. : ?do_execute   ( n1 f1 -- )
  133.                 128 =
  134.                 if      execute
  135.                 then ;
  136.  
  137. : ?missing      ( F1 -- )
  138.                 if      here count type true abort"  ?"
  139.                 then    ;
  140.  
  141. : .depth        ( -- )
  142.                 depth 10 umin 0
  143.                 ?do ." ." loop ;
  144.  
  145. : tnumber?      ( a1 -- d1 f1 )
  146.                 dup 1+ c@ '$' =                 \ if first char is a $
  147.                 if      save> base hex
  148.                         dup>r count 1- over c!  \ remove  the $ symbol
  149.                         number?                 \ attempt number conversion
  150.                         '$' r> 1+ c!            \ restore the $ symbol
  151.                         restore> base
  152.                 else    number?
  153.                 then    ;
  154.  
  155. : number        ( a1 -- n1 )
  156.                 tnumber? nip 0= ?missing ;
  157.  
  158. : dummy         ( -- )                  \ make sure a bunch of words are
  159.                 exit                    \ included in target
  160.                 u. .r h. h.r dump ;
  161.  
  162. : ?stack        ( -- )
  163.                 depth 0< abort" Stack Underflow!" ;
  164.  
  165. : interpret     ( -- )
  166.                 begin   ?stack  defined here c@
  167.                 while   ?dup
  168.                         if      ?do_execute
  169.                         else    number
  170.                         then
  171.                 repeat  2drop ;
  172.  
  173. : '             ( | <name> -- a1 )
  174.                 defined 0= ?missing ;
  175.  
  176. : >name         ( adr  -- adr2 )
  177.                 0 >r
  178.                 begin   headseg r@ @L over <>
  179.                         headseg r@ @L 0<> and
  180.                 while   r> headseg over 3 + c@L 4 + + >r
  181.                 repeat  drop r> headseg over @L 0=
  182.                 if      drop false
  183.                 then    ;
  184.  
  185. : .id           ( a1 -- )
  186.                 dup 0= if drop exit then
  187.                 headseg swap 3 + 2dup c@L ?ds: pad rot 1+ cmovel
  188.                 pad count type space ;
  189.  
  190. ?DIS #IF
  191.  
  192. : dis.symbol    ( a1 -- )
  193.                 dup >name ?dup
  194.                 if      .id
  195.                 else    dup H.
  196.                 then    drop ;
  197.  
  198. 32 array disname
  199.  
  200. : dis?symbol    ( a1 -- <a2 n1> f1 )
  201.                 >name dup
  202.                 if      headseg swap 3 + 2dup c@L ?ds: disname rot 1+ cmovel
  203.                         disname count true
  204.                 then    ;
  205.  
  206. : see           ( | <name> -- )
  207.                 ['] dis.symbol is .symbol
  208.                 ['] dis?symbol is ?symbol
  209.                 ' dis ;
  210.  
  211. : dis           ( a1 -- )
  212.                 ['] dis.symbol is .symbol
  213.                 ['] dis?symbol is ?symbol
  214.                 dis ;
  215.  
  216. #ENDIF
  217.  
  218. ?DBG #IF
  219.  
  220. : dbg           ( | <name> -- )
  221.                 ['] dis.symbol is .symbol
  222.                 ['] dis?symbol is ?symbol
  223.                 ' $trace ;
  224.  
  225. : debug         ( | <name> -- )
  226.                 ['] dis.symbol is .symbol
  227.                 ['] dis?symbol is ?symbol
  228.                 ['] interpret  =: interp
  229.                 ' $breakat ;
  230.  
  231. : $trace        ( a1 -- )
  232.                 ['] dis.symbol is .symbol
  233.                 ['] dis?symbol is ?symbol
  234.                 $trace ;
  235.  
  236. : $breakat      ( a1 -- )
  237.                 ['] dis.symbol is .symbol
  238.                 ['] dis?symbol is ?symbol
  239.                 ['] interpret  =: interp
  240.                 $breakat ;
  241.  
  242. #ENDIF
  243.  
  244. : QUIT          ( -- )
  245.                 sp0 @ sp!               \ reset data stack
  246.                 tib0 @ 'tib !           \ reset TIB
  247.                 begin   rp0 @ rp!       \ reset return stack
  248.                         cr query  space interpret ."  ok " .depth
  249.                 again  ;
  250.  
  251. : cold          ( -- )
  252.                 ." 80x86 Forth environment for TCOM "
  253.                 0 =: abort_func read_symtbl     \ error here, does BYE
  254.                 ['] quit is abort_func          \ don't leave on error
  255.                 quit
  256.                 ;
  257.  
  258.