File:  [gforth] / gforth / kernel / int.fs
Revision 1.7: download - view: text, annotated - select for diffs
Sun Oct 18 23:16:53 1998 UTC (25 years, 5 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added infile-id, fixed bug with KEY? when input is not a tty.
First try to compile it under Win32.

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

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