File:  [gforth] / gforth / kernel / comp-ec.fs
Revision 1.4: download - view: text, annotated - select for diffs
Mon Dec 31 15:25:19 2012 UTC (9 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year

    1: \ compiler definitions						14sep97jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: \ \ Revisions-Log
   21: 
   22: \	put in seperate file				14sep97jaw	
   23: 
   24: \ \ here allot , c, A,						17dec92py
   25: 
   26: [IFUNDEF] allot
   27: [IFUNDEF] forthstart
   28: : allot ( n -- ) \ core
   29:     dup unused u> -8 and throw
   30:     dp +! ;
   31: [THEN]
   32: [THEN]
   33: 
   34: \ we default to this version if we have nothing else 05May99jaw
   35: [IFUNDEF] allot
   36: : allot ( n -- ) \ core
   37:     \G Reserve @i{n} address units of data space without
   38:     \G initialization. @i{n} is a signed number, passing a negative
   39:     \G @i{n} releases memory.  In ANS Forth you can only deallocate
   40:     \G memory from the current contiguous region in this way.  In
   41:     \G Gforth you can deallocate anything in this way but named words.
   42:     \G The system does not check this restriction.
   43:     here +
   44:     dup 1- usable-dictionary-end forthstart within -8 and throw
   45:     dp ! ;
   46: [THEN]
   47: 
   48: : c,    ( c -- ) \ core c-comma
   49:     \G Reserve data space for one char and store @i{c} in the space.
   50:     here 1 chars allot [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;
   51: 
   52: : ,     ( w -- ) \ core comma
   53:     \G Reserve data space for one cell and store @i{w} in the space.
   54:     here cell allot [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;
   55: 
   56: : 2,	( w1 w2 -- ) \ gforth
   57:     \G Reserve data space for two cells and store the double @i{w1
   58:     \G w2} there, @i{w2} first (lower address).
   59:     here 2 cells allot  [ has? flash [IF] ] tuck flash! cell+ flash!
   60: 	[ [ELSE] ] 2! [ [THEN] ] ;
   61: 
   62: \ : aligned ( addr -- addr' ) \ core
   63: \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   64: 
   65: : align ( -- ) \ core
   66:     \G If the data-space pointer is not aligned, reserve enough space to align it.
   67:     here dup aligned swap ?DO  bl c,  LOOP ;
   68: 
   69: : maxalign ( -- ) \ gforth
   70:     \G Align data-space pointer for all alignment requirements.
   71:     here dup maxaligned swap
   72:     ?DO
   73: 	bl c,
   74:     LOOP ;
   75: 
   76: \ the code field is aligned if its body is maxaligned
   77: ' maxalign Alias cfalign ( -- ) \ gforth
   78: \G Align data-space pointer for code field requirements (i.e., such
   79: \G that the corresponding body is maxaligned).
   80: 
   81: ' , alias A, ( addr -- ) \ gforth
   82: 
   83: ' NOOP ALIAS const
   84: 
   85: \ \ Header							23feb93py
   86: 
   87: \ input-stream, nextname and noname are quite ugly (passing
   88: \ information through global variables), but they are useful for dealing
   89: \ with existing/independent defining words
   90: 
   91: : string, ( c-addr u -- ) \ gforth
   92:     \G puts down string as cstring
   93:     dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,
   94: [ has? flash [IF] ]
   95:     bounds ?DO  I c@ c,  LOOP
   96: [ [ELSE] ]
   97:     here swap chars dup allot move
   98: [ [THEN] ] ;
   99: 
  100: : longstring, ( c-addr u -- ) \ gforth
  101:     \G puts down string as longcstring
  102:     dup , here swap chars dup allot move ;
  103: 
  104: [IFDEF] prelude-mask
  105: variable next-prelude
  106: 
  107: : prelude, ( -- )
  108:     next-prelude @ if
  109: 	align next-prelude @ ,
  110:     then ;
  111: [THEN]
  112: 
  113: : header, ( c-addr u -- ) \ gforth
  114:     name-too-long?
  115:     dup max-name-length @ max max-name-length !
  116:     [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
  117:     align here last !
  118:     -1 A,
  119:     string,
  120:     cfalign ;
  121: 
  122: : header ( "name" -- )
  123:     parse-name name-too-short? header, ;
  124: 
  125: : latestxt ( -- xt ) \ gforth
  126:     \G @i{xt} is the execution token of the last word defined.
  127:     \ The main purpose of this word is to get the xt of words defined using noname
  128:     lastcfa @ ;
  129: 
  130: : latest ( -- nt ) \ gforth
  131: \G @var{nt} is the name token of the last word defined; it is 0 if the
  132: \G last word has no name.
  133:     last @ ;
  134: 
  135: \ \ literals							17dec92py
  136: 
  137: : Literal  ( compilation n -- ; run-time -- n ) \ core
  138:     \G Compilation semantics: compile the run-time semantics.@*
  139:     \G Run-time Semantics: push @i{n}.@*
  140:     \G Interpretation semantics: undefined.
  141: [ [IFDEF] lit, ]
  142:     lit,
  143: [ [ELSE] ]
  144:     postpone lit ,
  145: [ [THEN] ] ; immediate restrict
  146: 
  147: : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
  148:     \G Compile appropriate code such that, at run-time, @i{w1 w2} are
  149:     \G placed on the stack. Interpretation semantics are undefined.
  150:     swap postpone Literal  postpone Literal ; immediate restrict
  151: 
  152: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
  153: [ [IFDEF] alit, ]
  154:     alit,
  155: [ [ELSE] ]
  156:     postpone lit A, 
  157: [ [THEN] ] ; immediate restrict
  158: 
  159: Defer char@ ( addr u -- char addr' u' )
  160: :noname  over c@ -rot 1 /string ; IS char@
  161: 
  162: : char   ( '<spaces>ccc' -- c ) \ core
  163:     \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
  164:     \G display code representing the first character of @i{ccc}.
  165:     parse-name char@ 2drop ;
  166: 
  167: : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
  168:     \G Compilation: skip leading spaces. Parse the string
  169:     \G @i{ccc}. Run-time: return @i{c}, the display code
  170:     \G representing the first character of @i{ccc}.  Interpretation
  171:     \G semantics for this word are undefined.
  172:     char postpone Literal ; immediate restrict
  173: 
  174: \ \ threading							17mar93py
  175: 
  176: : cfa,     ( code-address -- )  \ gforth	cfa-comma
  177:     here
  178:     dup lastcfa !
  179:     [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]
  180:     code-address! ;
  181: 
  182: [IFUNDEF] compile,
  183: defer compile, ( xt -- )	\ core-ext	compile-comma
  184: \G  Compile the word represented by the execution token @i{xt}
  185: \G  into the current definition.
  186: 
  187: ' , is compile,
  188: [THEN]
  189: 
  190: ' , is compile,
  191: 
  192: : !does    ( addr -- ) \ gforth	store-does
  193:     latestxt does-code! ;
  194: 
  195: : (compile) ( -- ) \ gforth-obsolete: dummy
  196:     true abort" (compile) doesn't work, use POSTPONE instead" ;
  197: 
  198: \ \ ticks
  199: 
  200: : name>comp ( nt -- w xt ) \ gforth name-to-comp
  201:     \G @i{w xt} is the compilation token for the word @i{nt}.
  202:     (name>comp)
  203:     1 = if
  204:         ['] execute
  205:     else
  206:         ['] compile,
  207:     then ;
  208: 
  209: : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
  210:     (') postpone ALiteral ; immediate restrict
  211: 
  212: : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
  213:     \g @i{xt} represents @i{name}'s interpretation
  214:     \g semantics. Perform @code{-14 throw} if the word has no
  215:     \g interpretation semantics.
  216:     ' postpone ALiteral ; immediate restrict
  217: 
  218: : COMP'    ( "name" -- w xt ) \ gforth  comp-tick
  219:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  220:     (') name>comp ;
  221: 
  222: : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
  223:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  224:     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
  225: 
  226: : postpone, ( w xt -- ) \ gforth	postpone-comma
  227:     \g Compile the compilation semantics represented by the
  228:     \g compilation token @i{w xt}.
  229:     dup ['] execute =
  230:     if
  231: 	drop compile,
  232:     else
  233: 	swap POSTPONE aliteral compile,
  234:     then ;
  235: 
  236: : POSTPONE ( "name" -- ) \ core
  237:     \g Compiles the compilation semantics of @i{name}.
  238:     COMP' postpone, ; immediate
  239: 
  240: \ \ recurse							17may93jaw
  241: 
  242: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
  243:     \g Call the current definition.
  244:     latestxt compile, ; immediate restrict
  245: 
  246: \ \ compiler loop
  247: 
  248: : compiler1 ( c-addr u -- ... xt )
  249:     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
  250:     if ( c-addr u nt )
  251: 	nip nip name>comp
  252:     else
  253: 	drop
  254: 	2dup 2>r snumber? dup
  255: 	IF
  256: 	    0>
  257: 	    IF
  258: 		['] 2literal
  259: 	    ELSE
  260: 		['] literal
  261: 	    THEN
  262: 	    2rdrop
  263: 	ELSE
  264: 	    drop 2r> compiler-notfound1
  265: 	THEN
  266:     then ;
  267: 
  268: : [ ( -- ) \  core	left-bracket
  269:     \G Enter interpretation state. Immediate word.
  270:     ['] interpreter1  IS parser1 state off ; immediate
  271: 
  272: : ] ( -- ) \ core	right-bracket
  273:     \G Enter compilation state.
  274:     ['] compiler1     IS parser1 state on  ;
  275: 
  276: \ \ Strings							22feb93py
  277: 
  278: : S, ( addr u -- )
  279:     \ allot string as counted string
  280: [ has? flash [IF] ]
  281:     dup c, bounds ?DO  I c@ c,  LOOP
  282: [ [ELSE] ]
  283:     here over char+ allot  place align
  284: [ [THEN] ] ;
  285: 
  286: : mem, ( addr u -- )
  287:     \ allot the memory block HERE (do alignment yourself)
  288: [ has? flash [IF] ]
  289:     bounds ?DO  I c@ c,  LOOP
  290: [ [ELSE] ]
  291:     here over allot swap move
  292: [ [THEN] ] ;
  293: 
  294: : ," ( "string"<"> -- )
  295:     [char] " parse s, ;
  296: 
  297: \ \ Header states						23feb93py
  298: 
  299: \ problematic only for big endian machines
  300: 
  301: : cset ( bmask c-addr -- )
  302:     tuck c@ or swap c! ; 
  303: 
  304: : creset ( bmask c-addr -- )
  305:     tuck c@ swap invert and swap c! ; 
  306: 
  307: : ctoggle ( bmask c-addr -- )
  308:     tuck c@ xor swap c! ; 
  309: 
  310: : lastflags ( -- c-addr )
  311:     \ the address of the flags byte in the last header
  312:     \ aborts if the last defined word was headerless
  313:     latest dup 0= abort" last word was headerless" cell+ ;
  314: 
  315: : immediate ( -- ) \ core
  316:     \G Make the compilation semantics of a word be to @code{execute}
  317:     \G the execution semantics.
  318:     immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
  319: 
  320: : restrict ( -- ) \ gforth
  321:     \G A synonym for @code{compile-only}
  322:     restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
  323: 
  324: ' restrict alias compile-only ( -- ) \ gforth
  325: \G Remove the interpretation semantics of a word.
  326: 
  327: \ \ Create Variable User Constant                        	17mar93py
  328: 
  329: : Alias    ( xt "name" -- ) \ gforth
  330:     Header reveal
  331:     alias-mask lastflags creset
  332:     dup A, lastcfa ! ;
  333: 
  334: doer? :dovar [IF]
  335: 
  336: : Create ( "name" -- ) \ core
  337:     Header reveal dovar: cfa, ;
  338: [ELSE]
  339: 
  340: : Create ( "name" -- ) \ core
  341:     Header reveal here lastcfa ! 0 A, 0 , DOES> ;
  342: [THEN]
  343: 
  344: : buffer: ( u "name" -- ) \ core ext
  345:     Create allot ;
  346: 
  347: has? flash [IF]
  348:     : (variable) dpp @ normal-dp = IF  Create dpp @
  349: 	ELSE  normal-dp @ Constant dpp @ ram  THEN ;
  350: : Variable ( "name" -- ) \ core
  351:     (Variable) 0 , dpp ! ;
  352: 
  353: : 2Variable ( "name" -- ) \ double two-variable
  354:     (Variable) 0 , 0 , dpp ! ;
  355: [ELSE]
  356: : Variable ( "name" -- ) \ core
  357:     Create 0 , ;
  358: 
  359: : 2Variable ( "name" -- ) \ double two-variable
  360:     Create 0 , 0 , ;
  361: [THEN]
  362: 
  363: has? no-userspace 0= [IF]
  364: : uallot ( n -- ) \ gforth
  365:     udp @ swap udp +! ;
  366: 
  367: doer? :douser [IF]
  368: 
  369: : User ( "name" -- ) \ gforth
  370:     Header reveal douser: cfa, cell uallot , ;
  371: [ELSE]
  372: 
  373: : User Create cell uallot , DOES> @ up @ + ;
  374: [THEN]
  375: [THEN]
  376: 
  377: doer? :docon [IF]
  378:     : (Constant)  Header reveal docon: cfa, ;
  379: [ELSE]
  380:     : (Constant)  Create DOES> @ ;
  381: [THEN]
  382: 
  383: doer? :dovalue [IF]
  384:     : (Value)  Header reveal dovalue: cfa, ;
  385: [ELSE]
  386:     has? rom [IF]
  387: 	: (Value)  Create DOES> @ @ ;
  388:     [ELSE]
  389: 	: (Value)  Create DOES> @ ;
  390:     [THEN]
  391: [THEN]
  392: 
  393: : Constant ( w "name" -- ) \ core
  394:     \G Define a constant @i{name} with value @i{w}.
  395:     \G  
  396:     \G @i{name} execution: @i{-- w}
  397:     (Constant) , ;
  398: 
  399: : AConstant ( addr "name" -- ) \ gforth
  400:     (Constant) A, ;
  401: 
  402: has? flash [IF]
  403: : Value ( w "name" -- ) \ core-ext
  404:     (Value) dpp @ >r here cell allot >r
  405:     ram here >r , r> r> flash! r> dpp ! ;
  406: 
  407: ' Value alias AValue
  408: [ELSE]
  409: : Value ( w "name" -- ) \ core-ext
  410:     (Value) , ;
  411: [THEN]
  412: 
  413: : 2Constant ( w1 w2 "name" -- ) \ double two-constant
  414:     Create ( w1 w2 "name" -- )
  415:         2,
  416:     DOES> ( -- w1 w2 )
  417:         2@ ;
  418:     
  419: doer? :dofield [IF]
  420:     : (Field)  Header reveal dofield: cfa, ;
  421: [ELSE]
  422:     : (Field)  Create DOES> @ + ;
  423: [THEN]
  424: 
  425: \ \ interpret/compile:
  426: 
  427: struct
  428:     >body
  429:     cell% field interpret/compile-int
  430:     cell% field interpret/compile-comp
  431: end-struct interpret/compile-struct
  432: 
  433: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
  434:     Create immediate swap A, A,
  435: DOES>
  436:     abort" executed primary cfa of an interpret/compile: word" ;
  437: \    state @ IF  cell+  THEN  perform ;
  438: 
  439: \ IS Defer What's Defers TO                            24feb93py
  440: 
  441: defer defer-default ( -- )
  442: ' abort is defer-default
  443: \ default action for deferred words (overridden by a warning later)
  444:     
  445: doer? :dodefer [IF]
  446: 
  447: : Defer ( "name" -- ) \ gforth
  448: \G Define a deferred word @i{name}; its execution semantics can be
  449: \G set with @code{defer!} or @code{is} (and they have to, before first
  450: \G executing @i{name}.
  451:     Header Reveal dodefer: cfa,
  452:     [ has? rom [IF] ] here >r cell allot
  453:     dpp @ ram here r> flash! ['] defer-default A, dpp !
  454:     [ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
  455: 
  456: [ELSE]
  457: 
  458:     has? rom [IF]
  459: 	: Defer ( "name" -- ) \ gforth
  460: 	    Create here >r cell allot
  461: 	    dpp @ ram here r> flash! ['] defer-default A, dpp !
  462: 	  DOES> @ @ execute ;
  463:     [ELSE]
  464: 	: Defer ( "name" -- ) \ gforth
  465: 	    Create ['] defer-default A,
  466: 	  DOES> @ execute ;
  467:     [THEN]
  468: [THEN]
  469: 
  470: : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
  471: \G @i{xt} represents the word currently associated with the deferred
  472: \G word @i{xt-deferred}.
  473:     >body @ [ has? rom [IF] ] @ [ [THEN] ] ;
  474: 
  475: : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
  476:     \G Compiles the present contents of the deferred word @i{name}
  477:     \G into the current definition.  I.e., this produces static
  478:     \G binding as if @i{name} was not deferred.
  479:     ' defer@ compile, ; immediate
  480: 
  481: : does>-like ( xt -- )
  482:     \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
  483:     \ that should be stored right after the code address.
  484:     >r ;-hook ?struc
  485:     [ has? xconds [IF] ] exit-like [ [THEN] ]
  486:     here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
  487:     postpone aliteral r> compile, [compile] exit
  488:     [ has? peephole [IF] ] finish-code [ [THEN] ]
  489:     defstart ;
  490: 
  491: :noname
  492:     here !does ]
  493:     defstart :-hook ;
  494: :noname
  495:     ['] !does does>-like :-hook ;
  496: interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does
  497: 
  498: : defer! ( xt xt-deferred -- ) \ gforth  defer-store
  499: \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
  500:     >body [ has? rom [IF] ] @ [ [THEN] ] ! ;
  501:     
  502: : <IS> ( "name" xt -- ) \ gforth
  503:     \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
  504:     ' defer! ;
  505: 
  506: : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
  507:     \g At run-time, changes the @code{defer}red word @var{name} to
  508:     \g execute @var{xt}.
  509:     ' postpone ALiteral postpone defer! ; immediate restrict
  510: 
  511: ' <IS>
  512: ' [IS]
  513: interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
  514: \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
  515: \G Its compilation semantics parses at compile time.
  516: 
  517: ' <IS>
  518: ' [IS]
  519: interpret/compile: TO ( w "name" -- ) \ core-ext
  520: 
  521: : interpret/compile? ( xt -- flag )
  522:     >does-code ['] DOES> >does-code = ;
  523: 
  524: \ \ : ;                                                  	24feb93py
  525: 
  526: defer :-hook ( sys1 -- sys2 )
  527: 
  528: defer ;-hook ( sys2 -- sys1 )
  529: 
  530: 0 Constant defstart
  531: 
  532: [IFDEF] docol,
  533: : (:noname) ( -- colon-sys )
  534:     \ common factor of : and :noname
  535:     docol, ]comp
  536: [ELSE]
  537: : (:noname) ( -- colon-sys )
  538:     \ common factor of : and :noname
  539:     docol: cfa,
  540: [THEN]
  541:     defstart ] :-hook ;
  542: 
  543: : : ( "name" -- colon-sys ) \ core	colon
  544:     Header (:noname) ;
  545: 
  546: : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
  547:     0 last !
  548:     cfalign here (:noname) ;
  549: 
  550: [IFDEF] fini,
  551: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core   semicolon
  552:     ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
  553: [ELSE]
  554: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
  555:     ;-hook ?struc [compile] exit
  556:     [ has? peephole [IF] ] finish-code [ [THEN] ]
  557:     reveal postpone [ ; immediate restrict
  558: [THEN]
  559: 
  560: \ \ Search list handling: reveal words, recursive		23feb93py
  561: 
  562: : last?   ( -- false / nfa nfa )
  563:     latest ?dup ;
  564: 
  565: Variable warnings ( -- addr ) \ gforth
  566: G -1 warnings T !
  567: 
  568: : reveal ( -- ) \ gforth
  569:     last?
  570:     if \ the last word has a header
  571: 	dup ( name>link ) @ -1 =
  572: 	if \ it is still hidden
  573: 	    forth-wordlist dup >r @ over
  574: 	    [ has? flash [IF] ] flash! [ [ELSE] ] ! [  [THEN] ] r> !
  575: 	else
  576: 	    drop
  577: 	then
  578:     then ;
  579: 
  580: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
  581: \g Make the current definition visible, enabling it to call itself
  582: \g recursively.
  583: 	immediate restrict

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