Return to fcode.fs CVS log

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

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

1.1     ! root        1: \ tag: FCode implementation functions
        !             2: \ 
        !             3: \ this code implements IEEE 1275-1994 ch. 5.3.3
        !             4: \ 
        !             5: \ Copyright (C) 2003 Stefan Reinauer
        !             6: \ 
        !             7: \ See the file "COPYING" for further information about
        !             8: \ the copyright and warranty status of this work.
        !             9: \ 
        !            10: 
        !            11: hex 
        !            12: 
        !            13: 0    value fcode-sys-table \ table with built-in fcodes (0-0x7ff)
        !            14: 
        !            15: true value ?fcode-offset16 \ fcode offsets are 16 instead of 8 bit?
        !            16: 1    value fcode-spread    \ fcode spread (1, 2 or 4)
        !            17: 0    value fcode-table     \ pointer to fcode table
        !            18: false value ?fcode-verbose  \ do verbose fcode execution?
        !            19: 
        !            20: defer _fcode-debug?        \ If true, save names for FCodes with headers
        !            21: true value fcode-headers?  \ If true, possibly save names for FCodes.
        !            22: 
        !            23: 0 value fcode-stream-start \ start address of fcode stream
        !            24: 0 value fcode-stream       \ current fcode stream address
        !            25: 
        !            26: variable fcode-end         \ state variable, if true, fcode program terminates.
        !            27: defer fcode-c@             \ get byte
        !            28: 
        !            29: : fcode-push-state ( -- <state information> )
        !            30:   ?fcode-offset16
        !            31:   fcode-spread
        !            32:   fcode-table
        !            33:   fcode-headers?
        !            34:   fcode-stream-start
        !            35:   fcode-stream
        !            36:   fcode-end @
        !            37:   ['] fcode-c@ behavior
        !            38: ;
        !            39: 
        !            40: : fcode-pop-state ( <state information> -- )
        !            41:   to fcode-c@
        !            42:   fcode-end !
        !            43:   to fcode-stream
        !            44:   to fcode-stream-start
        !            45:   to fcode-headers?
        !            46:   to fcode-table
        !            47:   to fcode-spread
        !            48:   to ?fcode-offset16
        !            49: ;
        !            50:   
        !            51: \ 
        !            52: \ fcode access helper functions
        !            53: \ 
        !            54: 
        !            55: \ fcode-ptr
        !            56: \   convert FCode number to pointer to xt in FCode table.
        !            57: 
        !            58: : fcode-ptr ( u16 -- *xt )
        !            59:   cells
        !            60:   fcode-table ?dup if + exit then
        !            61:   
        !            62:   \ we are not parsing fcode at the moment
        !            63:   dup 800 cells u>= abort" User FCODE# referenced."
        !            64:   fcode-sys-table +
        !            65: ;
        !            66:   
        !            67: \ fcode>xt
        !            68: \   get xt according to an FCode#
        !            69: 
        !            70: : fcode>xt ( u16 -- xt )
        !            71:   fcode-ptr @
        !            72:   ;
        !            73: 
        !            74: \ fcode-num8
        !            75: \   get 8bit from FCode stream, taking spread into regard.
        !            76: 
        !            77: : fcode-num8 ( -- c ) ( F: c -- )
        !            78:   fcode-stream
        !            79:   dup fcode-spread + to fcode-stream 
        !            80:   fcode-c@
        !            81:   ;
        !            82: 
        !            83: \ fcode-num8-signed ( -- c ) ( F: c -- )
        !            84: \   get 8bit signed from FCode stream
        !            85: 
        !            86: : fcode-num8-signed
        !            87:   fcode-num8
        !            88:   dup 80 and 0> if
        !            89:      ff invert or
        !            90:   then
        !            91:   ;
        !            92: 
        !            93: \ fcode-num16
        !            94: \   get 16bit from FCode stream
        !            95: 
        !            96: : fcode-num16 ( -- num16 )
        !            97:   fcode-num8 fcode-num8 swap bwjoin
        !            98:   ;
        !            99: 
        !           100: \ fcode-num16-signed ( -- c ) ( F: c -- )
        !           101: \   get 16bit signed from FCode stream
        !           102: 
        !           103: : fcode-num16-signed
        !           104:   fcode-num16
        !           105:   dup 8000 and 0> if
        !           106:      ffff invert or
        !           107:   then
        !           108:   ;
        !           109: 
        !           110: \ fcode-num32
        !           111: \   get 32bit from FCode stream
        !           112: 
        !           113: : fcode-num32 ( -- num32 )
        !           114:   fcode-num8 fcode-num8
        !           115:   fcode-num8 fcode-num8
        !           116:   swap 2swap swap bljoin
        !           117:   ;
        !           118:  
        !           119: \ fcode#
        !           120: \   Get an FCode# from FCode stream
        !           121: 
        !           122: : fcode# ( -- fcode# )
        !           123:   fcode-num8
        !           124:   dup 1 f between if
        !           125:     fcode-num8 swap bwjoin
        !           126:   then
        !           127:   ;
        !           128: 
        !           129: \ fcode-offset
        !           130: \   get offset from FCode stream.
        !           131: 
        !           132: : fcode-offset ( -- offset )
        !           133:   ?fcode-offset16 if
        !           134:     fcode-num16-signed
        !           135:   else
        !           136:     fcode-num8-signed
        !           137:   then
        !           138: 
        !           139:   \ Display offset in verbose mode
        !           140:   ?fcode-verbose if
        !           141:     dup ."        (offset) " . cr
        !           142:   then
        !           143:   ;
        !           144: 
        !           145: \ fcode-string
        !           146: \   get a string from FCode stream, store in pocket.
        !           147: 
        !           148: : fcode-string ( -- addr len )
        !           149:   pocket dup
        !           150:   fcode-num8
        !           151:   dup rot c!
        !           152:   2dup bounds ?do
        !           153:     fcode-num8 i c!
        !           154:   loop
        !           155: 
        !           156:   \ Display string in verbose mode
        !           157:   ?fcode-verbose if
        !           158:     2dup ."        (const) " type cr
        !           159:   then
        !           160:   ;
        !           161:     
        !           162: \ fcode-header
        !           163: \   retrieve FCode header from FCode stream
        !           164: 
        !           165: : fcode-header
        !           166:   fcode-num8
        !           167:   fcode-num16
        !           168:   fcode-num32
        !           169:   ?fcode-verbose if
        !           170:     ." Found FCode header:" cr rot
        !           171:     ."   Format   : " u. cr swap
        !           172:     ."   Checksum : " u. cr
        !           173:     ."   Length   : " u. cr
        !           174:   else
        !           175:     3drop
        !           176:   then
        !           177:   \ TODO checksum
        !           178:   ;
        !           179: 
        !           180: \ writes currently created word as fcode# read from stream
        !           181: \ 
        !           182: 
        !           183: : fcode! ( F:FCode# -- )
        !           184:   here fcode#
        !           185: 
        !           186:   \ Display fcode# in verbose mode
        !           187:   ?fcode-verbose if
        !           188:     dup ."        (fcode#) " . cr
        !           189:   then
        !           190:   fcode-ptr !
        !           191:   ;
        !           192: 
        !           193:   
        !           194: \ 
        !           195: \ 5.3.3.1 Defining new FCode functions.
        !           196: \ 
        !           197: 
        !           198: \ instance ( -- )   
        !           199: \   Mark next defining word as instance specific.
        !           200: \  (defined in bootstrap.fs)
        !           201: 
        !           202: \ instance-init ( wid buffer -- )
        !           203: \   Copy template from specified wordlist to instance
        !           204: \ 
        !           205: 
        !           206: : instance-init
        !           207:   swap
        !           208:   begin @ dup 0<> while
        !           209:     dup /n + @ instance-cfa? if         \ buffer dict
        !           210:       2dup 2 /n* + @ +                  \ buffer dict dest
        !           211:       over 3 /n* + @                    \ buffer dict dest size
        !           212:       2 pick 4 /n* +                    \ buffer dict dest size src
        !           213:       -rot
        !           214:       move
        !           215:     then
        !           216:   repeat
        !           217:   2drop
        !           218:   ;
        !           219: 
        !           220: 
        !           221: \ new-token ( F:/FCode#/ -- ) 
        !           222: \   Create a new unnamed FCode function
        !           223: 
        !           224: : new-token 
        !           225:   0 0 header
        !           226:   fcode!
        !           227:   ;
        !           228: 
        !           229:   
        !           230: \ named-token (F:FCode-string FCode#/ -- )
        !           231: \   Create a new possibly named FCode function.
        !           232: 
        !           233: : named-token 
        !           234:   fcode-string
        !           235:   _fcode-debug? not if
        !           236:     2drop 0 0
        !           237:   then
        !           238:   header
        !           239:   fcode!
        !           240:   ;
        !           241: 
        !           242:   
        !           243: \ external-token (F:/FCode-string FCode#/ -- )
        !           244: \   Create a new named FCode function
        !           245: 
        !           246: : external-token 
        !           247:   fcode-string header
        !           248:   fcode!
        !           249:   ;
        !           250: 
        !           251:   
        !           252: \ b(;) ( -- ) 
        !           253: \   End an FCode colon definition.
        !           254: 
        !           255: : b(;)
        !           256:   ['] ; execute
        !           257:   ; immediate
        !           258: 
        !           259: 
        !           260: \ b(:) ( -- ) ( E: ... -- ??? )
        !           261: \   Defines type of new FCode function as colon definition.
        !           262: 
        !           263: : b(:)
        !           264:   1 , ]
        !           265:   ;
        !           266: 
        !           267: 
        !           268: \ b(buffer:) ( size -- ) ( E:  -- a-addr )  
        !           269: \   Defines type of new FCode function as buffer:.
        !           270: 
        !           271: : b(buffer:)
        !           272:   4 , allot
        !           273:   reveal
        !           274:   ;
        !           275: 
        !           276: \ b(constant) ( nl -- ) ( E: -- nl )
        !           277: \   Defines type of new FCode function as constant.
        !           278: 
        !           279: : b(constant)
        !           280:   3 , , 
        !           281:   reveal
        !           282:   ;
        !           283: 
        !           284: 
        !           285: \ b(create) ( -- ) ( E: -- a-addr )
        !           286: \   Defines type of new FCode function as create word.
        !           287: 
        !           288: : b(create)
        !           289:   6 , 
        !           290:   ['] noop ,
        !           291:   reveal
        !           292:   ;
        !           293: 
        !           294: 
        !           295: \ b(defer) ( -- ) ( E: ... -- ??? )  
        !           296: \   Defines type of new FCode function as defer word.
        !           297: 
        !           298: : b(defer)
        !           299:   5 ,
        !           300:   ['] (undefined-defer) ,
        !           301:   ['] (semis) ,
        !           302:   reveal
        !           303:   ;
        !           304: 
        !           305: 
        !           306: \ b(field) ( offset size -- offset+size ) ( E: addr -- addr+offset )
        !           307: \   Defines type of new FCode function as field.
        !           308: 
        !           309: : b(field)
        !           310:   6 ,
        !           311:   ['] noop ,
        !           312:   reveal
        !           313:     over ,
        !           314:     +
        !           315:   does>
        !           316:     @ +
        !           317:   ;
        !           318: 
        !           319:   
        !           320: \ b(value) ( x -- ) (E: -- x )
        !           321: \   Defines type of new FCode function as value.
        !           322:   
        !           323: : b(value)
        !           324:   3 , , reveal
        !           325:   ;
        !           326: 
        !           327: 
        !           328: \ b(variable) ( -- ) ( E: -- a-addr )
        !           329: \   Defines type of new FCode function as variable.
        !           330: 
        !           331: : b(variable)
        !           332:   4 , 0 ,
        !           333:   reveal
        !           334:   ;
        !           335:   
        !           336:   
        !           337: \ (is-user-word) ( name-str name-len xt -- ) ( E: ... -- ??? )
        !           338: \   Create a new named user interface command.
        !           339: 
        !           340: : (is-user-word)
        !           341:   ;
        !           342: 
        !           343:   
        !           344: \ get-token ( fcode# -- xt immediate? )
        !           345: \   Convert FCode number to function execution token.
        !           346: 
        !           347: : get-token
        !           348:   fcode>xt dup immediate?
        !           349:   ;
        !           350: 
        !           351: 
        !           352: \ set-token ( xt immediate? fcode# -- )
        !           353: \   Assign FCode number to existing function.
        !           354:   
        !           355: : set-token
        !           356:   nip \ TODO we use the xt's immediate state for now.
        !           357:   fcode-ptr !
        !           358:   ;
        !           359: 
        !           360:   
        !           361:   
        !           362: 
        !           363: \ 
        !           364: \ 5.3.3.2 Literals
        !           365: \ 
        !           366: 
        !           367: 
        !           368: \ b(lit) ( -- n1 ) 
        !           369: \   Numeric literal FCode. Followed by FCode-num32.
        !           370: 
        !           371: 64bit? [IF]
        !           372: : b(lit)
        !           373:   fcode-num32 32>64
        !           374:   state @ if
        !           375:     ['] (lit) , ,
        !           376:   then
        !           377:   ; immediate
        !           378: [ELSE]
        !           379: : b(lit)
        !           380:   fcode-num32 
        !           381:   state @ if
        !           382:     ['] (lit) , ,
        !           383:   then
        !           384:   ; immediate
        !           385: [THEN]
        !           386: 
        !           387: 
        !           388: \ b(') ( -- xt )  
        !           389: \   Function literal FCode. Followed by FCode#
        !           390: 
        !           391: : b(')
        !           392:   fcode# fcode>xt
        !           393:   state @ if
        !           394:     ['] (lit) , , 
        !           395:   then
        !           396:   ; immediate
        !           397: 
        !           398:   
        !           399: \ b(") ( -- str len )
        !           400: \   String literal FCode. Followed by FCode-string.
        !           401:   
        !           402: : b(")
        !           403:   fcode-string
        !           404:   state @ if
        !           405:     \ only run handle-text in compile-mode,
        !           406:     \ otherwise we would waste a pocket.
        !           407:     handle-text
        !           408:   then
        !           409:   ; immediate
        !           410: 
        !           411: 
        !           412: \ 
        !           413: \ 5.3.3.3 Controlling values and defers
        !           414: \ 
        !           415: 
        !           416: \ behavior ( defer-xt -- contents-xt )
        !           417: \ defined in bootstrap.fs
        !           418: 
        !           419: \ b(to) ( new-value -- )
        !           420: \   FCode for setting values and defers. Followed by FCode#.
        !           421: 
        !           422: : b(to)
        !           423:   fcode# fcode>xt 
        !           424:   1 handle-lit
        !           425:   ['] (to)
        !           426:   state @ if 
        !           427:     ,
        !           428:   else
        !           429:     execute
        !           430:   then
        !           431:   ; immediate
        !           432: 
        !           433: 
        !           434: 
        !           435: \ 
        !           436: \ 5.3.3.4 Control flow
        !           437: \ 
        !           438: 
        !           439: 
        !           440: \ offset16 ( -- )
        !           441: \   Makes subsequent FCode-offsets use 16-bit (not 8-bit) form.
        !           442: 
        !           443: : offset16
        !           444:   true to ?fcode-offset16
        !           445:   ;
        !           446: 
        !           447: 
        !           448: \ bbranch ( -- )
        !           449: \   Unconditional branch FCode. Followed by FCode-offset.
        !           450:   
        !           451: : bbranch
        !           452:   fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
        !           453:     ['] dobranch ,
        !           454:     resolve-dest
        !           455:     execute-tmp-comp
        !           456:   else
        !           457:     setup-tmp-comp ['] dobranch ,
        !           458:     here 0
        !           459:     0 ,
        !           460:     2swap
        !           461:   then
        !           462:   ; immediate
        !           463: 
        !           464: 
        !           465: \ b?branch ( continue? -- )
        !           466: \   Conditional branch FCode. Followed by FCode-offset.
        !           467: 
        !           468: : b?branch
        !           469:   fcode-offset 0< if \ if we jump backwards, we can forsee where it goes
        !           470:     ['] do?branch ,
        !           471:     resolve-dest
        !           472:     execute-tmp-comp
        !           473:   else
        !           474:     setup-tmp-comp ['] do?branch ,
        !           475:     here 0
        !           476:     0 ,
        !           477:   then 
        !           478:   ; immediate
        !           479: 
        !           480:   
        !           481: \ b(<mark) ( -- )
        !           482: \   Target of backward branches.
        !           483: 
        !           484: : b(<mark)
        !           485:   setup-tmp-comp
        !           486:   here 1
        !           487:   ; immediate
        !           488: 
        !           489:   
        !           490: \ b(>resolve) ( -- )
        !           491: \   Target of forward branches.
        !           492: 
        !           493: : b(>resolve)
        !           494:   resolve-orig
        !           495:   execute-tmp-comp
        !           496:   ; immediate
        !           497: 
        !           498:   
        !           499: \ b(loop) ( -- )
        !           500: \   End FCode do..loop. Followed by FCode-offset.
        !           501: 
        !           502: : b(loop)
        !           503:   fcode-offset drop
        !           504:   postpone loop
        !           505:   ; immediate
        !           506: 
        !           507:   
        !           508: \ b(+loop) ( delta -- )
        !           509: \   End FCode do..+loop. Followed by FCode-offset.
        !           510: 
        !           511: : b(+loop)
        !           512:   fcode-offset drop
        !           513:   postpone +loop
        !           514:   ; immediate
        !           515: 
        !           516:   
        !           517: \ b(do) ( limit start -- )
        !           518: \   Begin FCode do..loop. Followed by FCode-offset.
        !           519: 
        !           520: : b(do)
        !           521:   fcode-offset drop
        !           522:   postpone do
        !           523:   ; immediate
        !           524: 
        !           525:   
        !           526: \ b(?do) ( limit start -- )
        !           527: \   Begin FCode ?do..loop. Followed by FCode-offset.
        !           528: 
        !           529: : b(?do)
        !           530:   fcode-offset drop
        !           531:   postpone ?do
        !           532:   ; immediate
        !           533: 
        !           534:   
        !           535: \ b(leave) ( -- )
        !           536: \   Exit from a do..loop.
        !           537:   
        !           538: : b(leave)
        !           539:   postpone leave
        !           540:   ; immediate
        !           541: 
        !           542:   
        !           543: \ b(case) ( sel -- sel )
        !           544: \   Begin a case (multiple selection) statement.
        !           545: 
        !           546: : b(case)
        !           547:   postpone case
        !           548:   ; immediate
        !           549: 
        !           550:   
        !           551: \ b(endcase) ( sel | <nothing> -- )
        !           552: \   End a case (multiple selection) statement.
        !           553: 
        !           554: : b(endcase)
        !           555:   postpone endcase
        !           556:   ; immediate
        !           557:   
        !           558: 
        !           559: \ b(of) ( sel of-val -- sel | <nothing> )
        !           560: \   FCode for of in case statement. Followed by FCode-offset.
        !           561: 
        !           562: : b(of)
        !           563:   fcode-offset drop
        !           564:   postpone of
        !           565:   ; immediate
        !           566: 
        !           567: \ b(endof) ( -- )
        !           568: \   FCode for endof in case statement. Followed by FCode-offset.
        !           569: 
        !           570: : b(endof)
        !           571:   fcode-offset drop
        !           572:   postpone endof
        !           573:   ; immediate

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