File:  [gforth] / gforth / kernel / int.fs
Revision 1.13: download - view: text, annotated - select for diffs
Sat Dec 19 13:43:18 1998 UTC (23 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, HEAD
markers now reset included-files
fixed another bug in marker
added/changed some comments

    1: \ definitions needed for interpreter only
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998 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 2
   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, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: \ \ Revision-Log
   22: 
   23: \       put in seperate file				14sep97jaw 
   24: 
   25: \ \ input stream primitives                       	23feb93py
   26: 
   27: : tib ( -- c-addr ) \ core-ext
   28:     \ obsolescent
   29:     >tib @ ;
   30: 
   31: Defer source ( -- addr count ) \ core
   32: \ used by dodefer:, must be defer
   33: 
   34: : (source) ( -- addr count )
   35:     tib #tib @ ;
   36: ' (source) IS source
   37: 
   38: : (word) ( addr1 n1 char -- addr2 n2 )
   39:   dup >r skip 2dup r> scan  nip - ;
   40: 
   41: \ (word) should fold white spaces
   42: \ this is what (parse-white) does
   43: 
   44: \ word parse                                           23feb93py
   45: 
   46: : sword  ( char -- addr len ) \ gforth
   47:   \G parses like @code{word}, but the output is like @code{parse} output
   48:   \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
   49:   \ dpANS6 A.6.2.2008 have a word with that name that behaves
   50:   \ differently (like NAME).
   51:   source 2dup >r >r >in @ over min /string
   52:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
   53:   2dup + r> - 1+ r> min >in ! ;
   54: 
   55: : word   ( char -- addr ) \ core
   56:   sword here place  bl here count + c!  here ;
   57: 
   58: : parse    ( char -- addr len ) \ core-ext
   59:   >r  source  >in @ over min /string  over  swap r>  scan >r
   60:   over - dup r> IF 1+ THEN  >in +! ;
   61: 
   62: \ name                                                 13feb93py
   63: 
   64: [IFUNDEF] (name) \ name might be a primitive
   65: 
   66: : (name) ( -- c-addr count )
   67:     source 2dup >r >r >in @ /string (parse-white)
   68:     2dup + r> - 1+ r> min >in ! ;
   69: \    name count ;
   70: [THEN]
   71: 
   72: : name-too-short? ( c-addr u -- c-addr u )
   73:     dup 0= -&16 and throw ;
   74: 
   75: : name-too-long? ( c-addr u -- c-addr u )
   76:     dup $1F u> -&19 and throw ;
   77: 
   78: \ \ Number parsing					23feb93py
   79: 
   80: \ number? number                                       23feb93py
   81: 
   82: hex
   83: const Create bases   10 ,   2 ,   A , 100 ,
   84: \                     16     2    10   character
   85: \ !! this saving and restoring base is an abomination! - anton
   86: 
   87: : getbase ( addr u -- addr' u' )
   88:     over c@ [char] $ - dup 4 u<
   89:     IF
   90: 	cells bases + @ base ! 1 /string
   91:     ELSE
   92: 	drop
   93:     THEN ;
   94: 
   95: : s>number ( addr len -- d )
   96:     base @ >r  dpl on
   97:     over c@ '- =  dup >r
   98:     IF
   99: 	1 /string
  100:     THEN
  101:     getbase  dpl on  0 0 2swap
  102:     BEGIN
  103: 	dup >r >number dup
  104:     WHILE
  105: 	dup r> -
  106:     WHILE
  107: 	dup dpl ! over c@ [char] . =
  108:     WHILE
  109: 	1 /string
  110:     REPEAT  THEN
  111:         2drop rdrop dpl off
  112:     ELSE
  113: 	2drop rdrop r>
  114: 	IF
  115: 	    dnegate
  116: 	THEN
  117:     THEN
  118:     r> base ! ;
  119: 
  120: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
  121:     s>number dpl @ 0=
  122:     IF
  123: 	2drop false  EXIT
  124:     THEN
  125:     dpl @ dup 0> 0= IF
  126: 	nip
  127:     THEN ;
  128: 
  129: : number? ( string -- string 0 / n -1 / d 0> )
  130:     dup >r count snumber? dup if
  131: 	rdrop
  132:     else
  133: 	r> swap
  134:     then ;
  135: 
  136: : number ( string -- d )
  137:     number? ?dup 0= abort" ?"  0<
  138:     IF
  139: 	s>d
  140:     THEN ;
  141: 
  142: \ \ Comments ( \ \G
  143: 
  144: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file	paren
  145:     [char] ) parse 2drop ; immediate
  146: 
  147: : \ ( -- ) \ core-ext backslash
  148:     [ has? file [IF] ]
  149:     blk @
  150:     IF
  151: 	>in @ c/l / 1+ c/l * >in !
  152: 	EXIT
  153:     THEN
  154:     [ [THEN] ]
  155:     source >in ! drop ; immediate
  156: 
  157: : \G ( -- ) \ gforth backslash
  158:     POSTPONE \ ; immediate
  159: 
  160: \ \ object oriented search list                         17mar93py
  161: 
  162: \ word list structure:
  163: 
  164: struct
  165:   cell% field find-method   \ xt: ( c_addr u wid -- nt )
  166:   cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
  167:   cell% field rehash-method \ xt: ( wid -- )	   \ re-initializes a "search-data" (hashtables)
  168:   cell% field hash-method   \ xt: ( wid -- )    \ initializes ""
  169: \   \ !! what else
  170: end-struct wordlist-map-struct
  171: 
  172: struct
  173:   cell% field wordlist-map \ pointer to a wordlist-map-struct
  174:   cell% field wordlist-id \ linked list of words (for WORDS etc.)
  175:   cell% field wordlist-link \ link field to other wordlists
  176:   cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
  177: end-struct wordlist-struct
  178: 
  179: : f83find      ( addr len wordlist -- nt / false )
  180:     wordlist-id @ (f83find) ;
  181: 
  182: : initvoc		( wid -- )
  183:   dup wordlist-map @ hash-method perform ;
  184: 
  185: \ Search list table: find reveal
  186: Create f83search ( -- wordlist-map )
  187:     ' f83find A,  ' drop A,  ' drop A, ' drop A,
  188: 
  189: here G f83search T A, NIL A, NIL A, NIL A,
  190: AValue forth-wordlist \ variable, will be redefined by search.fs
  191: 
  192: AVariable lookup       	forth-wordlist lookup !
  193: \ !! last is user and lookup?! jaw
  194: AVariable current ( -- addr ) \ gforth
  195: AVariable voclink	forth-wordlist wordlist-link voclink !
  196: lookup AValue context
  197: 
  198: forth-wordlist current !
  199: 
  200: \ \ header, finding, ticks                              17dec92py
  201: 
  202: $80 constant alias-mask \ set when the word is not an alias!
  203: $40 constant immediate-mask
  204: $20 constant restrict-mask
  205: 
  206: \ higher level parts of find
  207: 
  208: : flag-sign ( f -- 1|-1 )
  209:     \ true becomes 1, false -1
  210:     0= 2* 1+ ;
  211: 
  212: : compile-only-error ( ... -- )
  213:     -&14 throw ;
  214: 
  215: : (cfa>int) ( cfa -- xt )
  216: [ has? compiler [IF] ]
  217:     dup interpret/compile?
  218:     if
  219: 	interpret/compile-int @
  220:     then 
  221: [ [THEN] ] ;
  222: 
  223: : (x>int) ( cfa b -- xt )
  224:     \ get interpretation semantics of name
  225:     restrict-mask and
  226:     if
  227: 	drop ['] compile-only-error
  228:     else
  229: 	(cfa>int)
  230:     then ;
  231: 
  232: : name>string ( nt -- addr count ) \ gforth     head-to-string
  233:     \g @var{addr count} is the name of the word represented by @var{nt}.
  234:     cell+ count $1F and ;
  235: 
  236: : ((name>))  ( nfa -- cfa )
  237:     name>string + cfaligned ;
  238: 
  239: : (name>x) ( nfa -- cfa b )
  240:     \ cfa is an intermediate cfa and b is the flags byte of nfa
  241:     dup ((name>))
  242:     swap cell+ c@ dup alias-mask and 0=
  243:     IF
  244:         swap @ swap
  245:     THEN ;
  246: 
  247: : name>int ( nt -- xt ) \ gforth
  248:     \G @var{xt} represents the interpretation semantics of the word
  249:     \G @var{nt}. Produces @code{' compile-only-error} if
  250:     \G @var{nt} is compile-only.
  251:     (name>x) (x>int) ;
  252: 
  253: : name?int ( nt -- xt ) \ gforth
  254:     \G Like name>int, but throws an error if compile-only.
  255:     (name>x) restrict-mask and
  256:     if
  257: 	compile-only-error \ does not return
  258:     then
  259:     (cfa>int) ;
  260: 
  261: : (name>comp) ( nt -- w +-1 ) \ gforth
  262:     \G @var{w xt} is the compilation token for the word @var{nt}.
  263:     (name>x) >r 
  264: [ has? compiler [IF] ]
  265:     dup interpret/compile?
  266:     if
  267:         interpret/compile-comp @
  268:     then 
  269: [ [THEN] ]
  270:     r> immediate-mask and flag-sign
  271:     ;
  272: 
  273: : (name>intn) ( nfa -- xt +-1 )
  274:     (name>x) tuck (x>int) ( b xt )
  275:     swap immediate-mask and flag-sign ;
  276: 
  277: const Create ???  0 , 3 c, char ? c, char ? c, char ? c,
  278: \ ??? is used by dovar:, must be created/:dovar
  279: 
  280: : >head ( cfa -- nt ) \ gforth  to-name
  281:  $21 cell do
  282:    dup i - count $9F and + cfaligned over alias-mask + = if
  283:      i - cell - unloop exit
  284:    then
  285:  cell +loop
  286:  drop ??? ( wouldn't 0 be better? ) ;
  287: 
  288: ' >head ALIAS >name
  289: 
  290: : body> 0 >body - ;
  291: 
  292: : (search-wordlist)  ( addr count wid -- nt / false )
  293:     dup wordlist-map @ find-method perform ;
  294: 
  295: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
  296:     \ xt is the interpretation semantics
  297:     (search-wordlist) dup if
  298: 	(name>intn)
  299:     then ;
  300: 
  301: : find-name ( c-addr u -- nt/0 ) \ gforth
  302:     \g Find the name @var{c-addr u} in the current search
  303:     \g order. Return its nt, if found, otherwise 0.
  304:     lookup @ (search-wordlist) ;
  305: 
  306: : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
  307:     find-name dup
  308:     if ( nt )
  309: 	state @
  310: 	if
  311: 	    (name>comp)
  312: 	else
  313: 	    (name>intn)
  314: 	then
  315:    then ;
  316: 
  317: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
  318:     dup count sfind dup
  319:     if
  320: 	rot drop
  321:     then ;
  322: 
  323: \ ticks
  324: 
  325: : (') ( "name" -- nt ) \ gforth
  326:     name find-name dup 0=
  327:     IF
  328: 	drop -&13 bounce
  329:     THEN  ;
  330: 
  331: : '    ( "name" -- xt ) \ core	tick
  332:     \g @var{xt} represents @var{name}'s interpretation
  333:     \g semantics. Performs @code{-14 throw} if the word has no
  334:     \g interpretation semantics.
  335:     (') name?int ;
  336: 
  337: \ \ the interpreter loop				  mar92py
  338: 
  339: \ interpret                                            10mar92py
  340: 
  341: Defer parser
  342: Defer name ( -- c-addr count ) \ gforth
  343: \ get the next word from the input buffer
  344: ' (name) IS name
  345: Defer compiler-notfound ( c-addr count -- )
  346: Defer interpreter-notfound ( c-addr count -- )
  347: 
  348: : no.extensions  ( addr u -- )
  349:     2drop -&13 bounce ;
  350: ' no.extensions IS compiler-notfound
  351: ' no.extensions IS interpreter-notfound
  352: 
  353: : interpret ( ?? -- ?? ) \ gforth
  354:     \ interpret/compile the (rest of the) input buffer
  355:     BEGIN
  356: 	?stack name dup
  357:     WHILE
  358: 	parser
  359:     REPEAT
  360:     2drop ;
  361: 
  362: \ interpreter                                 	30apr92py
  363: 
  364: \ not the most efficient implementations of interpreter and compiler
  365: | : interpreter ( c-addr u -- ) 
  366:     2dup find-name dup
  367:     if
  368: 	nip nip name>int execute
  369:     else
  370: 	drop
  371: 	2dup 2>r snumber?
  372: 	IF
  373: 	    2rdrop
  374: 	ELSE
  375: 	    2r> interpreter-notfound
  376: 	THEN
  377:     then ;
  378: 
  379: ' interpreter  IS  parser
  380: 
  381: \ \ Query Evaluate                                 	07apr93py
  382: 
  383: has? file 0= [IF]
  384: : sourceline# ( -- n )  1 ;
  385: [THEN]
  386: 
  387: : refill ( -- flag ) \ core-ext,block-ext,file-ext
  388:     [ has? file [IF] ]
  389: 	blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
  390: 	[ [THEN] ]
  391:     tib /line
  392:     [ has? file [IF] ]
  393: 	loadfile @ ?dup
  394: 	IF    read-line throw
  395: 	ELSE
  396: 	    [ [THEN] ]
  397: 	sourceline# 0< IF 2drop false EXIT THEN
  398: 	accept true
  399: 	[ has? file [IF] ]
  400: 	THEN
  401: 	1 loadline +!
  402: 	[ [THEN] ]
  403:     swap #tib ! 0 >in ! ;
  404: 
  405: : query   ( -- ) \ core-ext
  406:     \G obsolescent
  407:     [ has? file [IF] ]
  408: 	blk off loadfile off
  409: 	[ [THEN] ]
  410:     tib /line accept #tib ! 0 >in ! ;
  411: 
  412: \ save-mem extend-mem
  413: 
  414: has? os [IF]
  415: : save-mem	( addr1 u -- addr2 u ) \ gforth
  416:     \g copy a memory block into a newly allocated region in the heap
  417:     swap >r
  418:     dup allocate throw
  419:     swap 2dup r> -rot move ;
  420: 
  421: : extend-mem	( addr1 u1 u -- addr addr2 u2 )
  422:     \ extend memory block allocated from the heap by u aus
  423:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr
  424:     over >r + dup >r resize throw
  425:     r> over r> + -rot ;
  426: [THEN]
  427: 
  428: \ EVALUATE                                              17may93jaw
  429: 
  430: has? file 0= [IF]
  431: : push-file  ( -- )  r>
  432:   tibstack @ >r  >tib @ >r  #tib @ >r
  433:   >tib @ tibstack @ = IF  r@ tibstack +!  THEN
  434:   tibstack @ >tib ! >in @ >r  >r ;
  435: 
  436: : pop-file   ( throw-code -- throw-code )
  437:   r>
  438:   r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
  439: [THEN]
  440: 
  441: : evaluate ( c-addr len -- ) \ core,block
  442:   push-file  #tib ! >tib !
  443:   >in off
  444:   [ has? file [IF] ]
  445:       blk off loadfile off -1 loadline !
  446:       [ [THEN] ]
  447:   ['] interpret catch
  448:   pop-file throw ;
  449: 
  450: \ \ Quit                                            	13feb93py
  451: 
  452: Defer 'quit
  453: 
  454: Defer .status
  455: 
  456: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
  457: 
  458: : (Query)  ( -- )
  459:     [ has? file [IF] ]
  460: 	loadfile off  blk off loadline off
  461: 	[ [THEN] ]
  462:     refill drop ;
  463: 
  464: : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
  465: 
  466: ' (quit) IS 'quit
  467: 
  468: \ \ DOERROR (DOERROR)                        		13jun93jaw
  469: 
  470: 8 Constant max-errors
  471: Variable error-stack  0 error-stack !
  472: max-errors 6 * cells allot
  473: \ format of one cell:
  474: \ source ( addr u )
  475: \ >in
  476: \ line-number
  477: \ Loadfilename ( addr u )
  478: 
  479: : dec. ( n -- ) \ gforth
  480:     \ print value in decimal representation
  481:     base @ decimal swap . base ! ;
  482: 
  483: : hex. ( u -- ) \ gforth
  484:     \ print value as unsigned hex number
  485:     '$ emit base @ swap hex u. base ! ;
  486: 
  487: : typewhite ( addr u -- ) \ gforth
  488:     \ like type, but white space is printed instead of the characters
  489:     bounds ?do
  490: 	i c@ #tab = if \ check for tab
  491: 	    #tab
  492: 	else
  493: 	    bl
  494: 	then
  495: 	emit
  496:     loop ;
  497: 
  498: DEFER DOERROR
  499: 
  500: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
  501:   cr error-stack @
  502:   IF
  503:      ." in file included from "
  504:      type ." :" dec.  drop 2drop
  505:   ELSE
  506:      type ." :" dec.
  507:      cr dup 2over type cr drop
  508:      nip -trailing 1- ( line-start index2 )
  509:      0 >r  BEGIN
  510:                   2dup + c@ bl >  WHILE
  511: 		  r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
  512:      ( line-start index1 )
  513:      typewhite
  514:      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
  515:                   [char] ^ emit
  516:      loop
  517:   THEN
  518: ;
  519: 
  520: : (DoError) ( throw-code -- )
  521:   [ has? os [IF] ]
  522:       >stderr
  523:   [ [THEN] ] 
  524:   sourceline# IF
  525:       source >in @ sourceline# 0 0 .error-frame
  526:   THEN
  527:   error-stack @ 0 ?DO
  528:     -1 error-stack +!
  529:     error-stack dup @ 6 * cells + cell+
  530:     6 cells bounds DO
  531:       I @
  532:     cell +LOOP
  533:     .error-frame
  534:   LOOP
  535:   dup -2 =
  536:   IF 
  537:      "error @ ?dup
  538:      IF
  539:         cr count type 
  540:      THEN
  541:      drop
  542:   ELSE
  543:      .error
  544:   THEN
  545:   normal-dp dpp ! ;
  546: 
  547: ' (DoError) IS DoError
  548: 
  549: : quit ( ?? -- ?? ) \ core
  550:     rp0 @ rp! handler off clear-tibstack >tib @ >r
  551:     BEGIN
  552: 	[ has? compiler [IF] ]
  553: 	postpone [
  554: 	[ [THEN] ]
  555: 	['] 'quit CATCH dup
  556:     WHILE
  557: 	DoError r@ >tib ! r@ tibstack !
  558:     REPEAT
  559:     drop r> >tib ! ;
  560: 
  561: \ \ Cold Boot                                    	13feb93py
  562: 
  563: : (bootmessage)
  564:     ." GForth " version-string type 
  565:     ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
  566:     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
  567: [ has? os [IF] ]
  568:      cr ." Type `bye' to exit"
  569: [ [THEN] ] ;
  570: 
  571: defer bootmessage
  572: defer process-args
  573: 
  574: ' (bootmessage) IS bootmessage
  575: 
  576: Defer 'cold ( -- ) \ gforth  tick-cold
  577: \ hook (deferred word) for things to do right before interpreting the
  578: \ command-line arguments
  579: ' noop IS 'cold
  580: 
  581: include ../chains.fs
  582: 
  583: Variable init8
  584: 
  585: : cold ( -- ) \ gforth
  586: [ has? file [IF] ]
  587:     pathstring 2@ fpath only-path 
  588:     init-included-files
  589: [ [THEN] ]
  590:     'cold
  591:     init8 chainperform
  592: [ has? file [IF] ]
  593:     process-args
  594:     loadline off
  595: [ [THEN] ]
  596:     bootmessage
  597:     quit ;
  598: 
  599: : clear-tibstack ( -- )
  600: [ has? glocals [IF] ]
  601:     lp@ forthstart 7 cells + @ - 
  602: [ [ELSE] ]
  603:     [ has? os [IF] ]
  604:     r0 @ forthstart 6 cells + @ -
  605:     [ [ELSE] ]
  606:     sp@ $40 +
  607:     [ [THEN] ]
  608: [ [THEN] ]
  609:     dup >tib ! tibstack ! #tib off >in off ;
  610: 
  611: : boot ( path **argv argc -- )
  612:     main-task up!
  613: [ has? os [IF] ]
  614:     stdout TO outfile-id
  615:     stdin  TO infile-id
  616: \ !! [ [THEN] ]
  617: \ !! [ has? file [IF] ]
  618:     argc ! argv ! pathstring 2!
  619: [ [THEN] ]
  620:     sp@ sp0 !
  621:     clear-tibstack
  622:     rp@ rp0 !
  623: [ has? floating [IF] ]
  624:     fp@ fp0 !
  625: [ [THEN] ]
  626:     ['] cold catch DoError cr
  627: [ has? os [IF] ]
  628:     bye
  629: [ [THEN] ]
  630: ;
  631: 
  632: has? os [IF]
  633: : bye ( -- ) \ tools-ext
  634: [ has? file [IF] ]
  635:     script? 0= IF  cr  THEN
  636: [ [ELSE] ]
  637:     cr
  638: [ [THEN] ]
  639:     0 (bye) ;
  640: [THEN]
  641: 
  642: \ **argv may be scanned by the C starter to get some important
  643: \ information, as -display and -geometry for an X client FORTH
  644: \ or space and stackspace overrides
  645: 
  646: \ 0 arg contains, however, the name of the program.
  647: 

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