Annotation of gforth/kernel/comp.fs, revision 1.1
1.1 ! pazsan 1: \ compiler definitions 14sep97jaw
! 2:
! 3: \ \ Revisions-Log
! 4:
! 5: \ put in seperate file 14sep97jaw
! 6:
! 7: \ \ here allot , c, A, 17dec92py
! 8:
! 9: : allot ( n -- ) \ core
! 10: dup unused u> -8 and throw
! 11: dp +! ;
! 12:
! 13: : c, ( c -- ) \ core
! 14: here 1 chars allot c! ;
! 15:
! 16: : , ( x -- ) \ core
! 17: here cell allot ! ;
! 18:
! 19: : 2, ( w1 w2 -- ) \ gforth
! 20: here 2 cells allot 2! ;
! 21:
! 22: \ : aligned ( addr -- addr' ) \ core
! 23: \ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
! 24:
! 25: : align ( -- ) \ core
! 26: here dup aligned swap ?DO bl c, LOOP ;
! 27:
! 28: \ : faligned ( addr -- f-addr ) \ float
! 29: \ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
! 30:
! 31: : falign ( -- ) \ float
! 32: here dup faligned swap
! 33: ?DO
! 34: bl c,
! 35: LOOP ;
! 36:
! 37: : maxalign ( -- ) \ float
! 38: here dup maxaligned swap
! 39: ?DO
! 40: bl c,
! 41: LOOP ;
! 42:
! 43: \ the code field is aligned if its body is maxaligned
! 44: ' maxalign Alias cfalign ( -- ) \ gforth
! 45:
! 46: ' , alias A, ( addr -- ) \ gforth
! 47:
! 48: ' NOOP ALIAS const
! 49:
! 50: \ \ Header 23feb93py
! 51:
! 52: \ input-stream, nextname and noname are quite ugly (passing
! 53: \ information through global variables), but they are useful for dealing
! 54: \ with existing/independent defining words
! 55:
! 56: defer (header)
! 57: defer header ( -- ) \ gforth
! 58: ' (header) IS header
! 59:
! 60: : string, ( c-addr u -- ) \ gforth
! 61: \G puts down string as cstring
! 62: dup c, here swap chars dup allot move ;
! 63:
! 64: : header, ( c-addr u -- ) \ gforth
! 65: name-too-long?
! 66: align here last !
! 67: current @ 1 or A, \ link field; before revealing, it contains the
! 68: \ tagged reveal-into wordlist
! 69: string, cfalign
! 70: alias-mask lastflags cset ;
! 71:
! 72: : input-stream-header ( "name" -- )
! 73: name name-too-short? header, ;
! 74:
! 75: : input-stream ( -- ) \ general
! 76: \G switches back to getting the name from the input stream ;
! 77: ['] input-stream-header IS (header) ;
! 78:
! 79: ' input-stream-header IS (header)
! 80:
! 81: \ !! make that a 2variable
! 82: create nextname-buffer 32 chars allot
! 83:
! 84: : nextname-header ( -- )
! 85: nextname-buffer count header,
! 86: input-stream ;
! 87:
! 88: \ the next name is given in the string
! 89:
! 90: : nextname ( c-addr u -- ) \ gforth
! 91: name-too-long?
! 92: nextname-buffer c! ( c-addr )
! 93: nextname-buffer count move
! 94: ['] nextname-header IS (header) ;
! 95:
! 96: : noname-header ( -- )
! 97: 0 last ! cfalign
! 98: input-stream ;
! 99:
! 100: : noname ( -- ) \ gforth
! 101: \ the next defined word remains anonymous. The xt of that word is given by lastxt
! 102: ['] noname-header IS (header) ;
! 103:
! 104: : lastxt ( -- xt ) \ gforth
! 105: \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
! 106: lastcfa @ ;
! 107:
! 108: \ \ literals 17dec92py
! 109:
! 110: : Literal ( compilation n -- ; run-time -- n ) \ core
! 111: postpone lit , ; immediate restrict
! 112:
! 113: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
! 114: postpone lit A, ; immediate restrict
! 115:
! 116: : char ( 'char' -- n ) \ core
! 117: bl word char+ c@ ;
! 118:
! 119: : [char] ( compilation 'char' -- ; run-time -- n )
! 120: char postpone Literal ; immediate restrict
! 121:
! 122: \ \ threading 17mar93py
! 123:
! 124: : cfa, ( code-address -- ) \ gforth cfa-comma
! 125: here
! 126: dup lastcfa !
! 127: 0 A, 0 , code-address! ;
! 128:
! 129: : compile, ( xt -- ) \ core-ext compile-comma
! 130: A, ;
! 131:
! 132: : !does ( addr -- ) \ gforth store-does
! 133: lastxt does-code! ;
! 134:
! 135: : (does>) ( R: addr -- )
! 136: r> cfaligned /does-handler + !does ;
! 137:
! 138: : dodoes, ( -- )
! 139: cfalign here /does-handler allot does-handler! ;
! 140:
! 141: : (compile) ( -- ) \ gforth
! 142: r> dup cell+ >r @ compile, ;
! 143:
! 144: : postpone, ( w xt -- )
! 145: \g Compiles the compilation semantics represented by @var{w xt}.
! 146: dup ['] execute =
! 147: if
! 148: drop compile,
! 149: else
! 150: dup ['] compile, =
! 151: if
! 152: drop POSTPONE (compile) compile,
! 153: else
! 154: swap POSTPONE aliteral compile,
! 155: then
! 156: then ;
! 157:
! 158: : POSTPONE ( "name" -- ) \ core
! 159: \g Compiles the compilation semantics of @var{name}.
! 160: COMP' postpone, ; immediate restrict
! 161:
! 162: struct
! 163: >body
! 164: cell% field interpret/compile-int
! 165: cell% field interpret/compile-comp
! 166: end-struct interpret/compile-struct
! 167:
! 168: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
! 169: Create immediate swap A, A,
! 170: DOES>
! 171: abort" executed primary cfa of an interpret/compile: word" ;
! 172: \ state @ IF cell+ THEN perform ;
! 173:
! 174: \ \ ticks
! 175:
! 176: : name>comp ( nt -- w xt ) \ gforth
! 177: \G @var{w xt} is the compilation token for the word @var{nt}.
! 178: (name>comp)
! 179: 1 = if
! 180: ['] execute
! 181: else
! 182: ['] compile,
! 183: then ;
! 184:
! 185: : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
! 186: (') postpone ALiteral ; immediate restrict
! 187:
! 188: : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
! 189: \g @var{xt} represents @var{name}'s interpretation
! 190: \g semantics. Performs @code{-14 throw} if the word has no
! 191: \g interpretation semantics.
! 192: ' postpone ALiteral ; immediate restrict
! 193:
! 194: : COMP' ( "name" -- w xt ) \ gforth c-tick
! 195: \g @var{w xt} represents @var{name}'s compilation semantics.
! 196: (') name>comp ;
! 197:
! 198: : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
! 199: \g @var{w xt} represents @var{name}'s compilation semantics.
! 200: COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
! 201:
! 202: \ \ recurse 17may93jaw
! 203:
! 204: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
! 205: \g calls the current definition.
! 206: lastxt compile, ; immediate restrict
! 207:
! 208: \ \ compiler loop
! 209:
! 210: : compiler ( c-addr u -- )
! 211: 2dup find-name dup
! 212: if ( c-addr u nt )
! 213: nip nip name>comp execute
! 214: else
! 215: drop
! 216: 2dup snumber? dup
! 217: IF
! 218: 0>
! 219: IF
! 220: swap postpone Literal
! 221: THEN
! 222: postpone Literal
! 223: 2drop
! 224: ELSE
! 225: drop compiler-notfound
! 226: THEN
! 227: then ;
! 228:
! 229: : [ ( -- ) \ core left-bracket
! 230: ['] interpreter IS parser state off ; immediate
! 231:
! 232: : ] ( -- ) \ core right-bracket
! 233: ['] compiler IS parser state on ;
! 234:
! 235: \ \ Strings 22feb93py
! 236:
! 237: : ," ( "string"<"> -- ) [char] " parse
! 238: here over char+ allot place align ;
! 239:
! 240: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
! 241: postpone (S") here over char+ allot place align ;
! 242: immediate restrict
! 243:
! 244: \ \ abort" 22feb93py
! 245:
! 246: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote
! 247: postpone (abort") ," ; immediate restrict
! 248:
! 249: \ \ Header states 23feb93py
! 250:
! 251: : cset ( bmask c-addr -- )
! 252: tuck c@ or swap c! ;
! 253:
! 254: : creset ( bmask c-addr -- )
! 255: tuck c@ swap invert and swap c! ;
! 256:
! 257: : ctoggle ( bmask c-addr -- )
! 258: tuck c@ xor swap c! ;
! 259:
! 260: : lastflags ( -- c-addr )
! 261: \ the address of the flags byte in the last header
! 262: \ aborts if the last defined word was headerless
! 263: last @ dup 0= abort" last word was headerless" cell+ ;
! 264:
! 265: : immediate ( -- ) \ core
! 266: immediate-mask lastflags cset ;
! 267:
! 268: : restrict ( -- ) \ gforth
! 269: restrict-mask lastflags cset ;
! 270: ' restrict alias compile-only ( -- ) \ gforth
! 271:
! 272: \ \ Create Variable User Constant 17mar93py
! 273:
! 274: : Alias ( cfa "name" -- ) \ gforth
! 275: Header reveal
! 276: alias-mask lastflags creset
! 277: dup A, lastcfa ! ;
! 278:
! 279: doer? :dovar [IF]
! 280:
! 281: : Create ( "name" -- ) \ core
! 282: Header reveal dovar: cfa, ;
! 283: [ELSE]
! 284:
! 285: : Create ( "name" -- ) \ core
! 286: Header reveal here lastcfa ! 0 A, 0 , DOES> ;
! 287: [THEN]
! 288:
! 289: : Variable ( "name" -- ) \ core
! 290: Create 0 , ;
! 291:
! 292: : AVariable ( "name" -- ) \ gforth
! 293: Create 0 A, ;
! 294:
! 295: : 2Variable ( "name" -- ) \ double
! 296: create 0 , 0 , ;
! 297:
! 298: : uallot ( n -- ) udp @ swap udp +! ;
! 299:
! 300: doer? :douser [IF]
! 301:
! 302: : User ( "name" -- ) \ gforth
! 303: Header reveal douser: cfa, cell uallot , ;
! 304:
! 305: : AUser ( "name" -- ) \ gforth
! 306: User ;
! 307: [ELSE]
! 308:
! 309: : User Create cell uallot , DOES> @ up @ + ;
! 310:
! 311: : AUser User ;
! 312: [THEN]
! 313:
! 314: doer? :docon [IF]
! 315: : (Constant) Header reveal docon: cfa, ;
! 316: [ELSE]
! 317: : (Constant) Create DOES> @ ;
! 318: [THEN]
! 319:
! 320: : Constant ( w "name" -- ) \ core
! 321: \G Defines constant @var{name}
! 322: \G
! 323: \G @var{name} execution: @var{-- w}
! 324: (Constant) , ;
! 325:
! 326: : AConstant ( addr "name" -- ) \ gforth
! 327: (Constant) A, ;
! 328:
! 329: : Value ( w "name" -- ) \ core-ext
! 330: (Constant) , ;
! 331:
! 332: : 2Constant ( w1 w2 "name" -- ) \ double
! 333: Create ( w1 w2 "name" -- )
! 334: 2,
! 335: DOES> ( -- w1 w2 )
! 336: 2@ ;
! 337:
! 338: doer? :dofield [IF]
! 339: : (Field) Header reveal dofield: cfa, ;
! 340: [ELSE]
! 341: : (Field) Create DOES> @ + ;
! 342: [THEN]
! 343: \ IS Defer What's Defers TO 24feb93py
! 344:
! 345: doer? :dodefer [IF]
! 346:
! 347: : Defer ( "name" -- ) \ gforth
! 348: \ !! shouldn't it be initialized with abort or something similar?
! 349: Header Reveal dodefer: cfa,
! 350: ['] noop A, ;
! 351: [ELSE]
! 352:
! 353: : Defer ( "name" -- ) \ gforth
! 354: Create ['] noop A,
! 355: DOES> @ execute ;
! 356: [THEN]
! 357:
! 358: : Defers ( "name" -- ) \ gforth
! 359: ' >body @ compile, ; immediate
! 360:
! 361: \ \ : ; 24feb93py
! 362:
! 363: defer :-hook ( sys1 -- sys2 )
! 364:
! 365: defer ;-hook ( sys2 -- sys1 )
! 366:
! 367: : : ( "name" -- colon-sys ) \ core colon
! 368: Header docol: cfa, defstart ] :-hook ;
! 369:
! 370: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
! 371: ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
! 372:
! 373: : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
! 374: 0 last !
! 375: cfalign here docol: cfa, 0 ] :-hook ;
! 376:
! 377: \ \ Search list handling: reveal words, recursive 23feb93py
! 378:
! 379: : last? ( -- false / nfa nfa )
! 380: last @ ?dup ;
! 381:
! 382: : (reveal) ( nt wid -- )
! 383: ( wid>wordlist-id ) dup >r
! 384: @ over ( name>link ) !
! 385: r> ! ;
! 386:
! 387: \ make entry in wordlist-map
! 388: ' (reveal) f83search reveal-method !
! 389:
! 390: Variable warnings ( -- addr ) \ gforth
! 391: G -1 warnings T !
! 392:
! 393: : check-shadow ( addr count wid -- )
! 394: \G prints a warning if the string is already present in the wordlist
! 395: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
! 396: ." redefined " name>string 2dup type
! 397: compare 0<> if
! 398: ." with " type
! 399: else
! 400: 2drop
! 401: then
! 402: space space EXIT
! 403: then
! 404: 2drop 2drop ;
! 405:
! 406: : reveal ( -- ) \ gforth
! 407: last?
! 408: if \ the last word has a header
! 409: dup ( name>link ) @ 1 and
! 410: if \ it is still hidden
! 411: dup ( name>link ) @ 1 xor ( nt wid )
! 412: 2dup >r name>string r> check-shadow ( nt wid )
! 413: dup wordlist-map @ reveal-method perform
! 414: else
! 415: drop
! 416: then
! 417: then ;
! 418:
! 419: : rehash ( wid -- )
! 420: dup wordlist-map @ rehash-method perform ;
! 421:
! 422: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
! 423: \g makes the current definition visible, enabling it to call itself
! 424: \g recursively.
! 425: immediate restrict
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to comp.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel