\ Do not use this file except in compliance with the License. You may \ obtain a copy of the License at http://www.microcore.org/License/ \ Software distributed under the License is distributed on an "AS IS" basis, \ WITHOUT WARRANTY OF ANY KIND, either express or implied. \ See the License for the specific language governing rights and limitations \ under the License. \ \ The Original Code is: GFORTH-CONFIG.FS \ \ Last change: KS 16.09.2015 10:27:59 \ \ Port to the gforth system and extensions by Ulrich.E.Hoffmann AT xlerb.de \ \ MicroCore Forth Cross-compiler configuration \ compatibility layer loads on top of gforth_062, or gforth_070 depending on Constant gforth_062 Only Forth also definitions hex warnings off version-string s" 0.6.2" str= Constant gforth_062 version-string s" 0.7.0" str= Constant gforth_070 gforth_062 gforth_070 or 0= [IF] cr .( gforth ) version-string type .( not supported) abort [THEN] : cell_width ( -- u ) 0 1 BEGIN swap 1+ swap 2* ?dup 0= UNTIL ; : cell- 1 cells - ; : mem-save ( x1 ... xn n -- addr ) dup 1+ cells allocate Abort" memstore: Cannot allocate memory" ( x1 ... xn n addr ) dup >r 2dup ! cell+ \ store length swap 0 ?DO ( x1 .. xi addr_i ) swap over ! cell+ ( x1 ... xi-1 addr_i-1 ) LOOP ( addr1 ) drop r> ; : mem-restore ( addr -- x1 ... xn n ) dup >r ( addr ) dup @ ( addr len ) dup >r cells + ( addr' ) r@ 0 ?DO ( x1 .. xi addri ) dup @ swap cell- ( x1 ... xi xi+1 addr_i+1 ) LOOP ( x1 ... xn addr ) drop r> ( x1 ... xn n ) r> free Abort" mem-restore: could not free memory" ; : source> ( -- sca ) save-input mem-save ; : >source ( sca -- ) mem-restore restore-input abort" couldn't restore input" ; : drop-source ( sca -- ) free Abort" drop-source: cannot free source code info" ; : skip-input ( c -- ) source dup >in @ min /string over >r rot skip drop r> - >in +! ; : scan-input ( c ccccc[c] -- ) loadfile @ 0= abort" can only be loaded from file" BEGIN >in @ over parse nip >in @ rot - = \ is there no delimter? WHILE refill 0= IF drop EXIT THEN REPEAT drop ; : u2/ ( u1 -- u2 ) 1 rshift ; \ Assumes 2's complement arithmetic : 2** ( n -- 2**n ) 1 swap lshift ; : binary ( -- ) 2 base ! ; \ IO Redirection : _CR ( -- ) newline (type) ; Defer CR : _EMIT ( c -- ) (emit) ; : _TYPE ( c-addr len -- ) 2dup newline d= IF 2drop CR EXIT THEN \ make old cr invoke new CR (type) ; ' _TYPE IS TYPE ' _CR IS CR ' _EMIT IS EMIT : ascii ( -- ch ) char ; : Module ( -- ) >IN @ >R BL WORD FIND IF EXECUTE ELSE DROP THEN R> >IN ! MARKER ; : ?comp state @ 0= Abort" compilation only" ; : ?exec state @ Abort" execution only" ; : [NOTIF] ( flag -- ) \ tools-ext bracket-notif IF countif off lookup @ [ [struct]-voc 3 cells + ] ALiteral ! [struct]-voc lookup ! THEN ; immediate : becomes ( new-xt -- ) \ makes behave as new-xt here >r >r ' >body dp ! postpone ahead r> >body dp ! postpone THEN r> dp ! ; Create save[ 2 cells allot ' [ >body save[ 2 cells cmove Create save] 2 cells allot ' ] >body save] 2 cells cmove : unpatch ( -- ) save[ [ ' [ >body ] Literal 2 cells cmove save] [ ' ] >body ] Literal 2 cells cmove ; gforth_062 [IF] : unknown ( addr u -- ) type space -&13 throw ; ' unknown IS compiler-notfound ' unknown IS interpreter-notfound \ ' .error-string IS DoError Variable 'interpreter ' interpreter 'interpreter ! Variable 'compiler ' compiler 'compiler ! : new[ ( -- ) 'interpreter @ IS parser state off ; immediate ' new[ becomes [ : new] ( -- ) 'compiler @ IS parser state on ; ' new] becomes ] [THEN] gforth_070 [IF] ' interpreter-notfound1 Alias interpreter-notfound ' compiler-notfound1 Alias compiler-notfound Variable 'interpreter ' interpreter1 'interpreter ! Variable 'compiler ' compiler1 'compiler ! : new[ ( -- ) 'interpreter @ IS parser1 state off ; immediate ' new[ becomes [ : new] ( -- ) 'compiler @ IS parser1 state on ; ' new] becomes ] [THEN] ' noop IS dobacktrace : forget ' drop ; \ floored division : / ( n1 n2 -- n3 ) >r s>d r> fm/mod nip ; : ?missing ( f -- ) ABORT" not found" ; : defined ( -- xxxx ff | xt tf ) parse-word over swap name-too-short? find-name dup IF name?int nip true THEN ; : hide ( -- ) \ manipulate word header so it won't be found latest name>string $80 or swap cell- c! ; : reveal ( -- ) \ manipulate word header so it will be found again latest name>string $7F and swap cell- c! ; : new.voc ( wid -- ) dup >r wordlist-struct %size + dup head? -1 = IF ( wid nt ) dup name>int dup >code-address docon: = swap >body @ r@ = and IF id. rdrop EXIT THEN THEN drop r> body> >head-noprim id. ; ' new.voc becomes .voc : close-port ; \ --------------------------------------------------------------------------- \ Some System word (re)definitions for a more sympathetic environment \ --------------------------------------------------------------------------- : ?cr ( -- ) ; $0A Constant #lf $0D Constant #cr : stop? ( -- flag ) key? IF key #cr = ?dup ?EXIT key #cr = EXIT THEN false ; : .wordname ( pfa -- ) body> >name .name space ; : have ( ccc -- xt | false ) BL word find and ; : shift ( n1 quan -- n2 ) dup 0< IF abs rshift EXIT THEN lshift ; : ashift ( n1 n2 -- n3 ) dup 0< IF negate 0 DO 2/ LOOP EXIT THEN 0 ?DO 2* LOOP ; : m/mod ( d n -- rem quot ) fm/mod ; : ndrop ( n1 .. nn n -- ) 0 ?DO drop LOOP ; : pack ( c u -- u' ) $100 um* drop swap $FF and or ; : unpack ( u -- c u' ) 0 $100 um/mod ; Variable debugging debugging off : comp? ( -- f ) State @ 0<> ; : exec? ( -- f ) State @ 0= ; : dbg? ( -- f ) debugging @ exec? and ; : ?dbg ( -- ) dbg? 0= Abort" debugging only" ; : ?pairs ( n1 n2 -- ) - abort" unstructured!" ; \ for checking conditional constructs : : ( -- 0 ) : 0 ; \ this allows to create an "intelligent" ; later on \ for MACRO definitions to pick the proper : ; ( 0 -- ) 0 ?pairs postpone ; [ 0 ?pairs ] ; immediate \ ; behaviour : Does> ( 0 -- 0 ) >r postpone Does> r> ; immediate : :noname ( -- 0 ) :noname 0 ; : case? ( n1 n2 -- n1 ff | tf ) over = dup IF nip THEN ; \ the most primitive case operator Create restore ] r> r> ! exit [ : save ( var -- ) r> swap dup >r @ >r restore >r >r ; : temp_hex ( -- ) r> Base save hex >r ; : udump ( addr u -- ) \ dumps 32-bit data items as unsigned 8 /mod swap 0= 1+ + 0 ?DO cr dup u. ." : " 8 0 DO dup @ cell_width 2/ 2/ 1+ u.r cell+ LOOP LOOP drop ; : \\ ( -- ) source-id IF BEGIN refill 0= UNTIL THEN postpone \ ; immediate \ \\ Forth Root definitions ' udump Alias udump ' have Alias have Forth definitions