Annotation of gforth/cross.fs, revision 1.1

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>