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: require ./basics.fs \ bounds decimal hex ...
28: require ./io.fs \ type ...
29: require ./nio.fs \ . <# ...
30: require ./errore.fs \ .error ...
31: require ./version.fs \ version-string
32: require ./../chains.fs
33:
34: : tib ( -- c-addr ) \ core-ext
35: \G @var{c-addr} is the address of the Terminal Input Buffer.
36: \G OBSOLESCENT: @code{source} superceeds the function of this word.
37: >tib @ ;
38:
39: Defer source ( -- c-addr u ) \ core
40: \ used by dodefer:, must be defer
41: \G @var{c-addr} is the address of the input buffer and @var{u} is the
42: \G number of characters in it.
43:
44: : (source) ( -- c-addr u )
45: tib #tib @ ;
46: ' (source) IS source
47:
48: : (word) ( addr1 n1 char -- addr2 n2 )
49: dup >r skip 2dup r> scan nip - ;
50:
51: \ (word) should fold white spaces
52: \ this is what (parse-white) does
53:
54: \ word parse 23feb93py
55:
56: : sword ( char -- addr len ) \ gforth s-word
57: \G Parses like @code{word}, but the output is like @code{parse} output
58: \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
59: \ dpANS6 A.6.2.2008 have a word with that name that behaves
60: \ differently (like NAME).
61: source 2dup >r >r >in @ over min /string
62: rot dup bl = IF drop (parse-white) ELSE (word) THEN
63: 2dup + r> - 1+ r> min >in ! ;
64:
65: : word ( char "<chars>ccc<char>-- c-addr ) \ core
66: \G Skip leading delimiters. Parse @var{ccc}, delimited by
67: \G @var{char}, in the parse area. @var{c-addr} is the addres of a
68: \G transient region containing the parsed string in
69: \G counted-strinng format. If the parse area was empty or
70: \G contained no characters other than delimiters, the resulting
71: \G string has zero length. A program may replace characters within
72: \G the counted string. OBSOLESCENT: the counted string has a
73: \G trailing space that is not included in its length.
74: sword here place bl here count + c! here ;
75:
76: : parse ( char "ccc<char>" -- c-addr u ) \ core-ext
77: \G Parse @var{ccc}, delimited by @var{char}, in the parse
78: \G area. @var{c-addr u} specifies the parsed string within the
79: \G parse area. If the parse area was empty, @var{u} is 0.
80: >r source >in @ over min /string over swap r> scan >r
81: over - dup r> IF 1+ THEN >in +! ;
82:
83: \ name 13feb93py
84:
85: [IFUNDEF] (name) \ name might be a primitive
86:
87: : (name) ( -- c-addr count )
88: source 2dup >r >r >in @ /string (parse-white)
89: 2dup + r> - 1+ r> min >in ! ;
90: \ name count ;
91: [THEN]
92:
93: : name-too-short? ( c-addr u -- c-addr u )
94: dup 0= -&16 and throw ;
95:
96: : name-too-long? ( c-addr u -- c-addr u )
97: dup $1F u> -&19 and throw ;
98:
99: \ \ Number parsing 23feb93py
100:
101: \ number? number 23feb93py
102:
103: hex
104: const Create bases 10 , 2 , A , 100 ,
105: \ 16 2 10 character
106:
107: \ !! protect BASE saving wrapper against exceptions
108: : getbase ( addr u -- addr' u' )
109: over c@ [char] $ - dup 4 u<
110: IF
111: cells bases + @ base ! 1 /string
112: ELSE
113: drop
114: THEN ;
115:
116: : sign? ( addr u -- addr u flag )
117: over c@ [char] - = dup >r
118: IF
119: 1 /string
120: THEN
121: r> ;
122:
123: : s>unumber? ( addr u -- ud flag )
124: base @ >r dpl on getbase
125: 0. 2swap
126: BEGIN ( d addr len )
127: dup >r >number dup
128: WHILE \ there are characters left
129: dup r> -
130: WHILE \ the last >number parsed something
131: dup 1- dpl ! over c@ [char] . =
132: WHILE \ the current char is '.'
133: 1 /string
134: REPEAT THEN \ there are unparseable characters left
135: 2drop false
136: ELSE
137: rdrop 2drop true
138: THEN
139: r> base ! ;
140:
141: \ ouch, this is complicated; there must be a simpler way - anton
142: : s>number? ( addr len -- d f )
143: \ converts string addr len into d, flag indicates success
144: sign? >r
145: s>unumber?
146: 0= IF
147: rdrop false
148: ELSE \ no characters left, all ok
149: r>
150: IF
151: dnegate
152: THEN
153: true
154: THEN ;
155:
156: : s>number ( addr len -- d )
157: \ don't use this, there is no way to tell success
158: s>number? drop ;
159:
160: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
161: s>number? 0=
162: IF
163: 2drop false EXIT
164: THEN
165: dpl @ dup 0< IF
166: nip
167: ELSE
168: 1+
169: THEN ;
170:
171: : number? ( string -- string 0 / n -1 / d 0> )
172: dup >r count snumber? dup if
173: rdrop
174: else
175: r> swap
176: then ;
177:
178: : number ( string -- d )
179: number? ?dup 0= abort" ?" 0<
180: IF
181: s>d
182: THEN ;
183:
184: \ \ Comments ( \ \G
185:
186: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ thisone- core,file paren
187: \G ** this will not get annotated. The alias in glocals.fs will instead **
188: \G It does not work to use "wordset-" prefix since this file is glossed
189: \G by cross.fs which doesn't have the same functionalty as makedoc.fs
190: [char] ) parse 2drop ; immediate
191:
192: : \ ( -- ) \ thisone- core-ext,block-ext backslash
193: \G ** this will not get annotated. The alias in glocals.fs will instead **
194: \G It does not work to use "wordset-" prefix since this file is glossed
195: \G by cross.fs which doesn't have the same functionalty as makedoc.fs
196: [ has? file [IF] ]
197: blk @
198: IF
199: >in @ c/l / 1+ c/l * >in !
200: EXIT
201: THEN
202: [ [THEN] ]
203: source >in ! drop ; immediate
204:
205: : \G ( -- ) \ gforth backslash-gee
206: \G Equivalent to @code{\} but used as a tag to annotate definition
207: \G comments into documentation.
208: POSTPONE \ ; immediate
209:
210: \ \ object oriented search list 17mar93py
211:
212: \ word list structure:
213:
214: struct
215: cell% field find-method \ xt: ( c_addr u wid -- nt )
216: cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
217: cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables)
218: cell% field hash-method \ xt: ( wid -- ) \ initializes ""
219: \ \ !! what else
220: end-struct wordlist-map-struct
221:
222: struct
223: cell% field wordlist-map \ pointer to a wordlist-map-struct
224: cell% field wordlist-id \ linked list of words (for WORDS etc.)
225: cell% field wordlist-link \ link field to other wordlists
226: cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
227: end-struct wordlist-struct
228:
229: : f83find ( addr len wordlist -- nt / false )
230: wordlist-id @ (f83find) ;
231:
232: : initvoc ( wid -- )
233: dup wordlist-map @ hash-method perform ;
234:
235: \ Search list table: find reveal
236: Create f83search ( -- wordlist-map )
237: ' f83find A, ' drop A, ' drop A, ' drop A,
238:
239: here G f83search T A, NIL A, NIL A, NIL A,
240: AValue forth-wordlist \ variable, will be redefined by search.fs
241:
242: AVariable lookup forth-wordlist lookup !
243: \ !! last is user and lookup?! jaw
244: AVariable current ( -- addr ) \ gforth
245: \G VARIABLE: holds the wid of the current compilation word list.
246: AVariable voclink forth-wordlist wordlist-link voclink !
247: lookup AValue context ( -- addr ) \ gforth
248: \G VALUE: @code{context} @code{@@} is the wid of the word list at the
249: \G top of the search order stack.
250:
251: forth-wordlist current !
252:
253: \ \ header, finding, ticks 17dec92py
254:
255: hex
256: 80 constant alias-mask \ set when the word is not an alias!
257: 40 constant immediate-mask
258: 20 constant restrict-mask
259:
260: \ higher level parts of find
261:
262: : flag-sign ( f -- 1|-1 )
263: \ true becomes 1, false -1
264: 0= 2* 1+ ;
265:
266: : compile-only-error ( ... -- )
267: -&14 throw ;
268:
269: : (cfa>int) ( cfa -- xt )
270: [ has? compiler [IF] ]
271: dup interpret/compile?
272: if
273: interpret/compile-int @
274: then
275: [ [THEN] ] ;
276:
277: : (x>int) ( cfa b -- xt )
278: \ get interpretation semantics of name
279: restrict-mask and
280: if
281: drop ['] compile-only-error
282: else
283: (cfa>int)
284: then ;
285:
286: : name>string ( nt -- addr count ) \ gforth head-to-string
287: \g @var{addr count} is the name of the word represented by @var{nt}.
288: cell+ count $1F and ;
289:
290: : ((name>)) ( nfa -- cfa )
291: name>string + cfaligned ;
292:
293: : (name>x) ( nfa -- cfa b )
294: \ cfa is an intermediate cfa and b is the flags byte of nfa
295: dup ((name>))
296: swap cell+ c@ dup alias-mask and 0=
297: IF
298: swap @ swap
299: THEN ;
300:
301: : name>int ( nt -- xt ) \ gforth
302: \G @i{xt} represents the interpretation semantics of the word
303: \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
304: \G @code{compile-only}), @i{xt} is the execution token for
305: \G @code{compile-only-error}, which performs @code{-14 throw}.
306: (name>x) (x>int) ;
307:
308: : name?int ( nt -- xt ) \ gforth
309: \G Like @code{name>int}, but perform @code{-14 throw} if @i{nt}
310: \G has no interpretation semantics.
311: (name>x) restrict-mask and
312: if
313: compile-only-error \ does not return
314: then
315: (cfa>int) ;
316:
317: : (name>comp) ( nt -- w +-1 ) \ gforth
318: \G @i{w xt} is the compilation token for the word @i{nt}.
319: (name>x) >r
320: [ has? compiler [IF] ]
321: dup interpret/compile?
322: if
323: interpret/compile-comp @
324: then
325: [ [THEN] ]
326: r> immediate-mask and flag-sign
327: ;
328:
329: : (name>intn) ( nfa -- xt +-1 )
330: (name>x) tuck (x>int) ( b xt )
331: swap immediate-mask and flag-sign ;
332:
333: const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
334: \ ??? is used by dovar:, must be created/:dovar
335:
336: [IFDEF] forthstart
337: \ if we have a forthstart we can define head? with it
338: \ otherwise leave out the head? check
339:
340: : head? ( addr -- f )
341: \G heuristic check whether addr is a name token; may deliver false
342: \G positives; addr must be a valid address
343: \ we follow the link fields and check for plausibility; two
344: \ iterations should catch most false addresses: on the first
345: \ iteration, we may get an xt, on the second a code address (or
346: \ some code), which is typically not in the dictionary.
347: 2 0 do
348: dup @ dup
349: if ( addr addr1 )
350: dup rot forthstart within
351: if \ addr1 is outside forthstart..addr, not a head
352: drop false unloop exit
353: then ( addr1 )
354: else \ 0 in the link field, no further checks
355: 2drop true unloop exit
356: then
357: loop
358: \ in dubio pro:
359: drop true ;
360:
361: : >head ( cfa -- nt ) \ gforth to-head
362: $21 cell do ( cfa )
363: dup i - count $9F and + cfaligned over alias-mask + =
364: if ( cfa )
365: dup i - cell - dup head?
366: if
367: nip unloop exit
368: then
369: drop
370: then
371: cell +loop
372: drop ??? ( wouldn't 0 be better? ) ;
373:
374: [ELSE]
375:
376: : >head ( cfa -- nt ) \ gforth to-head
377: $21 cell do ( cfa )
378: dup i - count $9F and + cfaligned over alias-mask + =
379: if ( cfa ) i - cell - unloop exit
380: then
381: cell +loop
382: drop ??? ( wouldn't 0 be better? ) ;
383:
384: [THEN]
385:
386: ' >head ALIAS >name
387:
388: : body> 0 >body - ;
389:
390: : (search-wordlist) ( addr count wid -- nt | false )
391: dup wordlist-map @ find-method perform ;
392:
393: : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search
394: \G Search the word list identified by @i{wid}
395: \G for the definition named by the string at @i{c-addr count}.
396: \G If the definition is not found, return 0. If the definition
397: \G is found return 1 (if the definition is immediate) or -1
398: \G (if the definition is not immediate) together with the @i{xt}.
399: \G The @i{xt} returned represents the interpretation semantics.
400: (search-wordlist) dup if
401: (name>intn)
402: then ;
403:
404: : find-name ( c-addr u -- nt | 0 ) \ gforth
405: \g Find the name @i{c-addr u} in the current search
406: \g order. Return its @i{nt}, if found, otherwise 0.
407: lookup @ (search-wordlist) ;
408:
409: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
410: find-name dup
411: if ( nt )
412: state @
413: if
414: (name>comp)
415: else
416: (name>intn)
417: then
418: then ;
419:
420: : find ( c-addr -- xt +-1 | c-addr 0 ) \ core,search
421: \G Search all word lists in the current search order
422: \G for the definition named by the counted string at @i{c-addr}.
423: \G If the definition is not found, return 0. If the definition
424: \G is found return 1 (if the definition is immediate) or -1
425: \G (if the definition is not immediate) together with the @i{xt}.
426: dup count sfind dup
427: if
428: rot drop
429: then ;
430:
431: \ ticks
432:
433: : (') ( "name" -- nt ) \ gforth
434: name name-too-short?
435: find-name dup 0=
436: IF
437: drop -&13 bounce
438: THEN ;
439:
440: : ' ( "name" -- xt ) \ core tick
441: \g @i{xt} represents @i{name}'s interpretation
442: \g semantics. Perform @code{-14 throw} if the word has no
443: \g interpretation semantics.
444: (') name?int ;
445:
446: \ \ the interpreter loop mar92py
447:
448: \ interpret 10mar92py
449:
450: Defer parser
451: Defer name ( -- c-addr count ) \ gforth
452: \ get the next word from the input buffer
453: ' (name) IS name
454: Defer compiler-notfound ( c-addr count -- )
455: Defer interpreter-notfound ( c-addr count -- )
456:
457: : no.extensions ( addr u -- )
458: 2drop -&13 bounce ;
459: ' no.extensions IS compiler-notfound
460: ' no.extensions IS interpreter-notfound
461:
462: : interpret ( ?? -- ?? ) \ gforth
463: \ interpret/compile the (rest of the) input buffer
464: [ has? backtrace [IF] ]
465: rp@ backtrace-rp0 !
466: [ [THEN] ]
467: BEGIN
468: ?stack name dup
469: WHILE
470: parser
471: REPEAT
472: 2drop ;
473:
474: \ interpreter 30apr92py
475:
476: \ not the most efficient implementations of interpreter and compiler
477: : interpreter ( c-addr u -- )
478: 2dup find-name dup
479: if
480: nip nip name>int execute
481: else
482: drop
483: 2dup 2>r snumber?
484: IF
485: 2rdrop
486: ELSE
487: 2r> interpreter-notfound
488: THEN
489: then ;
490:
491: ' interpreter IS parser
492:
493: \ \ Query Evaluate 07apr93py
494:
495: has? file 0= [IF]
496: : sourceline# ( -- n ) 1 ;
497: [THEN]
498:
499: : refill ( -- flag ) \ core-ext,block-ext,file-ext
500: \G Attempt to fill the input buffer from the input source. When
501: \G the input source is the user input device, attempt to receive
502: \G input into the terminal input device. If successful, make the
503: \G result the input buffer, set @code{>IN} to 0 and return true;
504: \G otherwise return false. When the input source is a block, add 1
505: \G to the value of @code{BLK} to make the next block the input
506: \G source and current input buffer, and set @code{>IN} to 0;
507: \G return true if the new value of @code{BLK} is a valid block
508: \G number, false otherwise. When the input source is a text file,
509: \G attempt to read the next line from the file. If successful,
510: \G make the result the current input buffer, set @code{>IN} to 0
511: \G and return true; otherwise, return false. A successful result
512: \G includes receipt of a line containing 0 characters.
513: [ has? file [IF] ]
514: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
515: [ [THEN] ]
516: tib /line
517: [ has? file [IF] ]
518: loadfile @ ?dup
519: IF read-line throw
520: ELSE
521: [ [THEN] ]
522: sourceline# 0< IF 2drop false EXIT THEN
523: accept true
524: [ has? file [IF] ]
525: THEN
526: 1 loadline +!
527: [ [THEN] ]
528: swap #tib ! 0 >in ! ;
529:
530: : query ( -- ) \ core-ext
531: \G Make the user input device the input source. Receive input into
532: \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
533: \G superceeded by @code{accept}.
534: [ has? file [IF] ]
535: blk off loadfile off
536: [ [THEN] ]
537: tib /line accept #tib ! 0 >in ! ;
538:
539: \ save-mem extend-mem
540:
541: has? os [IF]
542: : save-mem ( addr1 u -- addr2 u ) \ gforth
543: \g copy a memory block into a newly allocated region in the heap
544: swap >r
545: dup allocate throw
546: swap 2dup r> -rot move ;
547:
548: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
549: \ extend memory block allocated from the heap by u aus
550: \ the (possibly reallocated piece is addr2 u2, the extension is at addr
551: over >r + dup >r resize throw
552: r> over r> + -rot ;
553: [THEN]
554:
555: \ EVALUATE 17may93jaw
556:
557: has? file 0= [IF]
558: : push-file ( -- ) r>
559: tibstack @ >r >tib @ >r #tib @ >r
560: >tib @ tibstack @ = IF r@ tibstack +! THEN
561: tibstack @ >tib ! >in @ >r >r ;
562:
563: : pop-file ( throw-code -- throw-code )
564: r>
565: r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ;
566: [THEN]
567:
568: : evaluate ( c-addr u -- ) \ core,block
569: \G Save the current input source specification. Store -1 in
570: \G @code{source-id} and 0 in @code{blk}. Set @code{>IN} to 0 and
571: \G make the string @var{c-addr u} the input source and input
572: \G buffer. Interpret. When the parse area is empty, restore the
573: \G input source specification.
574: push-file #tib ! >tib !
575: >in off
576: [ has? file [IF] ]
577: blk off loadfile off -1 loadline !
578: [ [THEN] ]
579: ['] interpret catch
580: pop-file throw ;
581:
582: \ \ Quit 13feb93py
583:
584: Defer 'quit
585:
586: Defer .status
587:
588: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
589:
590: : (Query) ( -- )
591: [ has? file [IF] ]
592: loadfile off blk off loadline off
593: [ [THEN] ]
594: refill drop ;
595:
596: : (quit)
597: BEGIN .status cr (query) interpret prompt AGAIN ;
598:
599: ' (quit) IS 'quit
600:
601: \ \ DOERROR (DOERROR) 13jun93jaw
602:
603: 8 Constant max-errors
604: Variable error-stack 0 error-stack !
605: max-errors 6 * cells allot
606: \ format of one cell:
607: \ source ( addr u )
608: \ >in
609: \ line-number
610: \ Loadfilename ( addr u )
611:
612: : dec. ( n -- ) \ gforth
613: \G Display @var{n} as a signed decimal number, followed by a space.
614: \G !! not used...
615: base @ decimal swap . base ! ;
616:
617: : dec.r ( u -- ) \ gforth
618: \G Display @var{u} as a unsigned decimal number
619: base @ decimal swap 0 .r base ! ;
620:
621: : hex. ( u -- ) \ gforth
622: \G Display @var{u} as an unsigned hex number, prefixed with a "$" and
623: \G followed by a space.
624: \G !! not used...
625: [char] $ emit base @ swap hex u. base ! ;
626:
627: : typewhite ( addr u -- ) \ gforth
628: \ like type, but white space is printed instead of the characters
629: bounds ?do
630: i c@ #tab = if \ check for tab
631: #tab
632: else
633: bl
634: then
635: emit
636: loop ;
637:
638: DEFER DOERROR
639:
640: has? backtrace [IF]
641: Defer dobacktrace ( -- )
642: ' noop IS dobacktrace
643: [THEN]
644:
645: : .error-string ( throw-code -- )
646: dup -2 =
647: IF "error @ ?dup IF count type THEN drop
648: ELSE .error
649: THEN ;
650:
651: : .error-frame ( throwcode addr1 u1 n1 n2 addr2 u2 -- throwcode )
652: \ addr2 u2: filename of included file
653: \ n2: line number
654: \ n1: error position in input line
655: \ addr1 u1: input line
656:
657: cr error-stack @
658: IF
659: ." in file included from "
660: type ." :" dec.r drop 2drop
661: ELSE
662: type ." :" dec.r ." : " 3 pick .error-string cr
663: dup 2over type cr drop
664: nip -trailing 1- ( line-start index2 )
665: 0 >r BEGIN
666: 2dup + c@ bl > WHILE
667: r> 1+ >r 1- dup 0< UNTIL THEN 1+
668: ( line-start index1 )
669: typewhite
670: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
671: [char] ^ emit
672: loop
673: THEN ;
674:
675: : (DoError) ( throw-code -- )
676: [ has? os [IF] ]
677: >stderr
678: [ [THEN] ]
679: sourceline# IF
680: source >in @ sourceline# 0 0 .error-frame
681: THEN
682: error-stack @ 0 ?DO
683: -1 error-stack +!
684: error-stack dup @ 6 * cells + cell+
685: 6 cells bounds DO
686: I @
687: cell +LOOP
688: .error-frame
689: LOOP
690: drop
691: [ has? backtrace [IF] ]
692: dobacktrace
693: [ [THEN] ]
694: normal-dp dpp ! ;
695:
696: ' (DoError) IS DoError
697:
698: : quit ( ?? -- ?? ) \ core
699: \G Empty the return stack, make the user input device
700: \G the input source, enter interpret state and start
701: \G the text interpreter.
702: rp0 @ rp! handler off clear-tibstack >tib @ >r
703: BEGIN
704: [ has? compiler [IF] ]
705: postpone [
706: [ [THEN] ]
707: ['] 'quit CATCH dup
708: WHILE
709: <# \ reset hold area, or we may get another error
710: DoError r@ >tib ! r@ tibstack !
711: REPEAT
712: drop r> >tib ! ;
713:
714: \ \ Cold Boot 13feb93py
715:
716: : (bootmessage)
717: ." GForth " version-string type
718: ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
719: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
720: [ has? os [IF] ]
721: cr ." Type `bye' to exit"
722: [ [THEN] ] ;
723:
724: defer bootmessage
725: defer process-args
726:
727: ' (bootmessage) IS bootmessage
728:
729: Defer 'cold ( -- ) \ gforth tick-cold
730: \ hook (deferred word) for things to do right before interpreting the
731: \ command-line arguments
732: ' noop IS 'cold
733:
734:
735: Variable init8
736:
737: : cold ( -- ) \ gforth
738: [ has? file [IF] ]
739: pathstring 2@ fpath only-path
740: init-included-files
741: [ [THEN] ]
742: 'cold
743: init8 chainperform
744: [ has? file [IF] ]
745: process-args
746: loadline off
747: [ [THEN] ]
748: bootmessage
749: quit ;
750:
751: : clear-tibstack ( -- )
752: [ has? glocals [IF] ]
753: lp@ forthstart 7 cells + @ -
754: [ [ELSE] ]
755: [ has? os [IF] ]
756: r0 @ forthstart 6 cells + @ -
757: [ [ELSE] ]
758: sp@ $10 cells +
759: [ [THEN] ]
760: [ [THEN] ]
761: dup >tib ! tibstack ! #tib off >in off ;
762:
763: : boot ( path **argv argc -- )
764: main-task up!
765: [ has? os [IF] ]
766: stdout TO outfile-id
767: stdin TO infile-id
768: \ !! [ [THEN] ]
769: \ !! [ has? file [IF] ]
770: argc ! argv ! pathstring 2!
771: [ [THEN] ]
772: sp@ sp0 !
773: clear-tibstack
774: rp@ rp0 !
775: [ has? floating [IF] ]
776: fp@ fp0 !
777: [ [THEN] ]
778: ['] cold catch DoError cr
779: [ has? os [IF] ]
780: bye
781: [ [THEN] ]
782: ;
783:
784: has? os [IF]
785: : bye ( -- ) \ tools-ext
786: [ has? file [IF] ]
787: script? 0= IF cr THEN
788: [ [ELSE] ]
789: cr
790: [ [THEN] ]
791: 0 (bye) ;
792: [THEN]
793:
794: \ **argv may be scanned by the C starter to get some important
795: \ information, as -display and -geometry for an X client FORTH
796: \ or space and stackspace overrides
797:
798: \ 0 arg contains, however, the name of the program.
799:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to int.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel