Return to cross.fs CVS log

Up to [gforth] / gforth

Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.

    1: \ CROSS.FS     The Cross-Compiler                      06oct92py
    2: \ $Id: cross.fs,v 1.8 1994/07/13 19:20:59 pazsan Exp $
    3: \ Idea and implementation: Bernd Paysan (py)
    4: \ Copyright 1992 by the ANSI figForth Development Group
    5: 
    6: \ Log:
    7: \       changed in ; [ to state off           12may93jaw
    8: \       included place +place                 12may93jaw
    9: \       for a created word (variable, constant...)
   10: \       is now an alias in the target voabulary.
   11: \       this means it is no longer necessary to
   12: \       switch between vocabularies for variable
   13: \       initialization                        12may93jaw
   14: \       discovered error in DOES>
   15: \       replaced !does with (;code)           16may93jaw
   16: \       made complete redesign and
   17: \       introduced two vocs method
   18: \       to be asure that the right words
   19: \       are found                             08jun93jaw
   20: \       btw:  ! works not with 16 bit
   21: \             targets                         09jun93jaw
   22: \       added: 2user and value                11jun93jaw
   23: 
   24: include other.fs       \ ansforth extentions for cross
   25: 
   26: : comment? ( c-addr u -- c-addr u )
   27:         2dup s" (" compare 0=
   28:         IF    postpone (
   29:         ELSE  2dup s" \" compare 0= IF postpone \ THEN
   30:         THEN ;
   31: 
   32: decimal
   33: 
   34: \ number?                                               11may93jaw
   35: 
   36: \ checks for +, -, $, & ...
   37: : leading? ( c-addr u -- c-addr u doubleflag negflag base )
   38:         2dup 1- chars + c@ [char] . =   \ process double
   39:         IF dup 1 chars = IF over 1 swap c! false ELSE 1 chars - true THEN
   40:         \ only if more than only . ( may be number output! )
   41:         \ if only . => store garbage
   42:         ELSE false THEN >r      \ numbers
   43:         false -rot base @ -rot
   44:         BEGIN over c@
   45:                 dup [char] - =
   46:                         IF drop >r >r >r
   47:                            drop true r> r> r> 0 THEN
   48:                 dup [char] + =
   49:                         IF drop 0 THEN
   50:                 dup [char] $ =
   51:                         IF drop >r >r drop 16 r> r> 0 THEN
   52:                 dup [char] & =
   53:                         IF drop >r >r drop 10 r> r> 0 THEN
   54:               0= IF 1 chars - swap char+ swap false ELSE true THEN
   55:               over 0= or
   56:         UNTIL
   57:               rot >r rot r> r> -rot ;
   58: 
   59: : number? ( c-addr -- n/d flag )
   60: \ return -1 if cell 1 if double 0 if garbage
   61:                 0 swap 0 swap           \ create double number
   62:                 count leading?
   63:                 base @ >r base !
   64:                 >r >r
   65:                 >number IF 2drop false r> r> 2drop
   66:                            r> base ! EXIT THEN
   67:                 drop r> r>
   68:                 IF IF dnegate 1
   69:                    ELSE drop negate -1 THEN
   70:                 ELSE IF 1 ELSE drop -1 THEN
   71:                 THEN r> base ! ;
   72: 
   73: 
   74: 
   75: \ Begin CROSS COMPILER:
   76: 
   77: \ GhostNames                                            9may93jaw
   78: \ second name source to search trough list
   79: 
   80: VARIABLE GhostNames
   81: 0 GhostNames !
   82: : GhostName ( -- addr )
   83:         here GhostNames @ , GhostNames ! here 0 ,
   84:         name count
   85: \        2dup type space
   86:         dup c, here over chars allot swap move align ;
   87: 
   88: hex
   89: 
   90: 
   91: Vocabulary Cross
   92: Vocabulary Target
   93: Vocabulary Ghosts
   94: VOCABULARY Minimal
   95: only Forth also Target also also
   96: definitions Forth
   97: 
   98: : T  previous Cross also Target ; immediate
   99: : G  Ghosts ; immediate
  100: : H  previous Forth also Cross ; immediate
  101: 
  102: forth definitions
  103: 
  104: : T  previous Cross also Target ; immediate
  105: : G  Ghosts ; immediate
  106: 
  107: : >cross  also Cross definitions previous ;
  108: : >target also Target definitions previous ;
  109: : >minimal also Minimal definitions previous ;
  110: 
  111: H
  112: 
  113: >CROSS
  114: 
  115: \ Variables                                            06oct92py
  116: 
  117: -1 Constant NIL
  118: Variable image
  119: Variable tlast    NIL tlast !  \ Last name field
  120: Variable tlastcfa \ Last code field
  121: Variable tdoes    \ Resolve does> calls
  122: Variable bit$
  123: Variable tdp
  124: : there  tdp @ ;
  125: 
  126: \ Parameter for target systems                         06oct92py
  127: 
  128: include machine.fs
  129: 
  130: >TARGET
  131: 
  132: \ Byte ordering and cell size                          06oct92py
  133: 
  134: : cell+         cell + ;
  135: : cells         cell<< lshift ;
  136: : chars         ;
  137: : floats	float * ;
  138:     
  139: >CROSS
  140: : cell/         cell<< rshift ;
  141: >TARGET
  142: 20 CONSTANT bl
  143: -1 Constant NIL
  144: -2 Constant :docol
  145: -3 Constant :docon
  146: -4 Constant :dovar
  147: -5 Constant :douser
  148: -6 Constant :dodoes
  149: -7 Constant :doesjump
  150: 
  151: >CROSS
  152: 
  153: endian  0 pad ! -1 pad c! pad @ 0<
  154: = [IF]   : bswap ; immediate 
  155: [ELSE]   : bswap ( big / little -- little / big )  0
  156:            cell 1- FOR  bits/byte lshift over
  157:                         [ 1 bits/byte lshift 1- ] Literal and or
  158:                         swap bits/byte rshift swap  NEXT  nip ;
  159: [THEN]
  160: 
  161: \ Memory initialisation                                05dec92py
  162: \ Fixed bug in else part                               11may93jaw
  163: 
  164: [IFDEF] Memory \ Memory is a bigFORTH feature
  165:    also Memory
  166:    : initmem ( var len -- )
  167:      2dup swap handle! >r @ r> erase ;
  168:    toss
  169: [ELSE]
  170:    : initmem ( var len -- )
  171:      tuck allocate abort" CROSS: No memory for target"
  172:      ( len var adr ) dup rot !
  173:      ( len adr ) swap erase ;
  174: [THEN]
  175: 
  176: \ MakeKernal                                           12dec92py
  177: 
  178: >MINIMAL
  179: : makekernal ( targetsize -- targetsize )
  180:   bit$  over 1- cell>bit rshift 1+ initmem
  181:   image over initmem tdp off ;
  182: 
  183: >CROSS
  184: \ Bit string manipulation                               06oct92py
  185: \                                                       9may93jaw
  186: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
  187: : bits ( n -- n ) chars Bittable + c@ ;
  188: 
  189: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
  190: : +bit ( addr n -- )  >bit over c@ or swap c! ;
  191: : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
  192: : relon ( taddr -- )  bit$ @ swap cell/ +bit ;
  193: : reloff ( taddr -- )  bit$ @ swap cell/ -bit ;
  194: 
  195: \ Target memory access                                 06oct92py
  196: 
  197: : align+  ( taddr -- rest )
  198:     cell tuck 1- and - [ cell 1- ] Literal and ;
  199: 
  200: >TARGET
  201: : aligned ( taddr -- ta-addr )  dup align+ + ;
  202: \ assumes cell alignment granularity (as GNU C)
  203: 
  204: >CROSS
  205: : >image ( taddr -- absaddr )  image @ + ;
  206: >TARGET
  207: : @  ( taddr -- w )     >image @ bswap ;
  208: : !  ( w taddr -- )     >r bswap r> >image ! ;
  209: : c@ ( taddr -- char )  >image c@ ;
  210: : c! ( char taddr -- )  >image c! ;
  211: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
  212: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
  213: 
  214: \ Target compilation primitives                        06oct92py
  215: \ included A!                                          16may93jaw
  216: 
  217: : here  ( -- there )    there ;
  218: : allot ( n -- )        tdp +! ;
  219: : ,     ( w -- )        T here H cell T allot  ! H ;
  220: : c,    ( char -- )     T here    1 allot c! H ;
  221: : align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
  222: 
  223: : A!                    dup relon T ! H ;
  224: : A,    ( w -- )        T here H relon T , H ;
  225: 
  226: >CROSS
  227: 
  228: \ threading modell                                     13dec92py
  229: 
  230: \ generic threading modell
  231: : docol,  ( -- ) :docol T A, 0 , H ;
  232: 
  233: >TARGET
  234: : >body   ( cfa -- pfa ) T cell+ cell+ H ;
  235: >CROSS
  236: 
  237: : dodoes, ( -- ) T :doesjump A, 0 , H ;
  238: 
  239: \ Ghost Builder                                        06oct92py
  240: 
  241: \ <T T> new version with temp variable                 10may93jaw
  242: 
  243: VARIABLE VocTemp
  244: 
  245: : <T  get-current VocTemp ! also Ghosts definitions ;
  246: : T>  previous VocTemp @ set-current ;
  247: 
  248: 4711 Constant <fwd>             4712 Constant <res>
  249: 4713 Constant <imm>
  250: 
  251: \ iForth makes only immediate directly after create
  252: \ make atonce trick! ?
  253: 
  254: Variable atonce atonce off
  255: 
  256: : NoExec true ABORT" CROSS: Don't execute ghost" ;
  257: 
  258: : GhostHeader <fwd> , 0 , ['] NoExec , ;
  259: 
  260: : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
  261: : >end 3 cells + ;
  262: 
  263: : Make-Ghost ( "name" -- ghost )
  264:   >in @ GhostName swap >in !
  265:   <T Create atonce @ IF immediate atonce off THEN
  266:   here tuck swap ! ghostheader T>
  267:   DOES>  >exec @ execute ;
  268: 
  269: \ ghost words                                          14oct92py
  270: \                                          changed:    10may93py/jaw
  271: 
  272: : gfind   ( string -- ghost true/1 / string false )
  273: \ searches for string in word-list ghosts
  274: \ !! wouldn't it be simpler to just use search-wordlist ? ae
  275:   dup count [ ' ghosts >body ] ALiteral search-wordlist
  276: \ >r get-order  0 set-order also ghosts  r> find >r >r
  277:   >r r@ IF  >body nip  THEN  r> ;
  278: \ set-order  r> r@  IF  >body  THEN  r> ;
  279: 
  280: VARIABLE Already
  281: 
  282: : ghost   ( "name" -- ghost )
  283:   Already off
  284:   >in @  name gfind   IF  Already on nip EXIT  THEN
  285:   drop  >in !  Make-Ghost ;
  286: 
  287: \ resolve                                              14oct92py
  288: 
  289: : resolve-loop ( ghost tcfa -- ghost tcfa )
  290:   >r dup >link @
  291:   BEGIN  dup  WHILE  dup T @ H r@ rot T ! H REPEAT  drop r> ;
  292: 
  293: \ exists                                                9may93jaw
  294: 
  295: : exists ( ghost tcfa -- )
  296:   over GhostNames
  297:   BEGIN @ dup
  298:   WHILE 2dup cell+ @ =
  299:   UNTIL
  300:         nip 2 cells + count cr ." CROSS: Exists: " type 4 spaces
  301:         swap cell+ !
  302:   ELSE true ABORT" CROSS: Ghostnames inconsistent"
  303:   THEN ;
  304: 
  305: : resolve  ( ghost tcfa -- )
  306:   over >magic @ <fwd> <>  IF  exists EXIT THEN
  307:   resolve-loop  over >link ! <res> swap >magic ! ;
  308: 
  309: \ gexecute ghost,                                      01nov92py
  310: 
  311: : do-forward   ( ghost -- )
  312:   >link dup @  there rot !  T  A,  H ;
  313: : do-resolve   ( ghost -- )
  314:   >link @                   T  A,  H ;
  315: 
  316: : gexecute   ( ghost -- )   dup @
  317:              <fwd> = IF  do-forward  ELSE  do-resolve  THEN ;
  318: : ghost,     ghost  gexecute ;
  319: 
  320: \ .unresolved                                          11may93jaw
  321: 
  322: variable ResolveFlag
  323: 
  324: \ ?touched                                             11may93jaw
  325: 
  326: : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @
  327:                                0 <> and ;
  328: 
  329: : ?resolved  ( ghostname -- )
  330:   dup cell+ @ ?touched
  331:   IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;
  332: 
  333: >MINIMAL
  334: : .unresolved  ( -- )
  335:   ResolveFlag off cr ." Unresolved: "
  336:   Ghostnames
  337:   BEGIN @ dup
  338:   WHILE dup ?resolved
  339:   REPEAT drop ResolveFlag @ 0= IF ." Nothing!" THEN cr ;
  340: 
  341: >CROSS
  342: \ Header states                                        12dec92py
  343: 
  344: : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
  345: 
  346: VARIABLE ^imm
  347: 
  348: >TARGET
  349: : immediate     20 flag!
  350:                 ^imm @ @ dup <imm> = ?EXIT
  351:                 <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
  352:                 <imm> ^imm @ ! ;
  353: : restrict      40 flag! ;
  354: >CROSS
  355: 
  356: \ ALIAS2 ansforth conform alias                          9may93jaw
  357: 
  358: : ALIAS2 create here 0 , DOES> @ execute ;
  359: \ usage:
  360: \ ' alias2 bla !
  361: 
  362: \ Target Header Creation                               01nov92py
  363: 
  364: : string,  ( addr count -- )
  365:   dup T c, H bounds  DO  I c@ T c, H  LOOP ; 
  366: : name,  ( "name" -- )  name count string, T align H ;
  367: : view,   ( -- ) ( dummy ) ;
  368: 
  369: VARIABLE CreateFlag CreateFlag off
  370: 
  371: : (Theader ( "name" -- ghost ) T align H view,
  372:   tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
  373:   >in @ name, >in ! T here H tlastcfa !
  374:   CreateFlag @ IF
  375:   >in @ alias2 swap >in !         \ create alias in target
  376:   >in @ ghost swap >in !
  377:   swap also ghosts ' previous swap !        \ tick ghost and store in alias
  378:   CreateFlag off
  379:   ELSE ghost THEN
  380:   dup >magic ^imm !     \ a pointer for immediate
  381:   Already @ IF  dup >end tdoes !
  382:   ELSE 0 tdoes ! THEN
  383:   80 flag! ;
  384: 
  385: VARIABLE ;Resolve 1 cells allot
  386: 
  387: : Theader  ( "name" -- )     (THeader there resolve 0 ;Resolve ! ;
  388: 
  389: >TARGET
  390: : Alias    ( cfa -- ) \ name
  391:   (THeader over resolve T A, H 80 flag! ;
  392: >CROSS
  393: 
  394: \ Conditionals and Comments                            11may93jaw
  395: 
  396: : ;Cond
  397:   postpone ;
  398:   swap ! ;  immediate
  399: 
  400: : Cond: ( -- ) \ name {code } ;
  401:   atonce on
  402:   ghost
  403:   >exec
  404:   :NONAME ;
  405: 
  406: : restrict? ( -- )
  407: \ aborts on interprete state - ae
  408:   state @ 0= ABORT" CROSS: Restricted" ;
  409: 
  410: : Comment ( -- )
  411:   >in @ atonce on ghost swap >in ! ' swap >exec ! ;
  412: 
  413: Comment (       Comment \
  414: 
  415: \ Predefined ghosts                                    12dec92py
  416: 
  417: ghost 0=                                        drop
  418: ghost branch    ghost ?branch                   2drop
  419: ghost (do)      ghost (?do)                     2drop
  420: ghost (for)                                     drop
  421: ghost (loop)    ghost (+loop)                   2drop
  422: ghost (next)                                    drop
  423: ghost unloop    ghost ;S                        2drop
  424: ghost lit       ghost (compile) ghost !         2drop drop
  425: ghost (;code)   ghost noop                      2drop
  426: ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
  427: 
  428: \ compile                                              10may93jaw
  429: 
  430: : compile  ( -- ) \ name
  431:   restrict?
  432:   name gfind dup 0= ABORT" CROSS: Can't compile "
  433:   0> ( immediate? )
  434:   IF    >exec @ compile,
  435:   ELSE  postpone literal postpone gexecute  THEN ;
  436:                                         immediate
  437: 
  438: >TARGET
  439: : '  ( -- cfa ) name gfind 0= ABORT" CROSS: undefined "
  440:   dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;
  441: 
  442: Cond: [']  compile lit ghost gexecute ;Cond
  443: 
  444: >CROSS
  445: \ tLiteral                                             12dec92py
  446: 
  447: : lit, ( n -- )   compile lit T  ,  H ;
  448: : alit, ( n -- )  compile lit T A,  H ;
  449: 
  450: >TARGET
  451: Cond:  Literal ( n -- )   restrict? lit, ;Cond
  452: Cond: ALiteral ( n -- )   restrict? alit, ;Cond
  453: 
  454: : Char ( "<char>" -- )  bl word char+ c@ ;
  455: Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond
  456: 
  457: >CROSS
  458: \ Target compiling loop                                12dec92py
  459: \ ">tib trick thrown out                               10may93jaw
  460: \ number? defined at the top                           11may93jaw
  461: 
  462: \ compiled word might leave items on stack!
  463: : tcom ( in name -- )
  464:   gfind  ?dup  IF    0> IF    nip >exec @ execute
  465:                         ELSE  nip gexecute  THEN EXIT THEN
  466:   number? dup  IF    0> IF swap lit,  THEN  lit,  drop
  467:                ELSE  2drop >in !
  468:                ghost gexecute THEN  ;
  469: 
  470: >TARGET
  471: \ : ; DOES>                                            13dec92py
  472: \ ]                                                     9may93py/jaw
  473: 
  474: : ] state on
  475:     BEGIN
  476:         BEGIN >in @ name
  477:               dup c@ 0= WHILE 2drop refill 0=
  478:               ABORT" CROSS: End of file while target compiling"
  479:         REPEAT
  480:         tcom
  481:         state @
  482:         0=
  483:     UNTIL ;
  484: 
  485: \ by the way: defining a second interpreter (a compiler-)loop
  486: \             is not allowed if a system should be ans conform
  487: 
  488: : : ( -- colon-sys ) \ Name
  489:   (THeader ;Resolve ! there ;Resolve cell+ !
  490:   docol, depth T ] H ;
  491: 
  492: Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond
  493: 
  494: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
  495: 
  496: Cond: ; ( -- ) restrict?
  497:                depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
  498:                           ELSE true ABORT" CROSS: Stack empty" THEN
  499:                compile ;S state off
  500:                ;Resolve @
  501:                IF ;Resolve @ ;Resolve cell+ @ resolve THEN
  502:                ;Cond
  503: Cond: [  restrict? state off ;Cond
  504: 
  505: >CROSS
  506: : !does  :dodoes tlastcfa @ tuck T ! cell+ ! H ;
  507: 
  508: >TARGET
  509: Cond: DOES> restrict?
  510:         compile (;code) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN
  511:         ;Cond
  512: : DOES> dodoes, T here H !does depth T ] H ;
  513: 
  514: >CROSS
  515: \ Creation                                             01nov92py
  516: 
  517: \ Builder                                               11may93jaw
  518: 
  519: : Builder    ( Create do: "name" -- )
  520:   >in @ alias2 swap dup >in ! >r >r
  521:   Make-Ghost rot swap >exec ! ,
  522:   r> r> >in !
  523:   also ghosts ' previous swap !
  524:   DOES> dup >exec @ execute ;
  525: 
  526: : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
  527:   IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
  528:   :dodoes T A, H gexecute T here H cell - reloff ;
  529: 
  530: : TCreate ( ghost -- )
  531:   CreateFlag on
  532:   Theader dup gdoes,
  533:   >end @ >exec @ execute ;
  534: 
  535: : Build:  ( -- [xt] [colon-sys] )
  536:   :noname  postpone TCreate ;
  537: 
  538: : gdoes>  ( ghost -- addr flag )
  539:   state @ IF  gexecute true EXIT  THEN
  540:   cell+ @ T >body H false ;
  541: 
  542: \ DO: ;DO                                               11may93jaw
  543: \ changed to ?EXIT                                      10may93jaw
  544: 
  545: : (does>)        postpone does> ; immediate \ second level does>
  546: 
  547: : DO:     ( -- addr [xt] [colon-sys] )
  548:   here ghostheader
  549:   :noname
  550:   postpone (does>) postpone gdoes> postpone ?EXIT ;
  551: 
  552: : ;DO ( addr [xt] [colon-sys] -- )
  553:   postpone ;    ( S addr xt )
  554:   over >exec ! ; immediate
  555: 
  556: : by      ( -- addr ) \ Name
  557:   ghost >end @ ;
  558: 
  559: >TARGET
  560: \ Variables and Constants                              05dec92py
  561: 
  562: Build:  ;
  563: DO: ( ghost -- addr ) ;DO
  564: Builder Create
  565: by Create :dovar resolve
  566: 
  567: Build: T 0 , H ;
  568: by Create
  569: Builder Variable
  570: 
  571: Build: T 0 A, H ;
  572: by Create
  573: Builder AVariable
  574: 
  575: \ User variables                                       04may94py
  576: 
  577: >CROSS
  578: Variable tup  0 tup !
  579: Variable tudp 0 tudp !
  580: : u,  ( n -- udp )
  581:   tup @ tudp @ + T  ! H
  582:   tudp @ dup cell+ tudp ! ;
  583: : au, ( n -- udp )
  584:   tup @ tudp @ + T A! H
  585:   tudp @ dup cell+ tudp ! ;
  586: >TARGET
  587: 
  588: Build: T 0 u, , H ;
  589: DO: ( ghost -- up-addr )  T @ H tup @ + ;DO
  590: Builder User
  591: by User :douser resolve
  592: 
  593: Build: T 0 u, , 0 u, drop H ;
  594: by User
  595: Builder 2User
  596: 
  597: Build: T 0 au, , H ;
  598: by User
  599: Builder AUser
  600: 
  601: Build:  ( n -- ) T , H ;
  602: DO: ( ghost -- n ) T @ H ;DO
  603: Builder Constant
  604: by Constant :docon resolve
  605: 
  606: Build:  ( n -- ) T A, H ;
  607: by Constant
  608: Builder AConstant
  609: 
  610: Build: T 0 , H ;
  611: by Constant
  612: Builder Value
  613: 
  614: Build:  ( -- ) compile noop ;
  615: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
  616: Builder Defer
  617: 
  618: \ structural conditionals                              17dec92py
  619: 
  620: >CROSS
  621: : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
  622: : sys?        ( sys -- sys )    dup 0= ?struc ;
  623: : >mark       ( -- sys )        T here  0 , H ;
  624: : >resolve    ( sys -- )        T here over - swap ! H ;
  625: : <resolve    ( sys -- )        T here - , H ;
  626: >TARGET
  627: 
  628: \ Structural Conditionals                              12dec92py
  629: 
  630: Cond: BUT       restrict? sys? swap ;Cond
  631: Cond: YET       restrict? sys? dup ;Cond
  632: 
  633: >CROSS
  634: Variable tleavings
  635: >TARGET
  636: 
  637: Cond: DONE   ( addr -- )  restrict? tleavings @
  638:       BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT
  639:       tleavings ! drop ;Cond
  640: 
  641: >CROSS
  642: : (leave  T here H tleavings @ T , H  tleavings ! ;
  643: >TARGET
  644: 
  645: Cond: LEAVE     restrict? compile branch (leave ;Cond
  646: Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond
  647: 
  648: \ Structural Conditionals                              12dec92py
  649: 
  650: Cond: AHEAD     restrict? compile branch >mark ;Cond
  651: Cond: IF        restrict? compile ?branch >mark ;Cond
  652: Cond: THEN      restrict? sys? dup T @ H ?struc >resolve ;Cond
  653: Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond
  654: 
  655: Cond: BEGIN     restrict? T here H ;Cond
  656: Cond: WHILE     restrict? sys? compile IF swap ;Cond
  657: Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond
  658: Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond
  659: Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond
  660: 
  661: \ Structural Conditionals                              12dec92py
  662: 
  663: Cond: DO        restrict? compile (do)   T here H ;Cond
  664: Cond: ?DO       restrict? compile (?do)  (leave T here H ;Cond
  665: Cond: FOR       restrict? compile (for)  T here H ;Cond
  666: 
  667: >CROSS
  668: : loop]   dup <resolve cell - compile DONE compile unloop ;
  669: >TARGET
  670: 
  671: Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond
  672: Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond
  673: Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond
  674: 
  675: \ String words                                         23feb93py
  676: 
  677: : ,"            [char] " parse string, T align H ;
  678: 
  679: Cond: ."        restrict? compile (.")     T ," H ;Cond
  680: Cond: S"        restrict? compile (S")     T ," H ;Cond
  681: Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond
  682: 
  683: Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
  684: : IS            T ' >body ! H ;
  685: 
  686: \ LINKED ERR" ENV" 2ENV"                                18may93jaw
  687: 
  688: \ linked list primitive
  689: : linked        T here over @ A, swap ! H ;
  690: 
  691: : err"   s" ErrLink linked" evaluate T , H
  692:          [char] " parse string, T align H ;
  693: 
  694: : env"  [char] " parse s" EnvLink linked" evaluate
  695:         string, T align , H ;
  696: 
  697: : 2env" [char] " parse s" EnvLink linked" evaluate
  698:         here >r string, T align , , H
  699:         r> dup T c@ H 80 and swap T c! H ;
  700: 
  701: \ compile must be last                                 22feb93py
  702: 
  703: Cond: compile ( -- ) restrict? \ name
  704:       name gfind dup 0= ABORT" CROSS: Can't compile"
  705:       0> IF    gexecute
  706:          ELSE  dup >magic @ <imm> =
  707:                IF   gexecute
  708:                ELSE compile (compile) gexecute THEN THEN ;Cond
  709: 
  710: Cond: postpone ( -- ) restrict? \ name
  711:       name gfind dup 0= ABORT" CROSS: Can't compile"
  712:       0> IF    gexecute
  713:          ELSE  dup >magic @ <imm> =
  714:                IF   gexecute
  715:                ELSE compile (compile) gexecute THEN THEN ;Cond
  716: 
  717: >MINIMAL
  718: also minimal
  719: \ Usefull words                                        13feb93py
  720: 
  721: : KB  400 * ;
  722: 
  723: \ define new [IFDEF] and [IFUNDEF]                      20may93jaw
  724: 
  725: : there? name gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
  726: 
  727: : [IFDEF] there? postpone [IF] ;
  728: : [IFUNDEF] there? 0= postpone [IF] ;
  729: 
  730: \ C: \- \+ Conditional Compiling                         09jun93jaw
  731: 
  732: : C: >in @ there? 0=
  733:      IF    >in ! T : H
  734:      ELSE drop
  735:         BEGIN bl word dup c@
  736:               IF   count comment? s" ;" compare 0= ?EXIT
  737:               ELSE refill 0= ABORT" CROSS: Out of Input while C:"
  738:               THEN
  739:         AGAIN
  740:      THEN ;
  741: 
  742: also minimal
  743: 
  744: : \- there? IF postpone \ THEN ;
  745: : \+ there? 0= IF postpone \ THEN ;
  746: 
  747: : [IF]   postpone [IF] ;
  748: : [THEN] postpone [THEN] ;
  749: : [ELSE] postpone [ELSE] ;
  750: 
  751: Cond: [IF]      [IF] ;Cond
  752: Cond: [IFDEF]   [IFDEF] ;Cond
  753: Cond: [IFUNDEF] [IFUNDEF] ;Cond
  754: Cond: [THEN]    [THEN] ;Cond
  755: Cond: [ELSE]    [ELSE] ;Cond
  756: 
  757: \ save-cross                                           17mar93py
  758: 
  759: \ i'm not interested in bigforth features this time    10may93jaw
  760: \ [IFDEF] file
  761: \ also file
  762: \ [THEN]
  763: \ included throw after create-file                     11may93jaw
  764: 
  765: endian Constant endian
  766: 
  767: : save-cross ( "name" -- )
  768:   bl parse ." Saving to " 2dup type
  769:   w/o bin create-file throw >r
  770:   image @ there r@ write-file throw
  771:   bit$  @ there 1- cell>bit rshift 1+ r@ write-file throw
  772:   r> close-file throw ;
  773: 
  774: \ words that should be in minimal
  775: 
  776: : + + ;         : 1- 1- ;
  777: : - - ;         : 2* 2* ;
  778: : dup dup ;     : over over ;
  779: : swap swap ;   : rot rot ;
  780: 
  781: \ include bug5.fs
  782: \ only forth also minimal definitions
  783: 
  784: : \ postpone \ ;
  785: : ( postpone ( ;
  786: : include bl word count included ;
  787: : .( [char] ) parse type ;
  788: : cr cr ;
  789: 
  790: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
  791: only forth also minimal definitions
  792: 
  793: \ cross-compiler words
  794: 
  795: : decimal       decimal ;
  796: : hex           hex ;
  797: 
  798: : tudp          T tudp H ;
  799: : tup           T tup H ;  minimal
  800: 
  801: \ for debugging...
  802: : order         order ;
  803: : words         words ;
  804: : .s            .s ;
  805: 
  806: : bye           bye ;
  807: 
  808: \ turnkey direction
  809: : H forth ; immediate
  810: : T minimal ; immediate
  811: : G ghosts ; immediate
  812: 
  813: : turnkey  0 set-order also Target definitions
  814:            also Minimal also ;
  815: 
  816: \ these ones are pefered:
  817: 
  818: : lock   turnkey ;
  819: : unlock forth also cross ;
  820: 
  821: unlock definitions also minimal
  822: : lock   lock ;
  823: lock