ARM Club 3

home *** CD-ROM | disk | FTP | other *** search

/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / wimpforth_2 / !WimpForth / primutil < prev next >

Wrap

Text File | 1996-03-21 | 28.2 KB | 847 lines

\ load extensions cr .( Loading the Primitive utilities...) \ This file holds some basic utilities added first to the kernel. \ Beside the ones one should expect in a Forth system there are others: \ comment $ This can be a multiline comment without dollar $ \ synonym newword oldword \ newword will do the same as oldword \ defer@ deferredword \ gets word to which deferredword points \ +null \ appends 0 to string \ z" Yes" \ zero-terminated string \ gotoxy getxy getcolrow col \ screen coordinates \ cols rows \ " \ tab #tab ?line \ tabs and conditional cr \ \+ \- \ conditional ignoring of lines \ ,"text" \ compile "string" into dict \ Several number display words \ trim \ trims chains for forget \ new-chain , chain-add , do-chain \ chain mechanism \ Number will recognise &hex and %binary numbers decimal \ start everything in decimal : cmdline 32788 @ zcount ; : ascii char state @ if postpone literal then ; immediate : alt char 4096 or state @ if postpone literal then ; immediate : ctrl char 31 and state @ if postpone literal then ; immediate : 0>= 0< 0= ; : 0<= 0> 0= ; ' exit constant 'exit 0 value doClass \ cfa for classes, initialized in CLASS.F 0 value do|Class \ cfa for invisible classes, initialized in CLASS.F : _comment \ char -- ?loading @ if begin source >in @ /string 2 pick scan nip 0= while refill 0= abort" EOF encountered in comment" repeat then parse 2drop ; : comment \ -<char>- char _comment ; immediate -1 value multi-line? \ we can have multiple line '(' comments : ( multi-line? IF [char] ) _comment ELSE [char] ) parse 2drop THEN ; immediate : $fload ( a1 -- f1 ) \ a1 = counted file string count included ; \ f1=false=ok, true=failed : "fload ( a1 n1 -- f1 ) \ a1,n1 = file string included ; \ f1=false=ok, true=failed : chars ( n1 -- n2 ) ( 1 * ) ; : char+ ( a1 -- a1 ) 1 chars + ; : emit? ( -- f1 ) \ return true if its ok to emit a character true ; : synonym ( -<newname> <oldname>- ) create bl word ?uppercase find dup 0= ?missing , , immediate does> 2@ ( cfa flag ) state @ = if , else execute then ; synonym stop/start start/stop : ekey>char ( echar -- char true ) true ; defer >bold ' noop is >bold defer >norm ' noop is >norm defer do-help ' noop is do-help defer voc-also ' noop is voc-also defer "message ' 2drop is "message defer "top-message ' 2drop is "top-message defer message-off ' noop is message-off : defer@ ( -<name>- ) \ function currently in defered word name ' >IS state @ if postpone literal postpone @ else @ then ; immediate : _\n->crlf ( a1 n1 -- ) \ parse "\n" occurances, change to CRLF's begin ascii \ scan dup \ found a '\' char while over 1+ c@ ascii n = \ followed by 'n' if over 13 swap c! \ replace with CR over 10 swap 1+ c! \ replace with LF then 1 /string \ else skip '\' char repeat 2drop ; ' _\n->crlf is \n->crlf \ link into kernel defered word : -null, ( -- ) 5 0 \ remove previous nulls do here 1- c@ ?leave -1 dp +! loop ; : +NULL ( a1 -- ) \ append a NULL just beyond the counted chars count + 0 swap c! ; : (z") ( -- ) ((")) 1+ ; : z" ( -<text">- ) ?comp compile (z") ," ; immediate : z", ( a1 n1 -- ) here over 2dup 2>r allot swap move 2r> \n->crlf 0 c, align ; \ terminate with a NULL : z," ( -<text">- ) \ compile text optionally containing "newline" ascii " parse z", ; : +z," ( -<text">- ) -null, z," ; : +z", ( a1 n1 -- ) -null, z", ; synonym " s" : not 0= ; : d0= or 0= ; : >= < 0= ; : <= > 0= ; : get-commandline ( -- ) \ initialize TIB from the commandline 0 to source-id cmdline (source) 2! >in off ; : cfa-func ( -<name>- ) create hide !csp dodoes call, ] ; defer enter-assembler ' noop is enter-assembler defer exit-assembler ' noop is exit-assembler : cfa-code ( -<name>- ) create enter-assembler ; : cfa-comp, ( cfa -- ) \ compile or execute a CFA state @ if , else execute then ; : _COL ( n -- ) _getcolrow drop 1- min _getxy drop - spaces ; \ define some defered words with their functions, and defaults defer gotoxy ' _gotoxy is gotoxy defer getxy ' _getxy is getxy defer getcolrow ' _getcolrow is getcolrow defer page ' cls is page defer col ' _col is col \ Some synonyms that improve compatibility with existing F-PC code. synonym SP>COL COL synonym AT-XY gotoxy : cols ( -- n1 ) \ current screen columns getcolrow drop ; : rows ( -- n1 ) \ current screen rows getcolrow nip ; : ?exit ( f1 -- ) postpone if postpone exit postpone then ; immediate : HIWORD ( n1 -- n2 ) word-split nip ; : LOWORD ( n1 -- n2 ) word-split drop ; : "HOLD ( adr len -- ) dup negate hld +! hld @ swap move ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Words that position on the screen \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 4 value tab-size 4 value left-margin 2 value right-margin 0 value tab-margin 5 value tabs-max 0 value tabing? \ are we tabing, default to no 0 value first-line? \ is this the first line of a paragraph -8 value indent \ inden/outdent spaces : wrap? ( n1 -- f1 ) \ return true if column n1 crosses into the \ right margin area getcolrow drop right-margin - > ; : tab-wrap? ( n1 -- f1 ) \ return true if column exceeds the maximum \ desired tabs, or crosses into the right \ margin area dup tabs-max tab-size * > swap wrap? or ; : TAB ( -- ) getxy drop tab-size / 1+ tab-size * col ; : #TAB ( n1 -- ) getxy drop over / 1+ * col ; : 0TAB ( -- ) \ left margin goes to left edge of screen 0 to tab-margin ; : +TAB ( --- ) tab-size +to tab-margin tab-margin tab-wrap? IF 0tab THEN ; : -TAB ( --- ) tab-margin tab-size - 0 MAX DUP to tab-margin tab-size < IF tabs-max tab-size * to tab-margin THEN ; : FIRST-LINE ( -- ) \ set first line flag true to first-line? 0tab ; : TABING-ON ( -- ) true to tabing? ; : TABING-OFF ( -- ) false to tabing? ; synonym tabbing-off tabing-off synonym tabbing-on tabing-on : CRTAB ( -- ) _cr tabing? 0= ?exit first-line? if left-margin indent + spaces false to first-line? else left-margin spaces tab-margin spaces then ; : ?LINE ( n1 -- ) 0 max getxy drop + wrap? if cr then ; warning off : allot ( n1 -- ) \ redefine ALLOT with a memory full check dup 1000 + ?memchk allot ; warning on 260 constant MAX-PATH \ maximum lengto of a filename buffer create &prognam max-path allot \ define the buffer that holds the program name &prognam off : "to-pathend" ( a1 n1 --- a2 n2 ) \ return a2 and count=n1 of filename over c@ [char] : = if 3 /string then begin 2dup [char] . scan ?dup while 2swap 2drop 1 /string repeat drop ; synonym "file-only" "to-pathend" : "path-only" ( a1 n1 -- a2 n2 ) 2dup "to-pathend" nip - 2dup + 1- c@ [char] . = if 1- 0max then ; : ?-. ( a1 -- ) \ delete trailing '.' if present dup count ?dup if + 1- c@ [char] . = \ end in '.'? if -1 swap c+! \ if not, append . else drop \ else discard a1 then else 2drop then ; : ?+. ( a1 -- ) \ append a '.' if not already present dup count ?dup if + 1- c@ [char] . <> \ end in '.'? if s" ." rot +place \ if not, append . else drop \ else discard a1 then else 2drop then ; : ?+, ( a1 -- ) \ append a ',' if not already present dup count ?dup if + 1- c@ [char] , <> \ end in ','? if s" ," rot +place \ if not, append , else drop \ else discard a1 then else 2drop then ; : ?+: ( a1 -- ) \ append a [char] : if not already present dup count + 1- c@ [char] : <> \ end in ':'? if s" :" rot +place \ if not, append ; else drop \ else discard a1 then ; \ A word to look through all vocabularies for a matching word to string a1 0 value ?name-max 0 value ?name-val : ?name ( a1 -- cfa ) \ return cfa of nearest definition below a1 to ?name-val 0 to ?name-max voc-link begin @ ?dup while dup vlink>voc dup voc#threads 0 do dup i cells+ begin @ ?dup while dup ?name-val < if dup l>name name> ?name-max max to ?name-max then repeat loop drop repeat ?name-max ; : EXEC: ( n1 -- ) \ execute the n1 item following CELLS R> + @ EXECUTE ; : 3DUP ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 ) >r 2dup r@ -rot r> ; : 4DUP ( a b c d -- a b c d a b c d ) \ Duplicate top 4 single numbers (or two double numbers) on the stack. 2OVER 2OVER ; : D< ( d1 d2 -- f ) \ Signed compare two double numbers. If d1 < d2, return TRUE. 2 PICK OVER = IF DU< ELSE NIP ROT DROP < THEN ; : D> ( d1 d2 -- f ) \ Signed compare two double numbers. If d1 > d2 , return TRUE. 2SWAP D< ; : D0< ( d1 -- f1 ) 0. D< ; : DMIN ( d1 d2 -- d3 ) \ Replace the top two double numbers with the smaller of the two (signed). 4DUP D> IF 2SWAP THEN 2DROP ; : DMAX ( d1 d2 -- d3 ) \ Replace the top two double numbers with the larger of the two (signed). 4DUP D< IF 2SWAP THEN 2DROP ; \ 05/25/90 tjz : ROLL ( n1 n2 .. nk k -- n2 n3 .. nk n1 ) \ Rotate k values on the stack, bringing the deepest to the top. >R R@ PICK SP@ DUP cell + R> 1+ cell * MOVE DROP ; : 3DROP ( n1 n2 n3 -- ) drop 2drop ; : 4DROP ( n1 n2 n3 n4 -- ) 2drop 2drop ; : D>S ( d1 -- n1 ) drop ; : CS-PICK ( dest .. u -- dest ) \ pick both addr and ?pairs value 2 * 1+ dup>r pick r> pick ; : CS-ROLL ( dest -- u -- .. dest ) \ roll both addr and ?pairs value 2 * 1+ dup>r roll r> roll ; 0 value olddepth : nostack1 ( -- ) depth to olddepth ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ MSTARSL.F ANSI extended precision math by Robert Smith \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : TNEGATE ( t1lo t1mid t1hi -- t2lo t2mid t2hi ) invert >r invert >r invert 0 -1. d+ s>d r> 0 d+ r> + ; : UT* ( ulo uhi u -- utlo utmid uthi ) swap >r dup>r um* 0 r> r> um* d+ ; : MT* ( lo hi n -- tlo tmid thi ) dup 0< IF abs over 0< IF >r dabs r> ut* ELSE ut* tnegate THEN ELSE over 0< IF >r dabs r> ut* tnegate ELSE ut* THEN THEN ; : UT/ ( utlo utmid uthi n -- d1 ) dup>r um/mod -rot r> um/mod nip swap ; : M*/ ( d1 n1 +n2 -- d2 ) >r mt* dup 0< IF tnegate r> ut/ dnegate ELSE r> ut/ THEN ; : M+ ( d1 n -- d2 ) s>d d+ ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : FIELD+ ( n1 n2 -<name>- n1+n2 ) \ definer for fields create over , + does> @ + ; : \- ( -<word>- ) \ load line if word IS NOT defined defined nip if [compile] \ then ; immediate : \+ ( -<word>- ) \ load line if word IS defined defined nip 0= if [compile] \ then ; immediate : RESERVE ( n1 -- ) \ allot some bytes initialized to NULL here over erase allot ; : C+PLACE ( c1 a1 -- ) \ append char c1 to the counted string at a1 >r sp@ 1 r> +place drop ; \ ,"TEXT" also detect \T embeded in the text and replaces it with a TAB char : ,"TEXT" ( -<"text">- ) \ parse out quote delimited text and compile \ it at here NO EXTRA SPACES ARE NEEDED !!! source >in @ /string [char] " scan 1 /string \ skip past first quote 2dup [char] " scan \ upto next quote 2dup 2>r nip - \ parse out the string 255 min dup>r 2dup [char] \ scan 2dup 2>r nip - \ leading part of string here place \ save in BNAME 2r> dup if over 1+ c@ upc [char] T = if 9 here c+place 2 /string here +place r> 1- >r else here +place then else 2drop then r> 1+ allot 0 c, align \ null terminate name source nip 2r> 1 /string nip - >in ! \ adjust >IN ; : CONVERT ( ud1 a1 -- ud2 a2 ) 1+ 64 >number drop ; VARIABLE SPAN : EXPECT ( a1 n1 -- ) \ accept the text accept span ! ; : UNUSED ( -- n1 ) \ return unused HERE in BYTES sp@ here - ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 2Value words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : 2+! ( d1 a1 -- ) \ double accumulate dup>r 2@ d+ r> 2! ; \ cfa-func do2value @ 2@ ; \ in the kernel cfa-func do2value! 2 cells - @ 2! ; cfa-func do2value+! 3 cells - @ 2+! ; : 2value ( d1 -<name>- ) header do2value call, here 3 cells+ , do2value! call, do2value+! call, , , ; synonym 2to to synonym 2+to +to \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Command line argument words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 0 0 2value arg" 0 0 2value arg-pos" : "arg-next" ( a1 n1 -- a2 n2 ) bl skip 2dup bl scan nip - 2dup bl scan 2dup 2>r nip - 2dup 2to arg" 2r> 2to arg-pos" ; : arg-1" ( -- a1 n1 ) cmdline upper cmdline "arg-next" ; : arg-next" ( -- a1 n1 ) arg-pos" "arg-next" ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ various number display words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : (.) ( n1 -- a1 n1 ) \ convert number n1 to an ascii string 0 (d.) ; : h.r ( n1 n2 -- ) \ display n1 as a hex number right \ justified in a field of n2 characters base @ >r hex >r 0 <# #s #> r> over - spaces type r> base ! ; : h.n ( n1 n2 -- ) \ display n1 a s a hex number of n2 digits base @ >r hex >r 0 <# r> 0 ?do # loop #> type r> base ! ; : h.2 ( n1 -- ) 2 h.n ; \ two digit HEX number : h.4 ( n1 -- ) 4 h.n ; \ four digit HEX number : h.8 ( n1 -- ) 8 h.n ; \ eight digit HEX number : .name ( cfa -- ) dup>r >name 32768 max \ don't let it wrap below 0 true over nfa-count dup ?line bounds do i c@ 32 < \ validate the name chars i c@ 127 > or if 0= leave then loop if .id else drop r@ 1 h.r ." h " then r>drop ; : ?.name ( cfa -- ) \ try to display the name at CFA dup ?name ?dup if .name else ." ???: " dup 1 h.r ." h " then drop ; \ BINARY double number display with commas : (BUD,.) ( ud -- a1 n1 ) base @ >r binary <# \ every 4 digits from right 4 0 DO # 2DUP D0= ?LEAVE LOOP begin 2DUP D0= 0= \ while not a double zero while [char] , HOLD 4 0 DO # 2DUP D0= ?LEAVE LOOP repeat #> r> base ! ; : BUD,.R ( ud l -- ) \ right justified, with ',' >R (BUD,.) R> OVER - SPACES TYPE ; : BU,.R ( n1 n2 -- ) 0 SWAP BUD,.R ; : b. ( n1 -- ) 1 bu,.r ; \ double number display with commas : (UD,.) ( ud1 -- a1 n1 ) <# \ every 3 digits from right 3 0 DO # 2DUP D0= ?LEAVE LOOP 2DUP D0= 0= IF [char] , HOLD 3 0 DO # 2DUP D0= ?LEAVE LOOP THEN 2DUP D0= 0= IF [char] , HOLD 3 0 DO # 2DUP D0= ?LEAVE LOOP THEN #> ; : UD,.R ( ud l -- ) \ right justified, with ',' >R (UD,.) R> OVER - SPACES TYPE ; : U,.R ( n1 n2 -- ) 0 SWAP UD,.R ; : (D.#) ( d1 n1 -- a1 n1 ) \ display d1 with n1 places behind DP >R <# \ n1=negative will display'.' but no digits R> ?DUP \ if not zero, then display places IF 0 MAX 0 ?DO # LOOP [char] . HOLD THEN #S #> ; : D.R.# ( d1 n1 n2 -- ) \ print d1 in a field of n1 characters, \ display with n2 places behind DP SWAP >R (D.#) R> OVER - SPACES TYPE ; : .R.1 ( n1 n2 -- ) \ print n1 right justified in field of n2 0 SWAP 1 D.R.# ; \ display with one place behind DP \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ TRIM (forget) primitives \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : (trim) ( addr1 addr2 -- addr1 addr3 ) begin @ 2dup u> until ; : trim ( addr voc -- ) tuck (trim) nip swap ! ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Execution chain words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ variable chain-link \ linked list of chains chain-link off : trim-chain ( a1 chain^ --- ) \ SMuB End trim begin 2dup @ 1- u> \ The 1- makes 0 the biggest value while @ repeat off drop ; : trim-chains ( a1 -- a1 ) \ trim down the chain linked list chain-link begin @ ?dup while 2dup 2 cells - trim-chain repeat dup chain-link trim ; : new-chain ( -- ) create 0 , ['] noop , chain-link link, ; : .chain ( chain -- ) dup @ 0= if drop ." Empty" else begin @ ?dup while dup cell+ @ >name .id 12 ?cr start/stop repeat then ; : .chains ( -- ) \ display the contents of all chains chain-link begin @ ?dup while dup 2 cells - dup cr body> >name .id 24 col ." --> " .chain repeat ; : do-chain ( chain_address -- ) begin @ ?dup while dup>r \ make sure stack is clean during cell+ @ execute \ execution of the chained functions r> \ so parameters can be passed through repeat ; \ the chain if items being performed : noop-chain-add ( chain_address -- addr ) \ add chain item, return addr of cfa added begin dup @ while @ repeat here swap ! 0 , here ['] noop , ; : chain-add ( chain_address -<word_to_add>- ) \ for normal forward chains begin dup @ while @ repeat here swap ! 0 , ' , ; : chain-add-before ( chain_address -<word_to_add>- ) \ for reverse chains like BYE here over @ , ' , swap ! ; \ define some of the chains we need new-chain initialization-chain \ chain of things to initialize new-chain bye-chain \ chain of things to de-initialize new-chain forget-chain \ chain of types of things to forget new-chain mouse-chain \ chain of things to do on mouse down new-chain semicolon-chain \ chain of things to do at end of definition new-chain forth-io-chain \ chain of things to to to restore forth-io new-chain number?-chain \ chain of number conversion options : n; ( -- ) ?comp ?csp reveal compile unnest [compile] [ semicolon-chain do-chain ; immediate ' n; is ; \ new version of semicolon that knows about chains \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ A super version of number that detect the 0x00 'C' style of hex numbers \ as well as ascii characters in the 'A' format. \ A HEX number ending in 'L' automatically has the 'L' removed. This is \ done so Forth can accept 0x1234L format numbers as they are encountered \ in 'C' header files. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : new-number? ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE ) dup ?exit drop 2dup _number? if 2swap 2drop TRUE else 2drop FALSE then ; number?-chain chain-add new-number? \ first item in NUMBER? chain : 0xNUMBER? ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE ) dup ?exit drop \ leave if already converted over c@ ascii ' = if false to double? \ initially not a double # 3 = over 2 + c@ ascii ' = and swap 1+ c@ 0 rot else base @ >r over 2 S" 0X" compare 0= \ if start with 0x if hex 2 /string \ set hex, remove 0x 2dup + 1- c@ ascii L = \ if have 'L' if 1- 0 max \ remove it then then FALSE new-number? r> base ! then ; number?-chain chain-add 0xNUMBER? : &number? ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE ) dup ?exit drop over c@ dup ascii & = swap ascii % = over or if false to double? base @ >r if hex else binary then 1 /string false new-number? r> base ! then ; number?-chain chain-add &NUMBER? : new-number ( ^str -- d ) \ an extensible version of NUMBER count FALSE number?-chain do-chain 0= ?missing ; ' new-number is number \ replace normal number conversion \ with the new chain scheme defer pushkey ' drop is pushkey defer "pushkeys ' 2drop is "pushkeys 0 value tot-malloc 0 value heapptr 0 value heapsize : heapon ( -- ) 16384 0 to tot-malloc heapsize abort" You already have a heap." -1 swap memory-total &8000 - dup>r + Wimp_SlotSize dup r> dup &8000 + to heapptr - to heapsize &8000 + 32772 ! 2drop heapsize 0 heapptr 0 OS_Heap drop 2drop ; initialization-chain chain-add heapon : heapoff ( -- ) tot-malloc abort" Heap still used" -1 memory-total dup>r heapsize - Wimp_SlotSize dup r> - 0max to heapsize 32772 ! 2drop ; : allocate ( n -- ad ior ) dup 0< abort" Allocation Error!" aligned 0 heapptr 2 OS_Heap if 2drop here true else swap cell+ dup 4 and + +to tot-malloc false then ; : malloc ( n1 -- a1 ) aligned 0 heapptr 2 OS_Heap abort" Failed to allocate memory" swap +to tot-malloc ; : free ( ad -- ior ) 0 swap heapptr 6 OS_Heap drop 0 swap heapptr 3 OS_Heap nip nip tuck 0= if negate +to tot-malloc else drop then ; : release ( a1 -- ) free drop ; : resize ( a1 n1 -- a2 f1 ) \ ansi version of realloc 0 rot heapptr 6 OS_Heap 2drop cell- - dup +to tot-malloc swap heapptr 4 OS_Heap rot drop ; \ -- f1 = true on error : realloc ( size pointer_to_malloc_mem -- pointer_to_new_mem flag ) swap resize ; : _forth-io ( -- ) \ reset to Forth IO words ['] _emit is emit ['] _type is type ['] crtab is cr ['] _?cr is ?cr ['] _key is key ['] _key? is key? ['] _cls is cls ['] cls is page ['] _gotoxy is gotoxy ['] _getxy is getxy ['] _getcolrow is getcolrow ['] _col is col ; forth-io-chain chain-add _forth-io : forth-io ( -- ) forth-io-chain do-chain ; forth-io \ set the default I/O words .( ...done )