home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / primutil < prev    next >
Text File  |  1996-03-21  |  29KB  |  847 lines
  1. \ load extensions
  2.  
  3. cr .( Loading the Primitive utilities...)
  4.  
  5. \   This file holds some basic utilities added first to the kernel.
  6. \   Beside the ones one should expect in a Forth system there are others:
  7. \     comment $  This can be a multiline comment without dollar $
  8. \     synonym newword oldword      \ newword will do the same as oldword
  9. \     defer@ deferredword          \ gets word to which deferredword points
  10. \     +null                        \ appends 0 to string
  11. \     z" Yes"                      \ zero-terminated string
  12. \     gotoxy getxy getcolrow col   \ screen coordinates
  13. \     cols rows                    \  "
  14. \     tab #tab ?line               \ tabs and conditional cr
  15. \     \+ \-                        \ conditional ignoring of lines
  16. \     ,"text"                      \ compile "string" into dict
  17. \     Several number display words
  18. \     trim                         \ trims chains for forget
  19. \     new-chain , chain-add , do-chain   \ chain mechanism
  20. \     Number will recognise &hex and %binary numbers
  21.  
  22. decimal                                 \ start everything in decimal
  23.  
  24. : cmdline 32788 @ zcount ;
  25.  
  26. : ascii    char          state @ if postpone literal then ; immediate
  27. : alt      char 4096  or state @ if postpone literal then ; immediate
  28. : ctrl     char   31 and state @ if postpone literal then ; immediate
  29.  
  30. : 0>=  0< 0= ;
  31. : 0<=  0> 0= ;
  32.  
  33. ' exit       constant 'exit
  34.  
  35. 0 value doClass         \ cfa for classes, initialized in CLASS.F
  36. 0 value do|Class        \ cfa for invisible classes, initialized in CLASS.F
  37.  
  38. : _comment      \ char --
  39.                 ?loading @
  40.                 if      begin   source >in @ /string
  41.                                 2 pick scan nip 0=
  42.                         while   refill 0= abort" EOF encountered in comment"
  43.                         repeat
  44.                 then    parse 2drop ;
  45.  
  46. : comment       \ -<char>-
  47.                 char _comment ; immediate
  48.  
  49. -1 value multi-line?    \ we can have multiple line '(' comments
  50.  
  51. : (             multi-line?
  52.                 IF      [char] ) _comment
  53.                 ELSE    [char] ) parse 2drop
  54.                 THEN    ; immediate
  55.  
  56. : $fload        ( a1 -- f1 )    \ a1 = counted file string
  57.                 count included ;  \ f1=false=ok, true=failed
  58.  
  59. : "fload        ( a1 n1 -- f1 ) \ a1,n1 = file string
  60.                 included ;      \ f1=false=ok, true=failed
  61.  
  62. : chars         ( n1 -- n2 )    ( 1 * ) ;
  63. : char+         ( a1 -- a1 )    1 chars + ;
  64.  
  65. : emit?         ( -- f1 )       \ return true if its ok to emit a character
  66.                 true ;
  67.  
  68. : synonym       ( -<newname> <oldname>- )
  69.                 create bl word ?uppercase find dup 0= ?missing , ,
  70.                         immediate
  71.                 does>   2@ ( cfa flag )
  72.                         state @ = if , else execute then ;
  73.  
  74. synonym stop/start start/stop
  75.  
  76. : ekey>char     ( echar -- char true )
  77.                 true ;
  78.  
  79. defer >bold             ' noop  is >bold
  80. defer >norm             ' noop  is >norm
  81. defer do-help           ' noop  is do-help
  82. defer voc-also          ' noop  is voc-also
  83. defer "message          ' 2drop is "message
  84. defer "top-message      ' 2drop is "top-message
  85. defer message-off       ' noop is message-off
  86.  
  87. : defer@        ( -<name>- )    \ function currently in defered word name
  88.                 ' >IS
  89.                 state @
  90.                 if      postpone literal postpone @
  91.                 else    @
  92.                 then    ; immediate
  93.  
  94. : _\n->crlf     ( a1 n1 -- )    \ parse "\n" occurances, change to CRLF's
  95.                 begin   ascii \ scan dup                \ found a '\' char
  96.                 while   over 1+ c@ ascii n =            \ followed by 'n'
  97.                         if      over 13 swap c!         \ replace with CR
  98.                                 over 10 swap 1+ c!      \ replace with LF
  99.                         then    1 /string               \ else skip '\' char
  100.                 repeat  2drop   ;
  101.  
  102. ' _\n->crlf is \n->crlf                 \ link into kernel defered word
  103.  
  104. : -null,        ( -- )
  105.                 5 0                     \ remove previous nulls
  106.                 do      here 1- c@ ?leave
  107.                         -1 dp +!
  108.                 loop    ;
  109.  
  110. : +NULL         ( a1 -- )       \ append a NULL just beyond the counted chars
  111.                 count + 0 swap c! ;
  112.  
  113. : (z")          ( -- )
  114.                 ((")) 1+ ;
  115.  
  116. : z"            ( -<text">- )
  117.                 ?comp compile (z") ," ; immediate
  118.  
  119. : z",           ( a1 n1 -- )
  120.                 here over 2dup 2>r allot swap move
  121.                 2r> \n->crlf
  122.                 0 c, align ;            \ terminate with a NULL
  123.  
  124. : z,"           ( -<text">- ) \ compile text optionally containing "newline"
  125.                 ascii " parse z", ;
  126.  
  127. : +z,"          ( -<text">- )
  128.                 -null, z," ;
  129.  
  130. : +z",          ( a1 n1 -- )
  131.                 -null, z", ;
  132.  
  133. synonym " s"
  134.  
  135. : not           0= ;
  136.  
  137. : d0=           or 0= ;
  138.  
  139. : >=            < 0= ;
  140.  
  141. : <=            > 0= ;
  142.  
  143. : get-commandline ( -- )        \ initialize TIB from the commandline
  144.                 0 to source-id
  145.                 cmdline (source) 2!
  146.                 >in off ;
  147.  
  148. : cfa-func      ( -<name>- )
  149.                 create hide !csp dodoes call, ] ;
  150.  
  151. defer enter-assembler   ' noop is enter-assembler
  152. defer exit-assembler    ' noop is exit-assembler
  153.  
  154. : cfa-code      ( -<name>- )
  155.                 create enter-assembler ;
  156.  
  157. : cfa-comp,     ( cfa -- )      \ compile or execute a CFA
  158.                 state @ if , else execute then ;
  159.  
  160. : _COL          ( n -- )
  161.                 _getcolrow drop 1- min _getxy drop - spaces ;
  162.  
  163. \ define some defered words with their functions, and defaults
  164.  
  165. defer gotoxy            ' _gotoxy    is gotoxy
  166. defer getxy             ' _getxy     is getxy
  167. defer getcolrow         ' _getcolrow is getcolrow
  168. defer page              ' cls        is page
  169. defer col               ' _col       is col
  170.  
  171. \ Some synonyms that improve compatibility with existing F-PC code.
  172.  
  173. synonym SP>COL COL
  174. synonym AT-XY gotoxy
  175.  
  176. : cols          ( -- n1 )               \ current screen columns
  177.                 getcolrow drop ;
  178.  
  179. : rows          ( -- n1 )               \ current screen rows
  180.                 getcolrow nip ;
  181.  
  182. : ?exit ( f1 -- )
  183.         postpone if postpone exit postpone then ; immediate
  184.  
  185. : HIWORD        ( n1 -- n2 )
  186.                 word-split nip ;
  187.  
  188. : LOWORD        ( n1 -- n2 )
  189.                 word-split drop ;
  190.  
  191. : "HOLD         ( adr len -- )
  192.                 dup negate hld +! hld @ swap move ;
  193.  
  194. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  195. \       Words that position on the screen
  196. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  197.  
  198.  4 value tab-size
  199.  4 value left-margin
  200.  2 value right-margin
  201.  0 value tab-margin
  202.  5 value tabs-max
  203.  0 value tabing?        \ are we tabing, default to no
  204.  0 value first-line?    \ is this the first line of a paragraph
  205. -8 value indent         \ inden/outdent spaces
  206.  
  207. : wrap?         ( n1 -- f1 )    \ return true if column n1 crosses into the
  208.                                 \ right margin area
  209.                 getcolrow drop right-margin - > ;
  210.  
  211.  
  212. : tab-wrap?     ( n1 -- f1 )    \ return true if column exceeds the maximum
  213.                                 \ desired tabs, or crosses into the right
  214.                                 \ margin area
  215.                 dup tabs-max tab-size * >
  216.                 swap wrap? or ;
  217.  
  218. : TAB           ( -- )
  219.                 getxy drop tab-size / 1+ tab-size * col ;
  220.  
  221. : #TAB          ( n1 -- )
  222.                 getxy drop over / 1+ * col ;
  223.  
  224. : 0TAB          ( -- )          \ left margin goes to left edge of screen
  225.                 0 to tab-margin ;
  226.  
  227. : +TAB          ( --- )
  228.                 tab-size +to tab-margin
  229.                 tab-margin tab-wrap?
  230.                 IF      0tab
  231.                 THEN    ;
  232.  
  233. : -TAB          ( --- )
  234.                 tab-margin tab-size - 0 MAX DUP to tab-margin
  235.                 tab-size <
  236.                 IF      tabs-max tab-size * to tab-margin
  237.                 THEN    ;
  238.  
  239. : FIRST-LINE    ( -- )          \ set first line flag
  240.                 true to first-line?
  241.                 0tab ;
  242.  
  243. : TABING-ON     ( -- )
  244.                 true to tabing? ;
  245.  
  246. : TABING-OFF    ( -- )
  247.                 false to tabing? ;
  248.  
  249. synonym tabbing-off tabing-off
  250. synonym tabbing-on  tabing-on
  251.  
  252. : CRTAB         ( -- )
  253.                 _cr
  254.                 tabing? 0= ?exit
  255.                 first-line?
  256.                 if      left-margin indent + spaces
  257.                         false to first-line?
  258.                 else    left-margin spaces
  259.                         tab-margin spaces
  260.                 then    ;
  261.  
  262. : ?LINE         ( n1 -- )
  263.                 0 max getxy drop + wrap?
  264.                 if      cr
  265.                 then    ;
  266.  
  267. warning off
  268.  
  269. : allot         ( n1 -- )               \ redefine ALLOT with a memory full check
  270.                 dup 1000 + ?memchk allot ;
  271.  
  272. warning on
  273.  
  274. 260           constant MAX-PATH         \ maximum lengto of a filename buffer
  275.  
  276. create &prognam max-path allot          \ define the buffer that holds the program name
  277.        &prognam off
  278.  
  279. : "to-pathend"  ( a1 n1 --- a2 n2 )     \ return a2 and count=n1 of filename
  280.                 over c@ [char] : =
  281.                 if      3 /string
  282.                 then
  283.                 begin   2dup [char] . scan ?dup
  284.                 while   2swap 2drop 1 /string
  285.                 repeat  drop ;
  286.  
  287. synonym "file-only" "to-pathend"
  288.  
  289. : "path-only"   ( a1 n1 -- a2 n2 )
  290.                 2dup "to-pathend" nip - 2dup + 1- c@ [char] . =
  291.                 if      1- 0max
  292.                 then    ;
  293.  
  294. : ?-.           ( a1 -- )       \ delete trailing '.' if present
  295.                 dup count ?dup
  296.                 if + 1- c@ [char] . =   \ end in '.'?
  297.                   if      -1 swap c+!   \ if not, append .
  298.                   else    drop          \ else discard a1
  299.                   then
  300.                 else 2drop then   ;
  301.  
  302. : ?+.           ( a1 -- )       \ append a '.' if not already present
  303.                 dup count ?dup
  304.                 if + 1- c@ [char] . <>   \ end in '.'?
  305.                   if      s" ." rot +place        \ if not, append .
  306.                   else    drop                    \ else discard a1
  307.                   then
  308.                 else 2drop then    ;
  309.  
  310. : ?+,           ( a1 -- )       \ append a ',' if not already present
  311.                 dup count ?dup
  312.                 if + 1- c@ [char] , <>   \ end in ','?
  313.                   if      s" ," rot +place        \ if not, append ,
  314.                   else    drop                    \ else discard a1
  315.                   then
  316.                 else 2drop then   ;
  317.  
  318. : ?+:           ( a1 -- )       \ append a [char] : if not already present
  319.                 dup count + 1- c@ [char] : <>   \ end in ':'?
  320.                 if      s" :" rot +place        \ if not, append ;
  321.                 else    drop                    \ else discard a1
  322.                 then    ;
  323.  
  324. \ A word to look through all vocabularies for a matching word to string a1
  325.  
  326. 0 value ?name-max
  327. 0 value ?name-val
  328.  
  329. : ?name         ( a1 -- cfa )   \ return cfa of nearest definition below a1
  330.     to ?name-val
  331.     0 to ?name-max
  332.     voc-link
  333.     begin   @ ?dup
  334.     while   dup vlink>voc
  335.       dup voc#threads 0
  336.       do      dup i cells+
  337.         begin   @ ?dup
  338.         while   dup ?name-val <
  339.           if      dup l>name name>
  340.             ?name-max max to ?name-max
  341.           then
  342.         repeat
  343.       loop    drop
  344.     repeat  ?name-max ;
  345.  
  346. : EXEC:         ( n1 -- )       \ execute the n1 item following
  347.                 CELLS R> + @ EXECUTE ;
  348.  
  349. : 3DUP          ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
  350.                 >r 2dup r@ -rot r> ;
  351.  
  352. : 4DUP          ( a b c d -- a b c d a b c d )
  353. \ Duplicate top 4 single numbers (or two double numbers) on the stack.
  354.                 2OVER 2OVER   ;
  355.  
  356. : D<            ( d1 d2 -- f )
  357. \ Signed compare two double numbers.  If d1 < d2, return TRUE.
  358.                 2 PICK OVER =
  359.                 IF      DU<
  360.                 ELSE  NIP ROT DROP <  THEN  ;
  361.  
  362. : D>            ( d1 d2 -- f )
  363. \ Signed compare two double numbers.  If d1 > d2 , return TRUE.
  364.                 2SWAP D<   ;
  365.  
  366. : D0<           ( d1 -- f1 )
  367.                 0. D< ;
  368.  
  369. : DMIN          ( d1 d2 -- d3 )
  370. \  Replace the top two double numbers with the smaller of the two (signed).
  371.                 4DUP D> IF  2SWAP  THEN 2DROP ;
  372.  
  373. : DMAX          ( d1 d2 -- d3 )
  374. \  Replace the top two double numbers with the larger of the two (signed).
  375.                 4DUP D< IF  2SWAP  THEN  2DROP ;        \ 05/25/90 tjz
  376.  
  377. : ROLL          ( n1 n2 .. nk k -- n2 n3 .. nk n1 )
  378. \  Rotate k values on the stack, bringing the deepest to the top.
  379.                 >R R@ PICK SP@ DUP cell + R> 1+ cell * MOVE DROP  ;
  380.  
  381. : 3DROP         ( n1 n2 n3 -- )
  382.                 drop 2drop ;
  383.  
  384. : 4DROP         ( n1 n2 n3 n4 -- )
  385.                 2drop 2drop ;
  386.  
  387. : D>S           ( d1 -- n1 )
  388.                 drop ;
  389.  
  390. : CS-PICK       ( dest .. u -- dest )   \ pick both addr and ?pairs value
  391.                 2 * 1+ dup>r pick r> pick ;
  392.  
  393. : CS-ROLL       ( dest -- u -- .. dest ) \ roll both addr and ?pairs value
  394.                 2 * 1+ dup>r roll r> roll ;
  395.  
  396. 0 value olddepth
  397.  
  398. : nostack1      ( -- )
  399.                 depth to olddepth ;
  400.  
  401. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  402. \ MSTARSL.F     ANSI extended precision math by Robert Smith
  403. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  404.  
  405. : TNEGATE   ( t1lo t1mid t1hi -- t2lo t2mid t2hi )
  406.         invert >r
  407.         invert >r
  408.         invert 0 -1. d+ s>d r> 0 d+
  409.         r> + ;
  410.  
  411. : UT*   ( ulo uhi u -- utlo utmid uthi )
  412.         swap >r dup>r
  413.         um* 0 r> r> um* d+ ;
  414.  
  415. : MT*   ( lo hi n -- tlo tmid thi )
  416.         dup 0<
  417.         IF      abs over 0<
  418.                 IF      >r dabs r> ut*
  419.                 ELSE    ut* tnegate
  420.                 THEN
  421.         ELSE    over 0<
  422.                 IF      >r dabs r> ut* tnegate
  423.                 ELSE    ut*
  424.                 THEN
  425.         THEN ;
  426.  
  427. : UT/   ( utlo utmid uthi n -- d1 )
  428.         dup>r um/mod -rot r> um/mod
  429.         nip swap ;
  430.  
  431. : M*/  ( d1 n1 +n2 -- d2 )
  432.         >r mt* dup 0<
  433.         IF      tnegate r> ut/ dnegate
  434.         ELSE    r> ut/
  435.         THEN ;
  436.  
  437. : M+    ( d1 n -- d2 )
  438.         s>d d+ ;
  439.  
  440. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  441. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  442.  
  443. : FIELD+        ( n1 n2 -<name>- n1+n2 )        \ definer for fields
  444.                 create  over , +
  445.                 does>   @ + ;
  446.  
  447. : \-            ( -<word>- )            \ load line if word IS NOT defined
  448.                 defined nip
  449.                 if      [compile] \
  450.                 then    ; immediate
  451.  
  452. : \+            ( -<word>- )            \ load line if word IS defined
  453.                 defined nip 0=
  454.                 if      [compile] \
  455.                 then    ; immediate
  456.  
  457. : RESERVE       ( n1 -- )               \ allot some bytes initialized to NULL
  458.                 here over erase allot ;
  459.  
  460. : C+PLACE       ( c1 a1 -- )    \ append char c1 to the counted string at a1
  461.                 >r sp@ 1 r> +place drop ;
  462.  
  463. \ ,"TEXT" also detect \T embeded in the text and replaces it with a TAB char
  464.  
  465. : ,"TEXT"       ( -<"text">- )  \ parse out quote delimited text and compile
  466.                                 \ it at here  NO EXTRA SPACES ARE NEEDED !!!
  467.                 source >in @ /string
  468.                 [char] " scan 1 /string                 \ skip past first quote
  469.                 2dup [char] " scan                      \ upto next quote
  470.                 2dup 2>r nip -                          \ parse out the string
  471.                 255 min dup>r
  472.                 2dup [char] \ scan 2dup 2>r nip -       \ leading part of string
  473.                 here place                              \ save in BNAME
  474.                 2r> dup
  475.                 if      over 1+ c@ upc [char] T =
  476.                         if      9         here c+place
  477.                                 2 /string here  +place
  478.                                 r> 1- >r
  479.                         else    here +place
  480.                         then
  481.                 else    2drop
  482.                 then
  483.                 r> 1+ allot
  484.                 0 c, align                           \ null terminate name
  485.                 source nip 2r> 1 /string nip - >in !    \ adjust >IN
  486.                 ;
  487.  
  488. : CONVERT       ( ud1 a1 -- ud2 a2 )
  489.                 1+ 64 >number drop ;
  490.  
  491. VARIABLE SPAN
  492.  
  493. : EXPECT        ( a1 n1 -- )            \ accept the text
  494.                 accept span ! ;
  495.  
  496. : UNUSED        ( -- n1 )               \ return unused HERE in BYTES
  497.                 sp@ here - ;
  498.  
  499. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  500. \      2Value words
  501. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  502.  
  503. : 2+!           ( d1 a1 -- )            \ double accumulate
  504.                 dup>r 2@ d+ r> 2! ;
  505.  
  506. \ cfa-func do2value              @ 2@  ;    \ in the kernel
  507.   cfa-func do2value!   2 cells - @ 2!  ;
  508.   cfa-func do2value+!  3 cells - @ 2+! ;
  509.  
  510. : 2value        ( d1 -<name>- )
  511.                 header  do2value call, here 3 cells+ , do2value! call, do2value+! call, , , ;
  512.  
  513. synonym 2to   to
  514. synonym 2+to +to
  515.  
  516. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  517. \      Command line argument words
  518. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  519.  
  520. 0 0 2value arg"
  521. 0 0 2value arg-pos"
  522.  
  523.  
  524. : "arg-next"    ( a1 n1 -- a2 n2 )
  525.                 bl skip 2dup bl scan nip -
  526.                 2dup bl scan 2dup 2>r nip - 2dup 2to arg"
  527.                 2r> 2to arg-pos" ;
  528.  
  529. : arg-1"        ( -- a1 n1 )
  530.                 cmdline upper
  531.                 cmdline "arg-next" ;
  532.  
  533. : arg-next"     ( -- a1 n1 )
  534.                 arg-pos" "arg-next" ;
  535.  
  536. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  537. \       various number display words
  538. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  539.  
  540. : (.)           ( n1 -- a1 n1 ) \ convert number n1 to an ascii string
  541.                 0 (d.) ;
  542.  
  543. : h.r           ( n1 n2 -- )    \ display n1 as a hex number right
  544.                                 \ justified in a field of n2 characters
  545.                 base @ >r hex >r
  546.                 0 <# #s #> r> over - spaces type
  547.                 r> base ! ;
  548.  
  549. : h.n           ( n1 n2 -- )    \ display n1 a s a hex number of n2 digits
  550.                 base @ >r hex >r
  551.                 0 <# r> 0 ?do # loop #> type
  552.                 r> base ! ;
  553.  
  554. : h.2           ( n1 -- ) 2 h.n ;       \ two digit HEX number
  555. : h.4           ( n1 -- ) 4 h.n ;       \ four digit HEX number
  556. : h.8           ( n1 -- ) 8 h.n ;       \ eight digit HEX number
  557.  
  558. : .name         ( cfa -- )
  559.                 dup>r >name 32768 max         \ don't let it wrap below 0
  560.                 true over nfa-count dup ?line
  561.                 bounds
  562.                 do      i c@ 32 <             \ validate the name chars
  563.                         i c@ 127 > or
  564.                         if      0= leave
  565.                         then
  566.                 loop
  567.                 if      .id
  568.                 else    drop r@ 1 h.r ." h "
  569.                 then    r>drop ;
  570.  
  571. : ?.name        ( cfa -- )      \ try to display the name at CFA
  572.                 dup ?name ?dup
  573.                 if      .name
  574.                 else    ." ???: " dup 1 h.r ." h "
  575.                 then    drop ;
  576.  
  577. \ BINARY double number display with commas
  578.  
  579. : (BUD,.)       ( ud -- a1 n1 )
  580.                 base @ >r binary
  581.                 <#              \ every 4 digits from right
  582.                 4 0 DO # 2DUP D0= ?LEAVE LOOP
  583.                 begin   2DUP D0= 0=     \ while not a double zero
  584.                 while   [char] , HOLD
  585.                         4 0 DO # 2DUP D0= ?LEAVE LOOP
  586.                 repeat  #>
  587.                 r> base ! ;
  588.  
  589.  
  590. : BUD,.R        ( ud l -- )             \ right justified, with ','
  591.                 >R (BUD,.) R> OVER - SPACES TYPE ;
  592.  
  593. : BU,.R         ( n1 n2 -- )
  594.                 0 SWAP BUD,.R ;
  595.  
  596. : b.            ( n1 -- ) 1 bu,.r ;
  597.  
  598.  
  599. \ double number display with commas
  600.  
  601. : (UD,.)        ( ud1 -- a1 n1 )
  602.                 <#              \ every 3 digits from right
  603.                 3 0 DO # 2DUP D0= ?LEAVE LOOP
  604.                 2DUP D0= 0=
  605.                 IF      [char] , HOLD
  606.                         3 0 DO # 2DUP D0= ?LEAVE LOOP
  607.                 THEN
  608.                 2DUP D0= 0=
  609.                 IF      [char] , HOLD
  610.                         3 0 DO # 2DUP D0= ?LEAVE LOOP
  611.                 THEN    #> ;
  612.  
  613. : UD,.R         ( ud l -- )             \ right justified, with ','
  614.                 >R (UD,.) R> OVER - SPACES TYPE ;
  615.  
  616. : U,.R          ( n1 n2 -- )
  617.                 0 SWAP UD,.R ;
  618.  
  619. : (D.#)         ( d1 n1 -- a1 n1 ) \ display d1 with n1 places behind DP
  620.                 >R <#              \ n1=negative will display'.' but no digits
  621.                 R> ?DUP            \ if not zero, then display places
  622.                 IF      0 MAX 0 ?DO # LOOP [char] . HOLD
  623.                 THEN    #S #> ;
  624.  
  625. : D.R.#         ( d1 n1 n2 -- ) \ print d1 in a field of n1 characters,
  626.                                 \ display with n2 places behind DP
  627.                 SWAP >R (D.#) R> OVER - SPACES TYPE ;
  628.  
  629. : .R.1          ( n1 n2 -- )     \ print n1 right justified in field of n2
  630.                 0 SWAP 1 D.R.# ; \ display with one place behind DP
  631.  
  632. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  633. \       TRIM (forget) primitives
  634. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  635.  
  636. : (trim)        ( addr1 addr2 -- addr1 addr3 )
  637.                 begin @ 2dup u> until ;
  638.  
  639. : trim          ( addr voc -- )
  640.                 tuck (trim) nip swap ! ;
  641.  
  642. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  643. \       Execution chain words
  644. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  645.  
  646. variable chain-link             \ linked list of chains
  647.          chain-link off
  648.  
  649. : trim-chain    ( a1 chain^ --- )       \ SMuB  End trim
  650.                 begin 2dup @ 1- u>      \ The 1- makes 0 the biggest value
  651.                 while @
  652.                 repeat
  653.                 off drop ;
  654.  
  655. : trim-chains   ( a1 -- a1 )            \ trim down the chain linked list
  656.                 chain-link
  657.                 begin   @ ?dup
  658.                 while   2dup 2 cells - trim-chain
  659.                 repeat  dup chain-link trim ;
  660.  
  661. : new-chain     ( -- )
  662.                 create 0 , ['] noop , chain-link link, ;
  663.  
  664. : .chain        ( chain -- )
  665.                 dup @ 0=
  666.                 if      drop ." Empty"
  667.                 else    begin   @ ?dup
  668.                         while   dup cell+ @ >name .id 12 ?cr
  669.                                 start/stop
  670.                         repeat
  671.                 then    ;
  672.  
  673. : .chains       ( -- )          \ display the contents of all chains
  674.                 chain-link
  675.                 begin   @ ?dup
  676.                 while   dup 2 cells -
  677.                         dup cr body> >name .id 24 col ."  --> " .chain
  678.                 repeat  ;
  679.  
  680. : do-chain      ( chain_address -- )
  681.                 begin   @ ?dup
  682.                 while   dup>r           \ make sure stack is clean during
  683.                         cell+ @
  684.                         execute \ execution of the chained functions
  685.                         r>              \ so parameters can be passed through
  686.                 repeat  ;               \ the chain if items being performed
  687.  
  688. : noop-chain-add ( chain_address -- addr )      \ add chain item, return addr of cfa added
  689.                 begin   dup @
  690.                 while   @
  691.                 repeat  here swap ! 0 , here ['] noop , ;
  692.  
  693. : chain-add     ( chain_address -<word_to_add>- )       \ for normal forward chains
  694.                 begin   dup @
  695.                 while   @
  696.                 repeat  here swap ! 0 , ' , ;
  697.  
  698. : chain-add-before ( chain_address -<word_to_add>- )    \ for reverse chains like BYE
  699.                 here over @ , ' , swap ! ;
  700.  
  701. \ define some of the chains we need
  702.  
  703. new-chain initialization-chain  \ chain of things to initialize
  704. new-chain            bye-chain  \ chain of things to de-initialize
  705. new-chain         forget-chain  \ chain of types of things to forget
  706. new-chain          mouse-chain  \ chain of things to do on mouse down
  707. new-chain      semicolon-chain  \ chain of things to do at end of definition
  708. new-chain       forth-io-chain  \ chain of things to to to restore forth-io
  709. new-chain        number?-chain  \ chain of number conversion options
  710.  
  711. : n;            ( -- )
  712.                 ?comp  ?csp  reveal  compile unnest
  713.                 [compile] [
  714.                 semicolon-chain do-chain ; immediate
  715.  
  716. ' n; is ;       \ new version of semicolon that knows about chains
  717.  
  718.  
  719. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  720. \ A super version of number that detect the 0x00 'C' style of hex numbers
  721. \ as well as ascii characters in the 'A' format.
  722. \ A HEX number ending in 'L' automatically has the 'L' removed.  This is
  723. \ done so Forth can accept 0x1234L format numbers as they are encountered
  724. \ in 'C' header files.
  725. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  726.  
  727. : new-number?   ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE )
  728.                 dup ?exit drop
  729.                 2dup _number?
  730.                 if      2swap 2drop TRUE
  731.                 else    2drop FALSE
  732.                 then    ;
  733.  
  734. number?-chain chain-add new-number?             \ first item in NUMBER? chain
  735.  
  736. : 0xNUMBER?     ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE )
  737.                 dup ?exit drop                  \ leave if already converted
  738.                 over c@ ascii ' =
  739.                 if      false to double?        \ initially not a double #
  740.                         3 =
  741.                         over 2 + c@ ascii ' = and
  742.                         swap 1+ c@ 0 rot
  743.                 else    base @ >r
  744.                         over 2 S" 0X" compare 0=        \ if start with 0x
  745.                         if      hex  2 /string          \ set hex, remove 0x
  746.                                 2dup + 1- c@ ascii L =  \ if have 'L'
  747.                                 if      1- 0 max        \ remove it
  748.                                 then
  749.                         then
  750.                         FALSE new-number?
  751.                         r> base !
  752.                 then    ;
  753.  
  754. number?-chain chain-add 0xNUMBER?
  755.  
  756. : &number?      ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE )
  757.     dup ?exit drop
  758.     over c@ dup ascii & = swap ascii % = over or
  759.     if false to double?
  760.       base @ >r
  761.       if hex else binary then
  762.       1 /string false new-number?
  763.       r> base !
  764.     then ;
  765.  
  766. number?-chain chain-add &NUMBER?
  767.  
  768. : new-number    ( ^str -- d )           \ an extensible version of NUMBER
  769.                 count FALSE number?-chain do-chain 0= ?missing ;
  770.  
  771. ' new-number is number                  \ replace normal number conversion
  772.                                         \ with the new chain scheme
  773.  
  774.  
  775. defer pushkey   ' drop is pushkey
  776. defer "pushkeys ' 2drop is "pushkeys
  777.  
  778. 0 value tot-malloc
  779. 0 value heapptr
  780. 0 value heapsize
  781.  
  782. : heapon   ( -- ) 16384
  783.     0 to tot-malloc
  784.     heapsize abort" You already have a heap."
  785.     -1 swap memory-total &8000 - dup>r + Wimp_SlotSize
  786.     dup r> dup &8000 + to heapptr - to heapsize
  787.     &8000 + 32772 ! 2drop
  788.     heapsize 0 heapptr 0 OS_Heap drop 2drop ;
  789.  
  790. initialization-chain chain-add heapon
  791.  
  792. : heapoff ( -- )
  793.     tot-malloc abort" Heap still used"
  794.     -1 memory-total dup>r heapsize -
  795.     Wimp_SlotSize dup r> - 0max to heapsize
  796.     32772 ! 2drop ;
  797.  
  798. : allocate ( n -- ad ior )
  799.     dup 0< abort" Allocation Error!"
  800.     aligned 0 heapptr 2 OS_Heap
  801.     if 2drop here true
  802.     else swap cell+ dup 4 and + +to tot-malloc false then ;
  803.  
  804. : malloc        ( n1 -- a1 )
  805.     aligned 0 heapptr 2 OS_Heap
  806.     abort" Failed to allocate memory"
  807.     swap +to tot-malloc ;
  808.  
  809. : free ( ad -- ior )
  810.     0 swap heapptr 6 OS_Heap drop
  811.     0 swap heapptr 3 OS_Heap nip nip
  812.     tuck 0= if negate +to tot-malloc else drop then ;
  813.  
  814. : release       ( a1 -- )
  815.     free drop ;
  816.  
  817. : resize        ( a1 n1 -- a2 f1 )      \ ansi version of realloc
  818.     0 rot heapptr 6 OS_Heap 2drop cell- - dup +to tot-malloc swap
  819.     heapptr 4 OS_Heap rot drop ;          \ -- f1 = true on error
  820.  
  821. : realloc       ( size pointer_to_malloc_mem -- pointer_to_new_mem  flag )
  822.     swap resize ;
  823.  
  824. : _forth-io     ( -- )                  \ reset to Forth IO words
  825.                 ['] _emit      is emit
  826.                 ['] _type      is type
  827.                 ['] crtab       is cr
  828.                 ['] _?cr        is ?cr
  829.                 ['] _key       is key
  830.                 ['] _key?      is key?
  831.                 ['] _cls        is cls
  832.                 [']  cls        is page
  833.                 ['] _gotoxy     is gotoxy
  834.                 ['] _getxy      is getxy
  835.                 ['] _getcolrow  is getcolrow
  836.                 ['] _col        is col ;
  837.  
  838. forth-io-chain chain-add _forth-io
  839.  
  840. : forth-io      ( -- )
  841.                 forth-io-chain do-chain ;
  842.  
  843. forth-io        \ set the default I/O words
  844.  
  845. .( ...done )
  846.  
  847.