File:  [gforth] / gforth / cross.fs
Revision 1.11: download - view: text, annotated - select for diffs
Fri Sep 2 15:23:33 1994 UTC (25 years, 3 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Corrected bug in error reporting due to input stream restoration
Corrected bug in cross compiler du to later defined constants
renamed search into lookup and implemented the correct "search"
UPS: removed double deferred header and (header) - if problems tell
me why double deferred?

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