Return to bootstrap.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / bootstrap

Annotation of qemu/roms/openbios/forth/bootstrap/bootstrap.fs, revision 1.1

1.1     ! root        1: \ tag: bootstrap of basic forth words
        !             2: \ 
        !             3: \ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz
        !             4: \ 
        !             5: \ See the file "COPYING" for further information about
        !             6: \ the copyright and warranty status of this work.
        !             7: \ 
        !             8: 
        !             9: \ 
        !            10: \ this file contains almost all forth words described
        !            11: \ by the open firmware user interface. Some more complex
        !            12: \ parts are found in seperate files (memory management,
        !            13: \ vocabulary support)
        !            14: \ 
        !            15: 
        !            16: \ 
        !            17: \ often used constants (reduces dictionary size)
        !            18: \ 
        !            19: 
        !            20: 1 constant 1
        !            21: 2 constant 2
        !            22: 3 constant 3
        !            23: -1 constant -1
        !            24: 0 constant 0
        !            25: 
        !            26: 0 value my-self
        !            27: 
        !            28: \ 
        !            29: \ 7.3.5.1 Numeric-base control
        !            30: \ 
        !            31: 
        !            32: : decimal 10 base ! ;
        !            33: : hex 16 base ! ;
        !            34: : octal 8 base ! ;
        !            35: hex
        !            36: 
        !            37: \ 
        !            38: \ vocabulary words
        !            39: \ 
        !            40: 
        !            41: variable current forth-last current !
        !            42: 
        !            43: : last 
        !            44:   current @ 
        !            45:   ;
        !            46: 
        !            47: variable #order 0 #order !
        !            48: 
        !            49: defer context
        !            50: 0 value vocabularies?
        !            51: 
        !            52: \ 
        !            53: \ 7.3.7 Flag constants
        !            54: \ 
        !            55: 
        !            56: 1 1 = constant true
        !            57: 0 1 = constant false
        !            58: 
        !            59: \ 
        !            60: \ 7.3.9.2.2 Immediate words (part 1)
        !            61: \ 
        !            62: 
        !            63: : (immediate) ( xt -- )
        !            64:   1 - dup c@ 1 or swap c!
        !            65:   ;
        !            66: 
        !            67: : (compile-only)
        !            68:   1 - dup c@ 2 or swap c!
        !            69:   ;
        !            70: 
        !            71: : immediate 
        !            72:   last @ (immediate) 
        !            73:   ;
        !            74:   
        !            75: : compile-only 
        !            76:   last @ (compile-only) 
        !            77:   ;
        !            78: 
        !            79: : flags? ( xt -- flags )
        !            80:   /n /c + - c@ 7f and
        !            81:   ;
        !            82: 
        !            83: : immediate? ( xt -- true|false )
        !            84:   flags? 1 and 1 =
        !            85:   ;
        !            86: 
        !            87: : compile-only? ( xt -- true|false )
        !            88:   flags? 2 and 2 =
        !            89:   ;
        !            90: 
        !            91: : [  0 state ! ; compile-only
        !            92: : ] -1 state ! ; 
        !            93: 
        !            94: 
        !            95: 
        !            96: \ 
        !            97: \ 7.3.9.2.1 Data space allocation
        !            98: \ 
        !            99: 
        !           100: : allot here + here! ;
        !           101: : ,  here /n allot ! ;
        !           102: : c, here /c allot c! ;
        !           103: 
        !           104: : align
        !           105:   /n here /n 1 - and -   \ how many bytes to next alignment
        !           106:   /n 1 - and allot       \ mask out everything that is bigger 
        !           107:   ;                      \ than cellsize-1
        !           108: 
        !           109: : null-align
        !           110:   here dup align here swap - 0 fill 
        !           111:   ;
        !           112: 
        !           113: : w, 
        !           114:   here 1 and allot       \ if here is not even, we have to align.
        !           115:   here /w allot w! 
        !           116:   ;
        !           117: 
        !           118: : l, 
        !           119:   /l here /l 1 - and -   \ same as in align, with /l
        !           120:   /l 1 - and             \ if it's /l we are already aligned.
        !           121:   allot
        !           122:   here /l allot l! 
        !           123:   ;
        !           124: 
        !           125: 
        !           126: \ 
        !           127: \ 7.3.6 comparison operators (part 1)
        !           128: \ 
        !           129: 
        !           130: : <> = invert ;
        !           131: 
        !           132: 
        !           133: \ 
        !           134: \ 7.3.9.2.4 Miscellaneous dictionary (part 1)
        !           135: \ 
        !           136: 
        !           137: : (to) ( xt-new xt-defer -- )
        !           138:   /n + !
        !           139:   ;
        !           140: 
        !           141: : >body ( xt -- a-addr )  /n 1 lshift + ;
        !           142: : body> ( a-addr -- xt )  /n 1 lshift - ;
        !           143: 
        !           144: : reveal latest @ last ! ;
        !           145: : recursive reveal ; immediate
        !           146: : recurse latest @ /n +  , ; immediate
        !           147: 
        !           148: : noop ;
        !           149: 
        !           150: defer environment?
        !           151: : no-environment?
        !           152:   2drop false 
        !           153:   ;
        !           154: 
        !           155: ['] no-environment? ['] environment? (to)
        !           156: 
        !           157: 
        !           158: \ 
        !           159: \ 7.3.8.1 Conditional branches
        !           160: \ 
        !           161: 
        !           162: \ A control stack entry is implemented using 2 data stack items
        !           163: \ of the form ( addr type ). type can be one of the
        !           164: \ following:
        !           165: \   0 - orig
        !           166: \   1 - dest
        !           167: \   2 - do-sys
        !           168: 
        !           169: : resolve-orig here nip over /n + - swap ! ;
        !           170: : (if) ['] do?branch , here 0 0 , ; compile-only
        !           171: : (then) resolve-orig ; compile-only
        !           172: 
        !           173: variable tmp-comp-depth -1 tmp-comp-depth !
        !           174: variable tmp-comp-buf 0 tmp-comp-buf !
        !           175: 
        !           176: : setup-tmp-comp ( -- )
        !           177:   state @ 0 = (if)
        !           178:     here tmp-comp-buf @ here! ,     \ save here and switch to tmp directory
        !           179:     1 ,                              \ DOCOL
        !           180:     depth tmp-comp-depth !          \ save control depth
        !           181:     ]
        !           182:   (then)
        !           183: ;
        !           184: 
        !           185: : execute-tmp-comp ( -- )
        !           186:   depth tmp-comp-depth @ =
        !           187:   (if)
        !           188:     -1 tmp-comp-depth !
        !           189:     ['] (semis) ,
        !           190:     tmp-comp-buf @
        !           191:     dup @ here!
        !           192:     0 state !
        !           193:     /n + execute
        !           194:   (then)
        !           195: ;
        !           196: 
        !           197: : if setup-tmp-comp ['] do?branch , here 0 0 , ; immediate
        !           198: : then resolve-orig execute-tmp-comp ; compile-only
        !           199: : else ['] dobranch , here 0 0 , 2swap resolve-orig ; compile-only
        !           200: 
        !           201: \ 
        !           202: \ 7.3.8.3 Conditional loops
        !           203: \ 
        !           204: 
        !           205: \ some dummy words for see
        !           206: : (begin) ;
        !           207: : (again) ;
        !           208: : (until) ;
        !           209: : (while) ;
        !           210: : (repeat) ;
        !           211: 
        !           212: \ resolve-dest requires a loop...
        !           213: : (resolve-dest) here /n + nip - , ;
        !           214: : (resolve-begin) setup-tmp-comp ['] (begin) , here 1 ; immediate
        !           215: : (resolve-until) ['] (until) , ['] do?branch , (resolve-dest) execute-tmp-comp ; compile-only
        !           216: 
        !           217: : resolve-dest ( dest origN ... orig )
        !           218:   2 >r
        !           219:   (resolve-begin)
        !           220:     \ Find topmost control stack entry with a type of 1 (dest)
        !           221:     r> dup dup pick 1 = if
        !           222:       \ Move it to the top
        !           223:       roll
        !           224:       swap 1 - roll
        !           225:       \ Resolve it
        !           226:       (resolve-dest)
        !           227:       1                \ force exit
        !           228:     else
        !           229:       drop
        !           230:       2 + >r
        !           231:       0
        !           232:     then
        !           233:   (resolve-until)
        !           234: ;
        !           235: 
        !           236: : begin
        !           237:   setup-tmp-comp
        !           238:   ['] (begin) , 
        !           239:   here
        !           240:   1
        !           241:   ; immediate
        !           242: 
        !           243: : again
        !           244:   ['] (again) ,
        !           245:   ['] dobranch , 
        !           246:   resolve-dest
        !           247:   execute-tmp-comp
        !           248:   ; compile-only
        !           249: 
        !           250: : until
        !           251:   ['] (until) ,
        !           252:   ['] do?branch , 
        !           253:   resolve-dest
        !           254:   execute-tmp-comp
        !           255:   ; compile-only
        !           256: 
        !           257: : while
        !           258:   setup-tmp-comp
        !           259:   ['] (while) ,
        !           260:   ['] do?branch , 
        !           261:   here 0 0 , 2swap  
        !           262:   ; immediate
        !           263: 
        !           264: : repeat
        !           265:   ['] (repeat) ,
        !           266:   ['] dobranch , 
        !           267:   resolve-dest resolve-orig
        !           268:   execute-tmp-comp
        !           269:   ; compile-only
        !           270: 
        !           271: 
        !           272: \ 
        !           273: \ 7.3.8.4 Counted loops
        !           274: \ 
        !           275: 
        !           276: variable leaves 0 leaves !
        !           277: 
        !           278: : resolve-loop
        !           279:   leaves @
        !           280:   begin
        !           281:     ?dup 
        !           282:   while 
        !           283:     dup @               \ leaves -- leaves *leaves )
        !           284:     swap                \ -- *leaves leaves )
        !           285:     here over -         \ -- *leaves leaves here-leaves
        !           286:     swap !              \ -- *leaves
        !           287:   repeat
        !           288:   here nip - , 
        !           289:   leaves !
        !           290:   ;
        !           291: 
        !           292: : do
        !           293:   setup-tmp-comp
        !           294:   leaves @
        !           295:   here 2
        !           296:   ['] (do) , 
        !           297:   0 leaves !
        !           298:   ; immediate
        !           299: 
        !           300: : ?do
        !           301:   setup-tmp-comp
        !           302:   leaves @ 
        !           303:   ['] (?do) ,
        !           304:   here 2
        !           305:   here leaves !
        !           306:   0 ,
        !           307:   ; immediate
        !           308: 
        !           309: : loop
        !           310:   ['] (loop) ,
        !           311:   resolve-loop
        !           312:   execute-tmp-comp
        !           313:   ; immediate 
        !           314: 
        !           315: : +loop
        !           316:   ['] (+loop) ,
        !           317:   resolve-loop
        !           318:   execute-tmp-comp
        !           319:   ; immediate
        !           320: 
        !           321: 
        !           322: \ Using primitive versions of i and j
        !           323: \ speeds up loops by 300%
        !           324: \ : i r> r@ swap >r ;
        !           325: \ : j r> r> r> r@ -rot >r >r swap >r ;
        !           326: 
        !           327: : unloop r> r> r> 2drop >r ;
        !           328: 
        !           329: : leave 
        !           330:   ['] unloop , 
        !           331:   ['] dobranch , 
        !           332:   leaves @ 
        !           333:   here leaves !  
        !           334:   , 
        !           335:   ; immediate
        !           336: 
        !           337: : ?leave if leave then ;
        !           338: 
        !           339: \ 
        !           340: \ 7.3.8.2  Case statement
        !           341: \ 
        !           342:  
        !           343: : case
        !           344:   setup-tmp-comp
        !           345:   0
        !           346: ; immediate
        !           347: 
        !           348: : endcase
        !           349:   ['] drop , 
        !           350:   0 ?do
        !           351:     ['] then execute
        !           352:   loop
        !           353:   execute-tmp-comp
        !           354: ; immediate
        !           355: 
        !           356: : of
        !           357:   1 + >r 
        !           358:   ['] over , 
        !           359:   ['] = , 
        !           360:   ['] if execute 
        !           361:   ['] drop , 
        !           362:   r> 
        !           363:   ; immediate
        !           364: 
        !           365: : endof
        !           366:   >r 
        !           367:   ['] else execute 
        !           368:   r> 
        !           369:   ; immediate
        !           370: 
        !           371: \ 
        !           372: \ 7.3.8.5    Other control flow commands
        !           373: \ 
        !           374: 
        !           375: : exit r> drop ;
        !           376: 
        !           377: 
        !           378: \ 
        !           379: \ 7.3.4.3 ASCII constants (part 1)
        !           380: \ 
        !           381: 
        !           382: 20 constant bl
        !           383: 07 constant bell
        !           384: 08 constant bs
        !           385: 0d constant carret
        !           386: 0a constant linefeed
        !           387: 
        !           388: 
        !           389: \ 
        !           390: \ 7.3.1.1 - stack duplication
        !           391: \ 
        !           392: : tuck swap over ;
        !           393: : 3dup 2 pick 2 pick 2 pick ;
        !           394: 
        !           395: \ 
        !           396: \ 7.3.1.2 - stack removal
        !           397: \ 
        !           398: : clear 0 depth! ;
        !           399: : 3drop 2drop drop ;
        !           400: 
        !           401: \ 
        !           402: \ 7.3.1.3 - stack rearrangement
        !           403: \ 
        !           404: 
        !           405: : 2rot >r >r 2swap r> r> 2swap ;
        !           406: 
        !           407: \
        !           408: \ 7.3.1.4 - return stack
        !           409: \
        !           410: 
        !           411: \ Note: these words are not part of the official OF specification, however
        !           412: \ they are part of the ANSI DPANS94 core extensions (see section 6.2) and
        !           413: \ so this seems an appropriate place for them.
        !           414: : 2>r r> -rot swap >r >r >r ;
        !           415: : 2r> r> r> r> rot >r swap ;
        !           416: : 2r@ r> r> r> 2dup >r >r rot >r swap ;
        !           417: 
        !           418: \ 
        !           419: \ 7.3.2.1 - single precision integer arithmetic (part 1)
        !           420: \ 
        !           421: 
        !           422: : u/mod 0 swap mu/mod drop ;
        !           423: : 1+ 1 + ;
        !           424: : 1- 1 - ;
        !           425: : 2+ 2 + ;
        !           426: : 2- 2 - ;
        !           427: : even 1+ -2 and ;
        !           428: : bounds over + swap ;
        !           429: 
        !           430: \ 
        !           431: \ 7.3.2.2 bitwise logical operators
        !           432: \ 
        !           433: : << lshift ;
        !           434: : >> rshift ;
        !           435: : 2* 1 lshift ;
        !           436: : u2/ 1 rshift ;
        !           437: : 2/ 1 >>a ;
        !           438: : not invert ;
        !           439: 
        !           440: \ 
        !           441: \ 7.3.2.3 double number arithmetic
        !           442: \ 
        !           443: 
        !           444: : s>d      dup 0 < ; 
        !           445: : dnegate  0 0 2swap d- ;
        !           446: : dabs     dup 0 < if dnegate then ;
        !           447: : um/mod   mu/mod drop ;
        !           448: 
        !           449: \ symmetric division
        !           450: : sm/rem  ( d n -- rem quot )
        !           451:   over >r >r dabs r@ abs um/mod r> 0 < 
        !           452:   if 
        !           453:     negate 
        !           454:   then 
        !           455:   r> 0 < if 
        !           456:     negate swap negate swap
        !           457:   then
        !           458:   ;
        !           459: 
        !           460: \ floored division
        !           461: : fm/mod ( d n -- rem quot ) 
        !           462:   dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if 
        !           463:     1 - swap r> + swap exit 
        !           464:   then
        !           465:   r> drop
        !           466:   ;
        !           467: 
        !           468: \ 
        !           469: \ 7.3.2.1 - single precision integer arithmetic (part 2)
        !           470: \ 
        !           471: 
        !           472: : */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod  ;
        !           473: : */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ;
        !           474: : /mod >r s>d r> fm/mod ;
        !           475: : mod /mod drop ;
        !           476: : / /mod nip ;
        !           477: 
        !           478: 
        !           479: \ 
        !           480: \ 7.3.2.4 Data type conversion
        !           481: \ 
        !           482: 
        !           483: : lwsplit ( quad -- w.lo w.hi )
        !           484:   dup ffff and swap 10 rshift ffff and
        !           485: ;
        !           486: 
        !           487: : wbsplit ( word -- b.lo b.hi )
        !           488:   dup ff and swap 8 rshift ff and
        !           489: ;
        !           490: 
        !           491: : lbsplit ( quad -- b.lo b2 b3 b.hi )
        !           492:   lwsplit swap wbsplit rot wbsplit
        !           493: ;
        !           494: 
        !           495: : bwjoin ( b.lo b.hi -- word )
        !           496:   ff and 8 lshift swap ff and or
        !           497: ;
        !           498: 
        !           499: : wljoin ( w.lo w.hi -- quad )
        !           500:   ffff and 10 lshift swap ffff and or
        !           501: ;
        !           502: 
        !           503: : bljoin ( b.lo b2 b3 b.hi -- quad )
        !           504:   bwjoin -rot bwjoin swap wljoin
        !           505: ;
        !           506: 
        !           507: : wbflip ( word -- word ) \ flips bytes in a word
        !           508:   dup 8 rshift ff and swap ff and bwjoin
        !           509: ;
        !           510: 
        !           511: : lwflip ( q1 -- q2 ) 
        !           512:   dup 10 rshift ffff and swap ffff and wljoin
        !           513: ;
        !           514: 
        !           515: : lbflip ( q1 -- q2 )
        !           516:   dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin
        !           517: ;
        !           518: 
        !           519: \ 
        !           520: \ 7.3.2.5 address arithmetic
        !           521: \ 
        !           522: 
        !           523: : /c* /c * ;
        !           524: : /w* /w * ;
        !           525: : /l* /l * ;
        !           526: : /n* /n * ;
        !           527: : ca+ /c* + ;
        !           528: : wa+ /w* + ;
        !           529: : la+ /l* + ;
        !           530: : na+ /n* + ;
        !           531: : ca1+ /c + ;
        !           532: : wa1+ /w + ;
        !           533: : la1+ /l + ;
        !           534: : na1+ /n + ;
        !           535: : aligned /n 1- + /n negate and ;
        !           536: : char+ ca1+ ;
        !           537: : cell+ na1+ ;
        !           538: : chars /c* ;
        !           539: : cells /n* ;
        !           540: /n constant cell
        !           541: 
        !           542: \ 
        !           543: \ 7.3.6 Comparison operators
        !           544: \ 
        !           545: 
        !           546: : <= > not ;
        !           547: : >= < not ;
        !           548: : 0= 0 = ;
        !           549: : 0<= 0 <= ;
        !           550: : 0< 0 < ;
        !           551: : 0<> 0 <> ;
        !           552: : 0> 0 > ;
        !           553: : 0>=  0 >= ;
        !           554: : u<= u> not ;
        !           555: : u>= u< not ;
        !           556: : within  >r over > swap r> >= or not ;
        !           557: : between 1 + within ;
        !           558: 
        !           559: \ 
        !           560: \ 7.3.3.1 Memory access
        !           561: \ 
        !           562: 
        !           563: : 2@ dup cell+ @ swap @  ;
        !           564: : 2! dup >r ! r> cell+ ! ;
        !           565: 
        !           566: : <w@ w@ dup 8000 >= if 10000 - then ;
        !           567: 
        !           568: : comp ( str1 str2 len -- 0|1|-1 )
        !           569:   >r 0 -rot r>
        !           570:   bounds ?do
        !           571:     dup c@ i c@ - dup if
        !           572:       < if 1 else -1 then swap leave
        !           573:     then 
        !           574:     drop ca1+
        !           575:   loop
        !           576:   drop
        !           577: ;
        !           578: 
        !           579: \ compare two string
        !           580: 
        !           581: : $= ( str1 len1 str2 len2 -- true|false )
        !           582:     rot ( str1 str2 len2 len1 )
        !           583:     over ( str1 str2 len2 len1 len2 )  
        !           584:     <> if ( str1 str2 len2 )
        !           585:         3drop
        !           586:         false
        !           587:     else ( str1 str2 len2 )
        !           588:         comp
        !           589:        0=
        !           590:     then
        !           591: ;
        !           592: 
        !           593: \ : +! tuck @ + swap ! ;
        !           594: : off false swap ! ;
        !           595: : on true swap ! ;
        !           596: : blank bl fill ;
        !           597: : erase 0 fill ;
        !           598: : wbflips ( waddr len -- )
        !           599:   bounds do i w@ wbflip i w! /w +loop
        !           600: ;
        !           601: 
        !           602: : lwflips ( qaddr len -- )
        !           603:   bounds do i l@ lwflip i l! /l +loop
        !           604: ;
        !           605: 
        !           606: : lbflips ( qaddr len -- )
        !           607:   bounds do i l@ lbflip i l! /l +loop
        !           608: ;
        !           609: 
        !           610: 
        !           611: \ 
        !           612: \ 7.3.8.6    Error handling (part 1)
        !           613: \ 
        !           614: 
        !           615: variable catchframe
        !           616: 0 catchframe !
        !           617: 
        !           618: : catch
        !           619:   my-self >r
        !           620:   depth >r
        !           621:   catchframe @ >r
        !           622:   rdepth catchframe !
        !           623:   execute
        !           624:   r> catchframe !
        !           625:   r> r> 2drop 0
        !           626:   ;
        !           627: 
        !           628: : throw
        !           629:   ?dup if
        !           630:     catchframe @ rdepth!
        !           631:     r> catchframe !
        !           632:     r> swap >r depth!
        !           633:     drop r>
        !           634:     r> ['] my-self (to)
        !           635:   then
        !           636:   ;
        !           637: 
        !           638: \ 
        !           639: \ 7.3.3.2 memory allocation
        !           640: \ 
        !           641: 
        !           642: include memory.fs
        !           643: 
        !           644: 
        !           645: \ 
        !           646: \ 7.3.4.4 Console output (part 1)
        !           647: \ 
        !           648: 
        !           649: defer emit
        !           650: 
        !           651: : type bounds ?do i c@ emit loop ;
        !           652: 
        !           653: \ this one obviously only works when called 
        !           654: \ with a forth string as count fetches addr-1.
        !           655: \ openfirmware has no such req. therefore it has to go:
        !           656: 
        !           657: \ : type 0 do count emit loop drop ;
        !           658: 
        !           659: 
        !           660: \ 
        !           661: \ 7.3.4.1 Text Input
        !           662: \ 
        !           663: 
        !           664: 0 value source-id 
        !           665: 0 value ib
        !           666: variable #ib 0 #ib !
        !           667: variable >in 0 >in !
        !           668: 
        !           669: : source ( -- addr len )
        !           670:   ib #ib @
        !           671:   ;
        !           672: 
        !           673: : /string  ( c-addr1 u1 n -- c-addr2 u2 )
        !           674:    tuck - -rot + swap 
        !           675: ; 
        !           676: 
        !           677: 
        !           678: \ 
        !           679: \ pockets implementation for 7.3.4.1
        !           680: 
        !           681: 100 constant pocketsize
        !           682: 4   constant numpockets
        !           683: variable pockets 0 pockets !
        !           684: variable whichpocket 0 whichpocket !
        !           685: 
        !           686: \ allocate 4 pockets to begin with
        !           687: : init-pockets     ( -- )
        !           688:   pocketsize numpockets * alloc-mem pockets !
        !           689:   ;
        !           690: 
        !           691: : pocket ( ?? -- ?? )
        !           692:   pocketsize whichpocket @ *
        !           693:   pockets @ +
        !           694:   whichpocket @ 1 + numpockets mod
        !           695:   whichpocket !
        !           696:   ;
        !           697: 
        !           698: \ span variable from 7.3.4.2
        !           699: variable span 0 span !
        !           700: 
        !           701: \ if char is bl then any control character is matched
        !           702: : findchar ( str len char -- offs true | false )
        !           703:   swap 0 do
        !           704:     over i + c@
        !           705:     over dup bl = if <= else = then if
        !           706:       2drop i dup dup leave
        !           707:       \ i nip nip true exit \ replaces above
        !           708:     then
        !           709:   loop
        !           710:   =
        !           711:   \ drop drop false
        !           712:   ;
        !           713: 
        !           714: : parse ( delim  text<delim>  -- str len )
        !           715:   >r              \ save delimiter
        !           716:   ib >in @ +
        !           717:   span @ >in @ -  \ ib+offs len-offset.
        !           718:   dup 0 < if      \ if we are already at the end of the string, return an empty string
        !           719:     + 0                  \ move to end of input string
        !           720:     r> drop
        !           721:     exit
        !           722:   then
        !           723:   2dup r>         \ ib+offs len-offset ib+offs len-offset delim
        !           724:   findchar if     \ look for the delimiter. 
        !           725:     nip dup 1+
        !           726:   else
        !           727:      dup
        !           728:   then
        !           729:   >in +!
        !           730:   \ dup -1 = if drop 0 then \ workaround for negative length
        !           731:   ;
        !           732: 
        !           733: : skipws ( -- )
        !           734:   ib span @        ( -- ib recvchars )
        !           735:   begin
        !           736:     dup >in @ > if    ( -- recvchars>offs )
        !           737:       over >in @ +
        !           738:       c@ bl <=
        !           739:     else
        !           740:       false
        !           741:     then
        !           742:   while
        !           743:       1 >in +!
        !           744:   repeat
        !           745:   2drop
        !           746:   ;
        !           747: 
        !           748: : parse-word (  < >text< >  -- str len )
        !           749:   skipws bl parse
        !           750:   ;
        !           751: 
        !           752: : word ( delim  <delims>text<delim>  -- pstr )
        !           753:   pocket >r parse dup r@ c! bounds r> dup 2swap
        !           754:   do
        !           755:     char+ i c@ over c!
        !           756:   loop
        !           757:   drop
        !           758:   ;
        !           759: 
        !           760: : ( 29 parse 2drop ; immediate
        !           761: : \ span @ >in !   ; immediate
        !           762: 
        !           763: 
        !           764: 
        !           765: \ 
        !           766: \ 7.3.4.7 String literals
        !           767: \ 
        !           768: 
        !           769: : ",
        !           770:   bounds ?do
        !           771:     i c@ c,
        !           772:   loop
        !           773:   ;
        !           774: 
        !           775: : (")  ( -- addr len )
        !           776:   r> dup 
        !           777:   2 cells +                   ( r-addr addr )
        !           778:   over cell+ @                ( r-addr addr len )
        !           779:   rot over + aligned cell+ >r ( addr len R: r-addr )
        !           780:   ;
        !           781:  
        !           782: : handle-text ( temp-addr len -- addr len )
        !           783:   state @ if
        !           784:     ['] (") , dup , ", null-align
        !           785:   else
        !           786:     pocket swap
        !           787:     dup >r
        !           788:     0 ?do
        !           789:       over i + c@ over i + c!
        !           790:     loop
        !           791:     nip r>
        !           792:   then
        !           793:   ;
        !           794: 
        !           795: : s"
        !           796:   22 parse handle-text
        !           797:   ; immediate
        !           798: 
        !           799: 
        !           800: 
        !           801: \ 
        !           802: \ 7.3.4.4 Console output (part 2)
        !           803: \ 
        !           804: 
        !           805: : ."
        !           806:   22 parse handle-text
        !           807:   ['] type
        !           808:   state @ if
        !           809:     ,
        !           810:   else
        !           811:     execute
        !           812:   then
        !           813:   ; immediate
        !           814: 
        !           815: : .(
        !           816:   29 parse handle-text
        !           817:   ['] type
        !           818:   state @ if
        !           819:     ,
        !           820:   else
        !           821:     execute
        !           822:   then
        !           823:   ; immediate
        !           824: 
        !           825: 
        !           826: 
        !           827: \ 
        !           828: \ 7.3.4.8 String manipulation
        !           829: \ 
        !           830: 
        !           831: : count ( pstr -- str len ) 1+ dup 1- c@ ;
        !           832: 
        !           833: : pack  ( str len addr -- pstr )
        !           834:   2dup c!     \ store len
        !           835:   1+ swap 0 ?do
        !           836:     over i + c@ over i + c!
        !           837:   loop nip 1-
        !           838:   ;
        !           839: 
        !           840: : lcc   ( char1 -- char2 ) dup 41 5a between if 20 + then ;
        !           841: : upc   ( char1 -- char2 ) dup 61 7a between if 20 - then ;
        !           842: 
        !           843: : -trailing ( str len1 -- str len2 )
        !           844:   begin 
        !           845:     dup 0<> if  \ len != 0 ?
        !           846:       2dup 1- + 
        !           847:       c@ bl =
        !           848:     else 
        !           849:       false 
        !           850:     then
        !           851:   while
        !           852:     1-
        !           853:   repeat
        !           854:   ;
        !           855: 
        !           856: 
        !           857: \ 
        !           858: \ 7.3.4.5   Output formatting
        !           859: \ 
        !           860: 
        !           861: : cr linefeed emit ;
        !           862: : (cr carret emit ;
        !           863: : space bl emit ;
        !           864: : spaces 0 ?do space loop ;
        !           865: variable #line 0 #line !
        !           866: variable #out  0 #out  !
        !           867: 
        !           868: 
        !           869: \ 
        !           870: \ 7.3.9.2.3 Dictionary search
        !           871: \ 
        !           872: 
        !           873: \ helper functions
        !           874: 
        !           875: : lfa2name ( lfa -- name len )
        !           876:   1-                   \ skip flag byte
        !           877:   begin                \ skip 0 padding 
        !           878:     1- dup c@ ?dup 
        !           879:   until
        !           880:   7f and               \ clear high bit in length
        !           881: 
        !           882:   tuck - swap          ( ptr-to-len len - name len )
        !           883:   ;
        !           884: 
        !           885: : comp-nocase ( str1 str2 len -- true|false )
        !           886:   0 do
        !           887:     2dup i + c@ upc    ( str1 str2 byteX )
        !           888:     swap i + c@ upc ( str1 str2 byte1 byte2 )
        !           889:     <> if
        !           890:       0 leave
        !           891:     then
        !           892:   loop
        !           893:   if -1 else drop 0 then
        !           894:   swap drop
        !           895:   ;
        !           896: 
        !           897: : comp-word ( b-str len lfa -- true | false )
        !           898:   lfa2name        ( str len str len -- )
        !           899:   >r swap r>      ( str str len len )
        !           900:   over = if       ( str str len )
        !           901:     comp-nocase
        !           902:   else
        !           903:     drop drop drop false   \ if len does not match, string does not match
        !           904:   then
        !           905: ;
        !           906: 
        !           907: \ $find is an fcode word, but we place it here since we use it for find.
        !           908: 
        !           909: : find-wordlist ( name-str name-len last -- xt true | name-str name-len false )
        !           910: 
        !           911:   @ >r
        !           912: 
        !           913:   begin
        !           914:     2dup r@ dup if comp-word dup false = then
        !           915:   while
        !           916:     r> @ >r drop
        !           917:   repeat
        !           918: 
        !           919:   r@ if \ successful?
        !           920:     -rot 2drop r> cell+ swap
        !           921:   else
        !           922:     r> drop drop drop false
        !           923:   then
        !           924: 
        !           925:   ;
        !           926: 
        !           927: : $find ( name-str name-len -- xt true | name-str name-len false )
        !           928:   vocabularies? if
        !           929:     #order @ 0 ?do
        !           930:       i cells context + @
        !           931:       find-wordlist
        !           932:       ?dup if
        !           933:         unloop exit
        !           934:       then
        !           935:     loop
        !           936:     false
        !           937:   else
        !           938:     forth-last find-wordlist
        !           939:   then
        !           940:   ;
        !           941: 
        !           942: \ look up a word in the current wordlist
        !           943: : $find1 ( name-str name-len -- xt true | name-str name-len false )
        !           944:   vocabularies? if
        !           945:     current @
        !           946:   else
        !           947:     forth-last
        !           948:   then
        !           949:   find-wordlist
        !           950:   ;
        !           951: 
        !           952:   
        !           953: : '
        !           954:   parse-word $find 0= if 
        !           955:     type 3a emit -13 throw
        !           956:   then
        !           957:   ;
        !           958: 
        !           959: : ['] 
        !           960:   parse-word $find 0= if
        !           961:     type 3a emit -13 throw
        !           962:   then 
        !           963:   state @ if
        !           964:     ['] (lit) , , 
        !           965:   then
        !           966:   ; immediate
        !           967: 
        !           968: : find ( pstr -- xt n | pstr false )
        !           969:   dup count $find           \  pstr xt true | pstr name-str name-len false
        !           970:   if
        !           971:     nip true
        !           972:     over immediate? if
        !           973:       negate                \ immediate returns 1
        !           974:     then
        !           975:   else
        !           976:     2drop false
        !           977:   then
        !           978:   ;
        !           979: 
        !           980: 
        !           981: \ 
        !           982: \ 7.3.9.2.2 Immediate words (part 2)
        !           983: \ 
        !           984: 
        !           985: : literal ['] (lit) , , ; immediate
        !           986: : compile, , ; immediate
        !           987: : compile r> cell+ dup @ , >r ;
        !           988: : [compile] ['] ' execute , ; immediate
        !           989: 
        !           990: : postpone
        !           991:   parse-word $find if
        !           992:     dup immediate? not if
        !           993:       ['] (lit) , , ['] ,
        !           994:     then
        !           995:     ,
        !           996:   else
        !           997:     s" undefined word " type type cr
        !           998:   then
        !           999:   ; immediate
        !          1000: 
        !          1001: 
        !          1002: \ 
        !          1003: \ 7.3.9.2.4 Miscellaneous dictionary (part 2)
        !          1004: \ 
        !          1005: 
        !          1006: variable #instance
        !          1007: 
        !          1008: : instance ( -- )
        !          1009:   true #instance !
        !          1010: ;
        !          1011: 
        !          1012: : #instance-base
        !          1013:   my-self dup if @ then
        !          1014: ;
        !          1015: 
        !          1016: : #instance-offs
        !          1017:   my-self dup if na1+ then
        !          1018: ;
        !          1019: 
        !          1020: \ the following instance words are used internally
        !          1021: \ to implement variable instantiation.
        !          1022: 
        !          1023: : instance-cfa? ( cfa -- true | false )
        !          1024:   b e within                              \ b,c and d are instance defining words
        !          1025: ;
        !          1026: 
        !          1027: : behavior ( xt-defer -- xt )
        !          1028:   dup @ instance-cfa? if
        !          1029:     #instance-base ?dup if
        !          1030:       swap na1+ @ + @
        !          1031:     else
        !          1032:       3 /n* + @
        !          1033:     then
        !          1034:   else
        !          1035:     na1+ @
        !          1036:   then
        !          1037: ;
        !          1038: 
        !          1039: : (ito) ( xt-new xt-defer -- )
        !          1040:   #instance-base ?dup if
        !          1041:     swap na1+ @ + !
        !          1042:   else
        !          1043:     3 /n* + !
        !          1044:   then
        !          1045: ;
        !          1046: 
        !          1047: : to
        !          1048:   ['] ' execute
        !          1049:   dup @ instance-cfa?
        !          1050:   state @ if
        !          1051:     swap ['] (lit) , , if ['] (ito) else ['] (to) then ,
        !          1052:   else
        !          1053:     if (ito) else /n + ! then
        !          1054:   then
        !          1055:   ; immediate
        !          1056: 
        !          1057: : is ( xt "wordname<>" -- )
        !          1058:   parse-word $find if
        !          1059:     (to)
        !          1060:   else
        !          1061:     s" could not find " type type
        !          1062:   then
        !          1063:   ;
        !          1064: 
        !          1065: \ 
        !          1066: \ 7.3.4.2 Console Input
        !          1067: \ 
        !          1068: 
        !          1069: defer key?
        !          1070: defer key
        !          1071: 
        !          1072: : accept ( addr len -- len2 )
        !          1073:   tuck 0 do
        !          1074:     key
        !          1075:     dup linefeed = if
        !          1076:       space drop drop drop i 0 leave
        !          1077:     then
        !          1078:     dup emit over c! 1 +
        !          1079:   loop
        !          1080:   drop ( cr )
        !          1081:   ;
        !          1082: 
        !          1083: : expect ( addr len -- )
        !          1084:   accept span !
        !          1085:   ;
        !          1086: 
        !          1087: 
        !          1088: \ 
        !          1089: \ 7.3.4.3 ASCII constants (part 2)
        !          1090: \ 
        !          1091: 
        !          1092: : handle-lit
        !          1093:   state @ if
        !          1094:     2 = if
        !          1095:       ['] (lit) ,  ,
        !          1096:     then
        !          1097:     ['] (lit) ,  ,
        !          1098:   else
        !          1099:     drop
        !          1100:   then
        !          1101:   ;
        !          1102: 
        !          1103: : char
        !          1104:   parse-word 0<> if c@ else s" Unexpected EOL." type cr then ;
        !          1105:   ;
        !          1106: 
        !          1107: : ascii  char 1 handle-lit ; immediate
        !          1108: : [char] char 1 handle-lit ; immediate
        !          1109: 
        !          1110: : control   
        !          1111:   char bl 1- and 1 handle-lit 
        !          1112: ; immediate
        !          1113: 
        !          1114: 
        !          1115: 
        !          1116: \ 
        !          1117: \ 7.3.8.6    Error handling (part 2)
        !          1118: \ 
        !          1119: 
        !          1120: : abort 
        !          1121:   -1 throw
        !          1122:   ;
        !          1123: 
        !          1124: : abort"
        !          1125:   ['] if execute
        !          1126:   22 parse handle-text 
        !          1127:   ['] type , 
        !          1128:   ['] (lit) , 
        !          1129:   -2 , 
        !          1130:   ['] throw ,
        !          1131:   ['] then execute
        !          1132:   ; compile-only 
        !          1133: 
        !          1134: \ 
        !          1135: \ 7.5.3.1 Dictionary search
        !          1136: \ 
        !          1137: 
        !          1138: \ this does not belong here, but its nice for testing
        !          1139: 
        !          1140: : words ( -- )
        !          1141:   last
        !          1142:   begin @ 
        !          1143:     ?dup while
        !          1144:     dup lfa2name
        !          1145: 
        !          1146:     \ Don't print spaces for headerless words
        !          1147:     dup if
        !          1148:       type space
        !          1149:     else
        !          1150:       type
        !          1151:     then
        !          1152: 
        !          1153:   repeat
        !          1154:   cr
        !          1155:   ;
        !          1156: 
        !          1157: \ 
        !          1158: \ 7.3.5.4 Numeric output primitives
        !          1159: \ 
        !          1160: 
        !          1161: false value capital-hex?
        !          1162: 
        !          1163: : pad       ( -- addr )      here 100 + aligned ;
        !          1164: 
        !          1165: : todigit   ( num -- ascii ) 
        !          1166:   dup 9 > if 
        !          1167:     capital-hex? not if
        !          1168:       20 +
        !          1169:     then
        !          1170:     7 + 
        !          1171:   then 
        !          1172:   30 + 
        !          1173:   ;
        !          1174: 
        !          1175: : <#   pad dup ! ;
        !          1176: : hold pad dup @ 1- tuck swap ! c! ;
        !          1177: : sign 
        !          1178:   0< if 
        !          1179:     2d hold 
        !          1180:   then 
        !          1181:   ;
        !          1182: 
        !          1183: : #    base @ mu/mod rot todigit hold ;
        !          1184: : #s   begin # 2dup or 0= until ;
        !          1185: : #>   2drop pad dup @ tuck - ;
        !          1186: : (.)  <# dup >r abs 0 #s r> sign #> ;
        !          1187: 
        !          1188: : u#   base @ u/mod swap todigit hold ;
        !          1189: : u#s  begin u# dup 0= until ;
        !          1190: : u#> 0 #> ;
        !          1191: : (u.) <# u#s u#> ;
        !          1192: 
        !          1193: \ 
        !          1194: \ 7.3.5.3 Numeric output
        !          1195: \ 
        !          1196: 
        !          1197: : .    (.) type space ;
        !          1198: : s.   . ;
        !          1199: : u.   (u.) type space ;
        !          1200: : .r   swap (.) rot 2dup < if over - spaces else drop then type ;
        !          1201: : u.r  swap (u.) rot 2dup < if over - spaces else drop then type ;
        !          1202: : .d   base @ swap decimal . base ! ;
        !          1203: : .h   base @ swap hex . base ! ;
        !          1204: 
        !          1205: : .s 
        !          1206:   3c emit depth dup (.) type 3e emit space
        !          1207:   0 
        !          1208:   ?do
        !          1209:     depth i - 1- pick .
        !          1210:   loop 
        !          1211:   cr
        !          1212:   ;
        !          1213: 
        !          1214: \ 
        !          1215: \ 7.3.5.2 Numeric input
        !          1216: \ 
        !          1217: 
        !          1218: : digit ( char base -- n true | char false )
        !          1219:   swap dup upc dup 
        !          1220:   41 5a ( A - Z ) between if
        !          1221:     7 -
        !          1222:   else
        !          1223:     dup 39 > if \ protect from : and ;
        !          1224:       -rot 2drop false exit
        !          1225:     then
        !          1226:   then
        !          1227:   
        !          1228:   30 ( number 0 ) - rot over swap 0 swap within  if
        !          1229:     nip true
        !          1230:   else
        !          1231:     drop false
        !          1232:   then  
        !          1233:   ;
        !          1234: 
        !          1235: : >number
        !          1236:    begin 
        !          1237:       dup 
        !          1238:    while
        !          1239:       over c@ base @ digit 0= if    
        !          1240:          drop exit 
        !          1241:       then  >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap 
        !          1242:       1 /string 
        !          1243:    repeat 
        !          1244:    ;
        !          1245: 
        !          1246: : numdelim?   
        !          1247:    dup 2e = swap 2c = or 
        !          1248: ; 
        !          1249: 
        !          1250: 
        !          1251: : $dnumber?   
        !          1252:    0 0 2swap dup 0= if    
        !          1253:       2drop 2drop 0 exit 
        !          1254:    then  over c@ 2d = dup >r negate /string begin 
        !          1255:       >number dup 1 > 
        !          1256:    while
        !          1257:       over c@ numdelim? 0= if    
        !          1258:          2drop 2drop r> drop 0 exit 
        !          1259:       then  1 /string 
        !          1260:    repeat if    
        !          1261:       c@ 2e = if    
        !          1262:          true 
        !          1263:       else
        !          1264:          2drop r> drop 0 exit 
        !          1265:       then  
        !          1266:    else
        !          1267:       drop false 
        !          1268:    then  over or if    
        !          1269:       r> if    
        !          1270:          dnegate 
        !          1271:       then  2 
        !          1272:    else
        !          1273:      drop r> if    
        !          1274:          negate 
        !          1275:       then  1 
        !          1276:    then  
        !          1277: ; 
        !          1278: 
        !          1279: 
        !          1280: : $number (  )
        !          1281:    $dnumber? 
        !          1282:    case
        !          1283:    0 of   true endof
        !          1284:    1 of   false endof
        !          1285:    2 of   drop false endof
        !          1286:    endcase
        !          1287: ; 
        !          1288: 
        !          1289: : d#
        !          1290:   parse-word
        !          1291:   base @ >r
        !          1292: 
        !          1293:   decimal
        !          1294: 
        !          1295:   $number if
        !          1296:     s" illegal number" type cr 0
        !          1297:   then
        !          1298:   r> base !
        !          1299:   1 handle-lit
        !          1300:   ; immediate
        !          1301: 
        !          1302: : h#
        !          1303:   parse-word
        !          1304:   base @ >r
        !          1305: 
        !          1306:   hex
        !          1307: 
        !          1308:   $number if
        !          1309:     s" illegal number" type cr 0
        !          1310:   then
        !          1311:   r> base !
        !          1312:   1 handle-lit
        !          1313:   ; immediate
        !          1314: 
        !          1315: : o#
        !          1316:   parse-word
        !          1317:   base @ >r
        !          1318: 
        !          1319:   octal
        !          1320: 
        !          1321:   $number if
        !          1322:     s" illegal number" type cr 0
        !          1323:   then
        !          1324:   r> base !
        !          1325:   1 handle-lit
        !          1326:   ; immediate
        !          1327: 
        !          1328: 
        !          1329: \ 
        !          1330: \ 7.3.4.7 String Literals (part 2)
        !          1331: \ 
        !          1332: 
        !          1333: : "
        !          1334:   pocket dup
        !          1335:   begin
        !          1336:     span @ >in @ > if
        !          1337:       22 parse >r         ( pocket pocket str  R: len )
        !          1338:       over r@ move        \ copy string
        !          1339:       r> +                ( pocket nextdest )
        !          1340:       ib >in @ + c@       ( pocket nextdest nexchar )
        !          1341:       1 >in +!
        !          1342:       28 =                \ is nextchar a parenthesis?
        !          1343:       span @ >in @ >      \ more input?
        !          1344:       and
        !          1345:     else
        !          1346:       false
        !          1347:     then
        !          1348:   while
        !          1349:     29 parse              \ parse everything up to the next ')'
        !          1350:     bounds ?do
        !          1351:       i c@ 10 digit if
        !          1352:         i 1+ c@ 10 digit if
        !          1353:           swap 4 lshift or
        !          1354:         else
        !          1355:           drop
        !          1356:         then
        !          1357:         over c! 1+
        !          1358:         2
        !          1359:       else
        !          1360:         drop 1
        !          1361:       then
        !          1362:     +loop
        !          1363:   repeat
        !          1364:   over -
        !          1365:   handle-text
        !          1366: ; immediate
        !          1367: 
        !          1368: 
        !          1369: \ 
        !          1370: \ 7.3.3.1 Memory Access (part 2)
        !          1371: \ 
        !          1372: 
        !          1373: : dump ( addr len -- )
        !          1374:   over + swap
        !          1375:   cr
        !          1376:   do i u. space
        !          1377:     10 0 do
        !          1378:       j i + c@
        !          1379:       dup 10 / todigit emit
        !          1380:       10 mod todigit emit
        !          1381:       space
        !          1382:       i 7 = if space then
        !          1383:     loop
        !          1384:     3 spaces
        !          1385:     10 0 do
        !          1386:       j i + c@
        !          1387:       dup 20 < if drop 2e then \ non-printables as dots?
        !          1388:       emit
        !          1389:     loop
        !          1390:     cr
        !          1391:   10 +loop
        !          1392: ;
        !          1393: 
        !          1394: 
        !          1395: 
        !          1396: \ 
        !          1397: \ 7.3.9.1 Defining words
        !          1398: \ 
        !          1399: 
        !          1400: : header ( name len -- )
        !          1401:   dup if                            \ might be a noname...
        !          1402:     2dup $find1 if
        !          1403:       drop 2dup type s"  isn't unique." type cr
        !          1404:     else
        !          1405:       2drop
        !          1406:     then
        !          1407:   then
        !          1408:   null-align
        !          1409:   dup -rot ", 80 or c,              \ write name and len
        !          1410:   here /n 1- and 0= if 0 c, then    \ pad and space for flags
        !          1411:   null-align
        !          1412:   80 here 1- c!                     \ write flags byte
        !          1413:   here last @ , latest !            \ write backlink and set latest
        !          1414:  ;
        !          1415: 
        !          1416: 
        !          1417: : :
        !          1418:   parse-word header
        !          1419:   1 , ]
        !          1420:   ;
        !          1421: 
        !          1422: : :noname 
        !          1423:   0 0 header 
        !          1424:   here
        !          1425:   1 , ]
        !          1426:   ;
        !          1427: 
        !          1428: : ;
        !          1429:   ['] (semis) , reveal ['] [ execute
        !          1430:   ; immediate
        !          1431: 
        !          1432: : constant
        !          1433:   parse-word header
        !          1434:   3 , ,                             \ compile DOCON and value
        !          1435:   reveal
        !          1436:   ;
        !          1437: 
        !          1438: 0 value active-package
        !          1439: : instance, ( size -- )
        !          1440:   \ first word of the device node holds the instance size
        !          1441:   dup active-package @ dup rot + active-package !
        !          1442:   , ,      \ offset size
        !          1443: ;
        !          1444: 
        !          1445: : instance? ( -- flag )
        !          1446:   #instance @ dup if
        !          1447:     false #instance !
        !          1448:   then
        !          1449: ;
        !          1450: 
        !          1451: : value
        !          1452:   parse-word header
        !          1453:   instance? if
        !          1454:     /n b , instance, ,              \ DOIVAL
        !          1455:   else
        !          1456:     3 , ,
        !          1457:   then
        !          1458:   reveal
        !          1459:   ;
        !          1460: 
        !          1461: : variable
        !          1462:   parse-word header
        !          1463:   instance? if
        !          1464:     /n c , instance, 0 ,
        !          1465:   else
        !          1466:     4 , 0 ,
        !          1467:   then
        !          1468:   reveal
        !          1469:   ;
        !          1470: 
        !          1471: : $buffer: ( size str len -- where )
        !          1472:   header
        !          1473:   instance? if
        !          1474:     /n over /n 1- and - /n 1- and +     \ align buffer size
        !          1475:     dup c , instance,                   \ DOIVAR
        !          1476:   else
        !          1477:     4 ,
        !          1478:   then
        !          1479:   here swap
        !          1480:   2dup 0 fill                            \ zerofill
        !          1481:   allot
        !          1482:   reveal
        !          1483: ;
        !          1484: 
        !          1485: : buffer: ( size -- )
        !          1486:   parse-word $buffer: drop
        !          1487: ;
        !          1488: 
        !          1489: : (undefined-defer)  ( -- )
        !          1490:   \ XXX: this does not work with behavior ... execute
        !          1491:   r@ 2 cells - lfa2name
        !          1492:   s" undefined defer word " type type cr ;
        !          1493: 
        !          1494: : (undefined-idefer)  ( -- )
        !          1495:   s" undefined idefer word " type cr ;
        !          1496: 
        !          1497: : defer  (  new-name< >  -- )
        !          1498:   parse-word header
        !          1499:   instance? if
        !          1500:     2 /n* d , instance,                 \ DOIDEFER
        !          1501:     ['] (undefined-idefer)
        !          1502:   else
        !          1503:     5 ,
        !          1504:     ['] (undefined-defer)
        !          1505:   then
        !          1506:   ,
        !          1507:   ['] (semis) ,
        !          1508:   reveal
        !          1509:   ;
        !          1510: 
        !          1511: : alias  (  new-name< >old-name< >  -- )
        !          1512:   parse-word
        !          1513:   parse-word $find if
        !          1514:     -rot                     \ move xt behind.
        !          1515:     header
        !          1516:     1 ,                      \ fixme we want our own cfa here.
        !          1517:     ,                        \ compile old name xt
        !          1518:     ['] (semis) ,
        !          1519:     reveal
        !          1520:   else
        !          1521:     s" undefined word " type type space
        !          1522:     2drop
        !          1523:   then
        !          1524:   ;
        !          1525: 
        !          1526: : $create
        !          1527:   header 6 ,
        !          1528:   ['] noop ,
        !          1529:   reveal
        !          1530:   ;
        !          1531: 
        !          1532: : create
        !          1533:   parse-word $create
        !          1534:   ;
        !          1535: 
        !          1536: : (does>)
        !          1537:   r> cell+              \ get address of code to execute
        !          1538:   latest @              \ backlink of just "create"d word
        !          1539:   cell+ cell+ !         \ write code to execute after the
        !          1540:                         \ new word's CFA
        !          1541:   ;
        !          1542: 
        !          1543: : does>
        !          1544:   ['] (does>) ,         \ compile does handling
        !          1545:   1 ,                   \ compile docol
        !          1546:   ; immediate
        !          1547: 
        !          1548: 0 constant struct
        !          1549: 
        !          1550: : field
        !          1551:   create
        !          1552:     over ,
        !          1553:     +
        !          1554:   does>
        !          1555:     @ +
        !          1556:   ;
        !          1557: 
        !          1558: : 2constant
        !          1559:   create , ,
        !          1560:   does> 2@ reveal
        !          1561:   ;
        !          1562: 
        !          1563: \ 
        !          1564: \ initializer for the temporary compile buffer
        !          1565: \ 
        !          1566: 
        !          1567: : init-tmp-comp
        !          1568:   here 200 allot tmp-comp-buf !
        !          1569: ;
        !          1570: 
        !          1571: \ the end

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.