home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / kernel.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  15.9 KB  |  1,226 lines
  1.  
  2. \
  3. \    Kernel
  4. \
  5.  
  6.  
  7.  
  8. \
  9. \    Core words
  10. \
  11.  
  12. \    Core words.  If primitives have been defined, these are not used.
  13.  
  14. \    ! # #> #S ' ( * */ */MOD + +! +LOOP , - . ." / /MOD 
  15. \    0< 0= 1+ 1- 2! 2* 2/ 2@ 2drop 2dup 2over 2swap :
  16. \    ; < <# = > >body >in >number >r ?dup @ abort abort"
  17. \    abs accept align aligned allot and base begin bl c! c,
  18. \    c@ cell+ cells char char+ chars constant count cr create
  19. \    decimal depth do does> drop dup else emit environment?
  20. \    evaluate execute exit fill find fm/mod here hold i if
  21. \    immediate invert j key leave literal loop lshift m* max min
  22. \    mod move negate or over postpone quit r> r@ recurse
  23. \    repeat rot rshift s" s>d sign source space spaces state
  24. \    swap then type u. u< um* um/mod unloop until variable
  25. \    while word xor [ ['] [char] ] 
  26.  
  27. \    stack words
  28.  
  29. [IFUNDEF] 2DROP
  30. : 2DROP        \ core
  31.     drop drop 
  32. ;
  33. [THEN]
  34. test" 2drop  2. 3. 2drop 2. d="
  35.  
  36. [IFUNDEF] 2DUP
  37. : 2DUP        \ core
  38.     over over
  39. ;
  40. [THEN]
  41. test" 2dup  1. 2. 2dup 2. d="
  42.  
  43. [IFUNDEF] 2OVER
  44. : 2OVER    
  45.     2 pick 2 pick
  46. ;
  47. [THEN]
  48. test" 2over  1. 2. 2over 1. d= "
  49.  
  50. [IFUNDEF] 2SWAP
  51. : 2SWAP
  52.     rot >r rot r>
  53. ;
  54. [THEN]
  55.  
  56. [IFUNDEF] >R
  57. \ : >R
  58. \ ;
  59. [THEN]
  60.  
  61. [IFUNDEF] ?DUP
  62. : ?DUP
  63.     dup if dup then
  64. ;
  65. [THEN]
  66.  
  67. [IFUNDEF] DEPTH
  68. : DEPTH
  69.     sp@ sp0 @ - negate [ cell<< ] literal rshift
  70. ;
  71. [THEN]
  72.  
  73. [IFUNDEF] DROP
  74. : DROP
  75.     >r rdrop
  76. ;
  77. [THEN]
  78.  
  79. [IFUNDEF] DUP
  80. : DUP
  81.     >r r@ r>
  82. ;
  83. [THEN]
  84.  
  85. [IFUNDEF] OVER
  86. : OVER
  87.     2>r r@ 2r> swap
  88. ;
  89. [THEN]
  90. test" over  1 2 over 1 = swap 2 = and swap 1 = and"
  91.  
  92. [IFUNDEF] TUCK
  93. : TUCK swap over ;
  94. [THEN]
  95.  
  96. [IFUNDEF] R>
  97. \ : R>
  98. \ ;
  99. error" need prim r>"
  100. [THEN]
  101.  
  102. [IFUNDEF] R@
  103. : R@
  104.     r> dup >r
  105. ;
  106. [THEN]
  107.  
  108. [IFUNDEF] SWAP
  109. \ : SWAP
  110. \ ;
  111. error" need prim swap"
  112. [THEN]
  113.  
  114. \    memory words
  115.  
  116.  
  117. [IFUNDEF] ! 
  118. \ : ! 
  119. \ ;
  120. error" need prim !"
  121. [THEN]
  122.  
  123. [IFUNDEF] +!
  124. : +!
  125.     dup @ over + swap !
  126. ;
  127. [THEN]
  128.  
  129. [IFUNDEF] 2!
  130. : 2!
  131.     2dup ! cell+ !
  132. ;
  133. [THEN]
  134.  
  135. [IFUNDEF] 2@
  136. : 2@
  137.     dup cell+ @ swap @
  138. ;
  139. [THEN]
  140.  
  141. [IFUNDEF] @
  142. \ : @
  143. \ ;
  144. error" need prim @"
  145. [THEN]
  146.  
  147. [IFUNDEF] C!
  148. \ : C!
  149. \ ;
  150. error" need prim c!"
  151. [THEN]
  152.  
  153. [IFUNDEF] C@
  154. \ : C@
  155. \ ;
  156. error" need prim c@"
  157. [THEN]
  158.  
  159. [IFUNDEF] CHAR+
  160. : CHAR+ 
  161.     #char + 
  162. ;
  163. [THEN]
  164.  
  165. [IFUNDEF] CHARS
  166. : CHARS 
  167.     #char * 
  168. ;
  169. [THEN]
  170.  
  171. [IFUNDEF] CELL+
  172. : CELL+
  173.     #cell +
  174. ;
  175. [THEN]
  176.  
  177. [IFUNDEF] CELLS
  178. : CELLS
  179.     #cell *
  180. ;
  181. [THEN]
  182.  
  183.  
  184. [IFUNDEF] FILL
  185. : FILL
  186.     rot rot 
  187.     over + swap
  188.     ?do dup I c! loop drop
  189. ;
  190. [THEN]
  191.  
  192.  
  193. [IFUNDEF] MOVE
  194. \ note: chars == address units
  195. : MOVE
  196.     >r 2dup u< if r> cmove> else r> cmove then
  197. ;
  198. [THEN]
  199.  
  200.  
  201. \    math words
  202.  
  203. [IFUNDEF] *
  204. : *
  205.     um* d>s
  206. ;
  207. [THEN]
  208.  
  209. [IFUNDEF] */
  210. : */
  211.     */mod swap drop
  212. ;
  213. [THEN]
  214.  
  215. [IFUNDEF] */MOD
  216. : */MOD ( n1 n2 n3 -- n4 n5 ) \ core    star-slash-mod
  217.     >r m* r> sm/rem 
  218. ;
  219. [THEN]
  220.  
  221. [IFUNDEF] +
  222. \ : +
  223. \ ;
  224. error" need prim +"
  225. [THEN]
  226.  
  227. [IFUNDEF] -
  228. : -
  229.     negate +
  230. ;
  231. [THEN]
  232.  
  233. [IFUNDEF] /
  234. : /
  235.     /mod swap drop
  236. ;
  237. [THEN]
  238.  
  239. [IFUNDEF] /MOD
  240. : /MOD
  241.     >r s>d r> sm/rem
  242. ;
  243. [THEN]
  244.  
  245. [IFUNDEF] 0<
  246. \ : 0<
  247. \ ;
  248. [THEN]
  249.  
  250. [IFUNDEF] 0=
  251. : 0=
  252.     if 0 else -1 then
  253. ;
  254. [THEN]
  255.  
  256. [IFUNDEF] 1+
  257. : 1+
  258.     1 +
  259. ;
  260. [THEN]
  261.  
  262. [IFUNDEF] 1-
  263. : 1-
  264.     1 -
  265. ;
  266. [THEN]
  267.  
  268. [IFUNDEF] 2*
  269. : 2*
  270.     dup +
  271. ;
  272. [THEN]
  273.  
  274. [IFUNDEF] 2/
  275. : 2/
  276.     1 rshift
  277. ;
  278. [THEN]
  279.  
  280. [IFUNDEF] <
  281. : <
  282.     - 0<
  283. ;
  284. [THEN]
  285.  
  286. [IFUNDEF] =
  287. : =
  288.     - 0=
  289. ;
  290. [THEN]
  291.  
  292. [IFUNDEF] >
  293. : >
  294.     - 0>
  295. ;
  296. [THEN]
  297.  
  298. [IFUNDEF] ABS
  299. : ABS
  300.     dup 0< if negate then
  301. ;
  302. [THEN]
  303.  
  304. [IFUNDEF] AND
  305. \ : AND
  306. \ ;
  307. [THEN]
  308.  
  309. [IFUNDEF] FM/MOD
  310. : FM/MOD        \ d1 n1 -- n2 n3          core            f_m_slash_mod
  311. \    floored division: d1 = n3*n1+n2, 0<=n2<n1 or n1<n2<=0
  312.  
  313.     dup >r dup 0< IF  negate >r dnegate r>  THEN
  314.     over       0< IF  tuck + swap  THEN
  315.     um/mod
  316.     r> 0< IF  swap negate swap  THEN
  317. ;
  318. [THEN]
  319. test" fm/mod 1ff. f fm/mod 22 = swap 1 = and"
  320. test" fm/mod -1ff. f fm/mod -23 = swap e = and"
  321.  
  322. [IFUNDEF] INVERT
  323. : INVERT
  324.     negate 1-
  325. ;
  326. [THEN]
  327.  
  328. [IFUNDEF] LSHIFT
  329. : LSHIFT
  330.     0 ?do dup + loop
  331. ;
  332. [THEN]
  333.  
  334. \ [IFUNDEF] M*
  335. : M*
  336.     2dup xor >r 
  337.     abs swap abs 
  338.     um* 
  339.     r> 0< if dnegate then
  340. ;
  341. \ [THEN]
  342. test" m* 3 -4 m* -$c. d="
  343. test" m* -4 -3 m* $c. d="
  344.  
  345. [IFUNDEF] MAX
  346. : MAX
  347.     2dup >= if drop else nip then
  348. ;
  349. [THEN]
  350. test" max -5 6 max 6 ="
  351.  
  352. [IFUNDEF] MIN
  353. : MIN
  354.     2dup <= if drop else nip then
  355. ;
  356. [THEN]
  357. test" min 6 -5 min -5 ="
  358.  
  359. [IFUNDEF] MOD
  360. : MOD
  361.     /mod drop
  362. ;
  363. [THEN]
  364.  
  365. [IFUNDEF] NEGATE
  366. : NEGATE
  367.     invert 1+
  368. ;
  369. [THEN]
  370.  
  371. [IFUNDEF] OR
  372. \ : OR
  373. \ ;
  374. [THEN]
  375.  
  376. [IFUNDEF] ROT
  377. : ROT    \ a b c -- b c a
  378.     >r swap r> swap
  379. ;
  380. [THEN]
  381. test" rot 1 2 3 rot 1 = swap 3 = and swap 2 ="
  382.  
  383. [IFUNDEF] RSHIFT
  384. : RSHIFT
  385.     0 ?do 2/ loop
  386. ;
  387. [THEN]
  388.  
  389. [IFUNDEF] S>D
  390. \ both endians will have the high word on top
  391. : S>D
  392.     dup 0< if -1 else 0 then
  393. ;
  394. [THEN]
  395. test" s>d 45 s>d 0= swap 45 = and"
  396.  
  397.  
  398. [IFUNDEF] SM/REM
  399. : SM/REM    ( d1 n1 -- n2 n3 )
  400. \ symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0
  401.     over >r 
  402.     dup >r abs 
  403.     rot rot
  404.     dabs rot um/mod
  405.     r> r@ xor 0< IF       negate       THEN
  406.     r>        0< IF  swap negate swap  THEN
  407. ;
  408. [THEN]
  409. test" sm/rem -$1ff. $f sm/rem -$22 = swap -$1 = and"
  410.  
  411. [IFUNDEF] U<
  412. \ : U<
  413. \ ;
  414. error" need prim u<"
  415. [THEN]
  416. test" u< 1 2 u<"
  417. test" u< 2 1 u< 0="
  418. test" u< -1 2 u< 0="
  419. test" u< 2 -1 u<"
  420.  
  421. [IFUNDEF] UM*
  422. \ magic code stolen from gforth
  423. \
  424. : d2*+ ( ud n -- ud+n c )
  425.     over MINI
  426.     and >r >r 2dup d+ swap r> + swap r> 
  427. ;
  428. : UM*
  429.    >r >r 0 0 r> r> [ 8 cells ] literal 0
  430.    DO
  431.        over >r dup >r 0< and d2*+ drop
  432.        r> 2* r> swap
  433.    LOOP 2drop 
  434. ;
  435. [THEN]
  436.  
  437. [IFUNDEF] UM/MOD
  438. \ magic code stolen from gforth
  439. \
  440. : /modstep ( ud c R: u -- ud-?u c R: u )
  441.     >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN  d2*+ r> 
  442. ;
  443. : UM/MOD    \ ud u1 -- u2 u3          core    u_m_slash_mod
  444.     0 swap [ 8 cells 1 + ] literal 0
  445.     ?DO /modstep
  446.     LOOP drop swap 1 rshift or swap 
  447. ;
  448. [THEN]
  449.  
  450. [IFUNDEF] XOR
  451. \ : XOR
  452. \ ;
  453. error" need prim xor"
  454. [THEN]
  455.  
  456. [IFUNDEF] TYPE
  457. : TYPE    ( caddr n -- )
  458.     0 ?do 
  459.         dup c@ emit 1+
  460.     loop
  461.     drop
  462. ;
  463. [THEN]
  464.  
  465.  
  466. [IFUNDEF] ."
  467. : ."
  468.     postpone s"
  469.     state @ if
  470.         [compile] type
  471.     else
  472.         type
  473.     then
  474. ; immediate
  475. [THEN]
  476.  
  477. [IFUNDEF] >NUMBER
  478. : dn* ( ud un -- ud )
  479.     \            hi.lo 
  480.     \        *        n
  481.     \    -------------
  482.     \    hi.lo*n lo.lo*n
  483.     \    lo.hi*n    0
  484.     dup rot     \ ( lo-d un un hi-d )
  485.     um*         \ ( lo-d un d.hiprod )
  486.     drop >r        \ save lo.hi*n
  487.     um*         \ ( d.loprod )
  488.     0 r>         \ create d.hiprod
  489.     d+ 
  490. ;
  491.  
  492. : (skip)
  493.     1 /string
  494. ;
  495.  
  496. \    yes, this ignores '+' and '-' and '.'
  497. : >NUMBER    \ CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
  498.     begin            \ ( ud1 c-addr1 u1 )
  499.         dup            \ chars left?
  500.         if
  501.             over c@     
  502.             base @
  503.             swap digit        \ legal digit?
  504.         else
  505.             0
  506.         then        \ ( ud1 c-addr1 u1 # -1 | ud1 c-addr1 u1 0 )
  507.     while
  508.         >r            \ save digit
  509.         2swap         \ get accum
  510.         base @ dn*
  511.         r> s>d d+    \ add digit
  512.         2swap
  513.         (skip)        \ advance pointer    
  514. \        2dup . .
  515.     repeat
  516. ;
  517. [THEN]
  518.  
  519. \ : testnum s" 18446744069414584320" ;
  520. \ test" >number 0. testnum  >number 2drop 2dup d. 1. d+ or 0="
  521. : testnum s" 4294967295" ;
  522. test" >number 0. testnum  >number 2drop 2dup d. 1. d+ or 0="
  523.  
  524. [IFUNDEF] ABORT"
  525. : (abort")
  526.     rot if cr ." error: " type cr abort else 2drop then
  527. ;
  528.  
  529. : ABORT"
  530. \        Compilation: ( "ccc<quote>" -- )
  531. \
  532. \   Parse ccc delimited by a " (double-quote). Append the run-time semantics
  533. \   given below to the current definition.
  534. \
  535. \        Run-time: ( i*x x1 --  | i*x ) ( R: j*x --  | j*x )
  536. \
  537. \   Remove x1 from the stack. If any bit of x1 is not zero, display ccc and
  538. \   perform an implementation-defined abort sequence that includes the
  539. \   function of ABORT.
  540.  
  541.     postpone s"
  542.     state @ if
  543.         [compile] (abort")
  544.     else
  545.         (abort")
  546.     then
  547. ; immediate
  548. [THEN]
  549.  
  550. [IFUNDEF] BASE
  551. User BASE
  552. [THEN]
  553.  
  554. [IFUNDEF] EXECUTE
  555. \ : EXECUTE
  556. \ ;
  557. error" need prim execute"
  558. [THEN]
  559.  
  560. \ \\\\\\\\\\\\\\\
  561.  
  562. [IFUNDEF] ]
  563. : ]
  564.     -1 state !
  565. ;
  566. [THEN]
  567.  
  568. [IFUNDEF] I
  569. \ : I
  570. \ ;
  571. [THEN]
  572.  
  573. [IFUNDEF] J
  574. \ : J
  575. \ ;
  576. [THEN]
  577.  
  578. [IFUNDEF] LITERAL
  579. : DLITERAL
  580.     state @ if 
  581.         swap postpone lit , postpone lit ,
  582.     then
  583. ; immediate
  584.  
  585. : LITERAL
  586.     state @ if 
  587.         postpone lit ,
  588.     then
  589. ; immediate
  590. [THEN]
  591.  
  592. [IFUNDEF] SLITERAL
  593. : string,    ( caddr u -- )
  594.     dup    c, 
  595.     here swap chars dup allot move
  596. ;
  597.  
  598. : SLITERAL    \ C: ( caddr u --  ) R: ( -- caddr u )
  599.     state @ if
  600.         [compile] (s") string, align
  601.     else
  602.         \ copy string to safe place
  603.         >r (slit-pad) @ r@ cmove
  604.         (slit-pad) @ r>
  605.     then
  606. ; immediate
  607. [THEN]
  608.  
  609. [IFUNDEF] S"
  610. : S"
  611.     $22 parse
  612.     postpone sliteral
  613. ; immediate
  614. [THEN]
  615.  
  616. [IFUNDEF] VARIABLE
  617. \ : VARIABLE
  618. \ ;
  619. [THEN]
  620.  
  621. \    printing words
  622.  
  623. user hld            \ offset into number pad
  624.  
  625. [IFUNDEF] -pad
  626. : -pad
  627.     (#-pad) @
  628. ;
  629. [THEN]
  630.  
  631. \    we use an area at the end of dictionary in front of PAD
  632. [IFUNDEF] <#
  633. : <#    \     ( -- )
  634. \   Initialize the pictured numeric output conversion process.
  635.      -pad hld !
  636. ;
  637. [THEN]
  638.  
  639. [IFUNDEF] HOLD
  640. : HOLD    \    ( char -- )
  641. \   Add char to the beginning of the pictured numeric output string. An ambiguous condition exists if HOLD executes outside of
  642. \   a <# #> delimited number conversion.
  643.      -1 hld +! 
  644.     hld @ c!
  645. ;
  646.  
  647. [IFUNDEF] #
  648.  
  649. [IFUNDEF] M/MOD
  650. : M/MOD    ( ud un -- ur udq )
  651.     \ divide high word by base
  652.     >r 0 r@     ( ud.l ud.h:0 un | R: un ) 
  653.     u/             ( ud. ud.h*10000%r:ud.h*10000/r | R: un ) 
  654.     r> swap >r    ( ud.l:ud.h*10000%r un | R: ud.h*10000/r )
  655.     u/             ( r q )
  656.     r>            ( r q ud.h*10000/r )
  657. ;
  658. [THEN]
  659.  
  660. [IFUNDEF] (#)
  661. : (#)    ( ud base -- ud' ch )
  662.     m/mod        \ ( ur udq ) 
  663.     rot         \ ( udq ur )
  664.     $09 over <    \ ( udq 9<ur )
  665.     if $07 + then 
  666.     $30 + 
  667. ;
  668. [THEN]
  669.  
  670. : #        \   ( ud1 -- ud2 )
  671. \   Divide ud1 by the number in BASE giving the quotient ud2 and the remainder n. (n is the least-significant digit of ud1.)
  672. \   Convert n to external form and add the resulting character to the beginning of the pictured numeric output string. An
  673. \   ambiguous condition exists if # executes outside of a <# #> delimited number conversion.
  674.  
  675.     base @  
  676.     (#)
  677.     hold
  678. ;
  679. [THEN]
  680.  
  681. [IFUNDEF] #>
  682. : #>    \    ( xd -- c-addr u )
  683. \   Drop xd. Make the pictured numeric output string available as a character string. c-addr and u specify the resulting
  684. \   character string. A program may replace characters within the string.
  685.     2drop hld @ -pad over -
  686. ;
  687. [THEN]
  688.  
  689. [IFUNDEF] #S
  690. : #S    \    ( ud1 -- ud2 )
  691. \   Convert one digit of ud1 according to the rule for #. Continue conversion until the quotient is zero. ud2 is zero. An
  692. \   ambiguous condition exists if #S executes outside of a <# #> delimited number conversion.
  693.     begin
  694.         #
  695.         2dup or    0=
  696.     until
  697. ;
  698. [THEN]
  699. test" abs 394 abs 394 ="
  700. test" abs -395 abs 395 ="
  701.  
  702. [IFUNDEF] .
  703. : .
  704.     0 .r space
  705. ;
  706. [THEN]
  707. test" . -640 . 1"
  708.  
  709. [IFUNDEF] BL
  710. $20 constant BL
  711. [THEN]
  712.  
  713. [IFUNDEF] CR
  714. : CR
  715.     $0D emit
  716. ;
  717. [THEN]
  718.  
  719. [IFUNDEF] DECIMAL
  720. : DECIMAL
  721.     $A base !
  722. ;
  723. [THEN]
  724.  
  725. [IFUNDEF] SIGN
  726. : SIGN    \    ( n -- )        \ depends on high word being TOS
  727.     0< if
  728.         $2d hold
  729.     then
  730. ;
  731. [THEN]
  732.  
  733. [IFUNDEF] SPACE
  734. : SPACE
  735.     bl emit
  736. ;
  737. [THEN]
  738.  
  739. [IFUNDEF] SPACES
  740. : SPACES
  741.     0 max 0 ?do bl emit loop
  742. ;
  743. [THEN]
  744.  
  745. [IFUNDEF] U.
  746. : U.
  747.     0 u.r space
  748. ;
  749. [THEN]
  750.  
  751.  
  752. \    string words
  753.  
  754. [IFUNDEF] COUNT
  755. : COUNT
  756.     dup c@ swap 1+ swap
  757. ;
  758. [THEN]
  759.  
  760. [IFUNDEF] WORD
  761. : (parse-word)    ( ch -- caddr u )
  762.     (skip-spaces)
  763.     parse                \ get new word
  764. ;
  765.  
  766. : WORD    \    ( char "<chars>ccc<char>" -- c-addr )
  767.     (parse-word) 
  768.     2dup + bl swap c!    \ word ends with space
  769.     -pad (>c)             \ copy to word pad
  770.     -pad                \ leave addr
  771. ;
  772. [THEN]
  773.  
  774.  
  775. \    I/O words
  776.  
  777. [IFUNDEF] ACCEPT
  778. : overstrike
  779.     bksp emit bl emit bksp emit
  780. ;
  781.  
  782. : ACCEPT
  783. \        ( c-addr +n1 -- +n2 )
  784. \   Receive a string of at most +n1 characters. An ambiguous condition exists if +n1 is zero or greater than 32,767. Display
  785. \   graphic characters as they are received. A program that depends on the presence or absence of non-graphic characters in
  786. \   the string has an environmental dependency. The editing functions, if any, that the system performs in order to construct
  787. \   the string are implementation-defined.
  788. \
  789. \    (EJS: this one does not automatically abort at n1 chars.)
  790.     swap >r        \ store c-addr on R:
  791.     0            \ position
  792.     begin
  793.         key
  794.         dup $0d <>
  795.     while
  796.         dup bksp <>
  797.         if
  798.             >r            \ store key
  799.             2dup <= if bksp emit then
  800.             r@ emit        \ show key
  801.             over 1- min      \ get proper index    ( max idx -- )
  802.             dup r> swap r@ + c!    \ write
  803.             1+
  804.         else
  805.             drop dup 0 > if        \ don't go too far
  806.                 overstrike    \ backspace
  807.                 1-
  808.             then
  809.         then
  810.     repeat
  811.     drop        \ key
  812.     min            \ lose max #chars
  813.     rdrop
  814. ;
  815. \ : prompt ." type stuff> " ;
  816. \ test" accept prompt pad 5 accept pad swap $2a emit type $2a emit  1"
  817. [THEN]
  818.  
  819. [IFUNDEF] EMIT
  820. \ : EMIT
  821. \     drop
  822. \ ;
  823. error" need emit"
  824. [THEN]
  825.  
  826. [IFUNDEF] ENVIRONMENT?
  827. : ENVIRONMENT?
  828.     2drop 0
  829. ;
  830. [THEN]
  831.  
  832. [IFUNDEF] KEY
  833. \ : KEY
  834. \ ;
  835. error" need key"
  836. [THEN]
  837.  
  838. : (quit?)
  839.     dup &81 = swap &113 = or
  840. ;
  841.  
  842. : (pause?)    ( -- <t|f to quit> )
  843.     key? dup if 
  844.         key (quit?) 0= if        \ 'q'
  845.             0= key (quit?) or
  846.         then
  847.     then
  848. ;
  849.  
  850. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  851.  
  852. \    CORE EXT words
  853. \    #tib .( .r 0<> 0> 2>r 2r> 2r@
  854. \    :noname <> ?do again c" case compile,
  855. \    convert endcase endof erase expect
  856. \    false hex marker nip of pad parse
  857. \    pick query refill restore-input roll
  858. \    save-input source-id span tib to
  859. \    true tuck u.r u> unused value
  860. \    within [compile] \ 
  861.  
  862. [IFUNDEF] #TIB
  863. User #TIB
  864. [THEN]
  865.  
  866. [IFUNDEF] .(
  867. \ : .(
  868. \ ;
  869. [THEN]
  870.  
  871. [IFUNDEF] .R
  872. \ : .R
  873. \ ;
  874. [THEN]
  875.  
  876. [IFUNDEF] 0<>
  877. \ : 0<>
  878. \ ;
  879. [THEN]
  880.  
  881. [IFUNDEF] 0>
  882. \ : 0>
  883. \ ;
  884. [THEN]
  885.  
  886. [IFUNDEF] 2>R
  887. \ : 2>R
  888. \ ;
  889. [THEN]
  890.  
  891. [IFUNDEF] 2R>
  892. \ : 2R>
  893. \ ;
  894. [THEN]
  895.  
  896. [IFUNDEF] 2R@
  897. \ : 2R@
  898. \ ;
  899. [THEN]
  900.  
  901. [IFUNDEF] :NONAME
  902. \ : :NONAME
  903. \ ;
  904. [THEN]
  905.  
  906. [IFUNDEF] <>
  907. : <>    \ core ext
  908.     = NOT
  909. ;
  910. [THEN]
  911.  
  912. [IFUNDEF] .R
  913. : .R
  914.     >r                \ field width
  915.     s>d                \ make double
  916.     dup >r            \ sign
  917.     dabs <# #S r> sign #>
  918.     r> over - spaces
  919.     type
  920. ;
  921. [THEN]
  922.  
  923.  
  924. [IFUNDEF] C"
  925. \ : C"
  926. \ ;
  927. [THEN]
  928.  
  929. [IFUNDEF] CONVERT
  930. \ : CONVERT
  931. \ ;
  932. [THEN]
  933.  
  934. [IFUNDEF] ERASE
  935. \ : ERASE
  936. \ ;
  937. [THEN]
  938.  
  939. [IFUNDEF] EXPECT
  940. \ : EXPECT
  941. \ ;
  942. [THEN]
  943.  
  944. [IFUNDEF] FALSE
  945. 0 constant FALSE
  946. [THEN]
  947.  
  948. [IFUNDEF] HEX
  949. : HEX
  950.     $10 base !
  951. ;
  952. [THEN]
  953.  
  954. [IFUNDEF] MARKER
  955. \ : MARKER
  956. \ ;
  957. [THEN]
  958.  
  959. [IFUNDEF] NIP
  960. \ : NIP
  961. \ ;
  962. [THEN]
  963.  
  964. [IFUNDEF] PAD
  965. : PAD
  966.     (pad) @
  967. ;
  968. [THEN]
  969.  
  970. [IFUNDEF] PARSE        \ core ext, used to implement WORD
  971.  
  972. \    Match 'char' inside [caddr..caddr+u) and return length of word
  973. : (match)        ( caddr u char "ccc<char>" -- u )
  974.  
  975.     over >r            \ save original #chars
  976.     >r                \ store char 
  977.     begin
  978.         dup            \ any more chars left?
  979.         if
  980.             over c@      \ ( caddr u ch' )
  981.             r@             \ ( caddr u ch' ch )
  982.             <>            \ ( caddr u t/f )
  983.         else
  984.             0
  985.         then
  986.     while
  987.         1- swap 1+ swap
  988.     repeat
  989.     rdrop
  990.  
  991.     swap drop        ( u' )
  992.     r>                 ( u' u )
  993.     swap -            ( len )
  994. ;
  995. [THEN]
  996.  
  997. : mystr s" 1111123456" ;
  998. test" (match) mystr $32 (match) mystr drop swap type 1"
  999.  
  1000. \    Return bounds of remaining source
  1001. : (src>)        ( -- caddr u )
  1002.     source     
  1003.     >in @ 
  1004.     - 0 max
  1005.     swap >in @ + swap
  1006. ;
  1007.  
  1008. \    (>src) advances >in by u' bytes
  1009. : (>src)            \ ( u' -- )
  1010.     1+ >in +!        \ update >in
  1011. ;
  1012.  
  1013.  
  1014. : PARSE    \     ( char "ccc<char>" -- c-addr u )
  1015. \   Parse ccc delimited by the delimiter char.
  1016. \   c-addr is the address (within the input buffer) and u is the length of the parsed string. If the parse area was empty, the
  1017. \   resulting string has a zero length.
  1018.     (src>) over >r 
  1019.     rot (match)
  1020.     dup (>src)
  1021.     r> swap
  1022. ;
  1023.  
  1024. \    Skip spaces in source
  1025. : (skip-spaces)    ( -- )
  1026.     (src>)
  1027.     0 ?do
  1028.         dup c@ bl > if
  1029. \            unloop drop exit    \ needed to avoid problem using cross.fs's 'leave'
  1030.             unloop leave        \ nope, UNLOOP doesn't exit the loop.
  1031.         else
  1032.             1+ 1 >in +!
  1033.         then
  1034.     loop
  1035.     drop
  1036. ;
  1037.  
  1038. [THEN]
  1039.  
  1040. [IFUNDEF] PICK
  1041. \ : PICK
  1042. \ ;
  1043. [THEN]
  1044.  
  1045. [IFUNDEF] ROLL
  1046. \ : ROLL
  1047. \ ;
  1048. [THEN]
  1049.  
  1050. [IFUNDEF] SPAN
  1051. \ : SPAN
  1052. \ ;
  1053. [THEN]
  1054.  
  1055. [IFUNDEF] TO
  1056. \ : TO
  1057. \ ;
  1058. [THEN]
  1059.  
  1060. [IFUNDEF] TRUE
  1061. -1 constant TRUE
  1062. [THEN]
  1063.  
  1064. [IFUNDEF] TUCK
  1065. : TUCK
  1066.     dup >r swap r>
  1067. ;
  1068. [THEN]
  1069.  
  1070. [IFUNDEF] U.R
  1071. : U.R
  1072.     >r 
  1073.     0            \ make double
  1074.     <# #S #>
  1075.     r> over - spaces
  1076.     type
  1077. ;
  1078. [THEN]
  1079.  
  1080.  
  1081. [IFUNDEF] U>
  1082. \ : U>
  1083. \ ;
  1084. [THEN]
  1085.  
  1086. [IFUNDEF] UNUSED
  1087. \ : UNUSED
  1088. \ ;
  1089. [THEN]
  1090.  
  1091. [IFUNDEF] VALUE
  1092. \ : VALUE
  1093. \ ;
  1094. [THEN]
  1095.  
  1096. [IFUNDEF] WITHIN
  1097. : WITHIN    ( test low high -- flag )   
  1098.     over - >r - r> u<
  1099. ;
  1100. [THEN]
  1101.  
  1102. [IFUNDEF] \
  1103. : \
  1104.     blk @
  1105.     if >in @ c/l / 1+ c/l * >in ! exit
  1106.     then
  1107.     source >in ! drop 
  1108. ; immediate
  1109. [THEN]
  1110.  
  1111. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  1112.  
  1113.  
  1114. \
  1115. \    STRING words
  1116. \
  1117.  
  1118. [IFUNDEF] CMOVE
  1119. \ : CMOVE
  1120. \ ;
  1121. [THEN]
  1122.  
  1123. [IFUNDEF] CMOVE>
  1124. \ : CMOVE>
  1125. \ ;
  1126. [THEN]
  1127.  
  1128. [IFUNDEF] /STRING
  1129. \ : /STRING
  1130. \ ;
  1131. [THEN]
  1132.  
  1133. [IFUNDEF] COMPARE
  1134. \ : COMPARE
  1135. \ ;
  1136. [THEN]
  1137.  
  1138.  
  1139. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  1140.  
  1141.  
  1142. \
  1143. \    Double words
  1144. \
  1145.  
  1146. [IFUNDEF] D.    
  1147. : D.R
  1148.     >r                \ field width
  1149.     dup >r            \ sign
  1150.     dabs <# #S r> sign #>
  1151.     r> over - spaces
  1152.     type
  1153. ;
  1154. : D.        \ DOUBLE
  1155.     0 d.r space
  1156. ;
  1157. [THEN]
  1158.  
  1159. [IFUNDEF] UD.
  1160. : UD.R    \ double
  1161.     >r
  1162.     <# #S #>
  1163.     r> over - spaces
  1164.     type
  1165. ;
  1166. : UD.    \ double
  1167.     0 UD.R
  1168.     space
  1169. ;
  1170. [THEN]
  1171.  
  1172. [IFUNDEF] D-
  1173. : D-
  1174.     DNEGATE D+
  1175. ;
  1176. [THEN]
  1177.  
  1178. [IFUNDEF] D<
  1179. : D<
  1180.     D- D0<
  1181. ;
  1182. [THEN]
  1183. test" d< 20. 40. d<"
  1184. test" d< 50. 40. d< 0="
  1185. test" d< -20. -10. d<"
  1186. test" d< -10. -20. d< 0="
  1187. test" d< -10. 10. d<"
  1188. test" d< 10. -10. d< 0="
  1189.  
  1190. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  1191.  
  1192. \    BLOCKS
  1193.  
  1194. [IFUNDEF] BLK
  1195. User BLK
  1196. [THEN]
  1197.  
  1198. [IFUNDEF] C/L
  1199. 32 constant C/L
  1200. [THEN]
  1201.  
  1202. [IFUNDEF] CHARS/BLOCK
  1203. 1024 constant CHARS/BLOCK
  1204. [THEN]
  1205.  
  1206. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  1207.  
  1208. \
  1209. \    TOOLS words
  1210. \
  1211.  
  1212. [IFUNDEF] .S
  1213. : .S
  1214.     ." <" depth dup 0 u.r [char] : emit 0 ?do
  1215.         depth i - 1- pick u.
  1216.     loop ." >"
  1217. ;
  1218. [THEN]
  1219.  
  1220. [IFUNDEF] ?
  1221. : ? @ . ;
  1222. [THEN]
  1223.  
  1224. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  1225.  
  1226.