Annotation of gforth/kernel.fs, revision 1.18
1.1 pazsan 1: \ kernel.fs GForth kernel 17dec92py
2:
3: \ Copyright (C) 1995 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: \ Idea and implementation: Bernd Paysan (py)
22:
23: HEX
24:
25: \ labels for some code addresses
26:
1.15 pazsan 27: doer? :docon [IF]
1.1 pazsan 28: : docon: ( -- addr ) \ gforth
1.3 pazsan 29: \G the code address of a @code{CONSTANT}
1.1 pazsan 30: ['] bl >code-address ;
1.15 pazsan 31: [THEN]
1.1 pazsan 32:
33: : docol: ( -- addr ) \ gforth
1.3 pazsan 34: \G the code address of a colon definition
1.15 pazsan 35: ['] docol: >code-address ;
1.1 pazsan 36:
1.15 pazsan 37: doer? :dovar [IF]
1.1 pazsan 38: : dovar: ( -- addr ) \ gforth
1.3 pazsan 39: \G the code address of a @code{CREATE}d word
1.1 pazsan 40: ['] udp >code-address ;
1.15 pazsan 41: [THEN]
1.1 pazsan 42:
1.15 pazsan 43: doer? :douser [IF]
1.1 pazsan 44: : douser: ( -- addr ) \ gforth
1.3 pazsan 45: \G the code address of a @code{USER} variable
1.1 pazsan 46: ['] s0 >code-address ;
1.15 pazsan 47: [THEN]
1.1 pazsan 48:
1.15 pazsan 49: doer? :dodefer [IF]
1.1 pazsan 50: : dodefer: ( -- addr ) \ gforth
1.3 pazsan 51: \G the code address of a @code{defer}ed word
1.1 pazsan 52: ['] source >code-address ;
1.15 pazsan 53: [THEN]
1.1 pazsan 54:
1.15 pazsan 55: doer? :dofield [IF]
1.1 pazsan 56: : dofield: ( -- addr ) \ gforth
1.3 pazsan 57: \G the code address of a @code{field}
1.1 pazsan 58: ['] reveal-method >code-address ;
1.15 pazsan 59: [THEN]
60:
61: has-prims 0= [IF]
62: : dodoes: ( -- addr ) \ gforth
63: \G the code address of a @code{field}
64: ['] spaces >code-address ;
65: [THEN]
1.1 pazsan 66:
67: NIL AConstant NIL \ gforth
68:
1.13 pazsan 69: \ Aliases
70:
1.18 ! anton 71: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
! 72: \ copy w from the return stack to the data stack
1.13 pazsan 73:
1.1 pazsan 74: \ Bit string manipulation 06oct92py
75:
76: \ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
77: \ DOES> ( n -- ) + c@ ;
78:
79: \ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
80: \ : +bit ( addr n -- ) >bit over c@ or swap c! ;
81:
82: \ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ;
83: \ : >rel ( addr -- n ) forthstart - ;
84: \ : relon ( addr -- ) relinfo swap >rel cell / +bit ;
85:
86: \ here allot , c, A, 17dec92py
87:
88: : dp ( -- addr ) \ gforth
89: dpp @ ;
90: : here ( -- here ) \ core
91: dp @ ;
92: : allot ( n -- ) \ core
93: dp +! ;
94: : c, ( c -- ) \ core
95: here 1 chars allot c! ;
96: : , ( x -- ) \ core
97: here cell allot ! ;
98: : 2, ( w1 w2 -- ) \ gforth
99: here 2 cells allot 2! ;
100:
101: \ : aligned ( addr -- addr' ) \ core
102: \ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
103: : align ( -- ) \ core
104: here dup aligned swap ?DO bl c, LOOP ;
105:
106: \ : faligned ( addr -- f-addr ) \ float
107: \ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
108:
109: : falign ( -- ) \ float
110: here dup faligned swap
111: ?DO
112: bl c,
113: LOOP ;
114:
115: \ !! this is machine-dependent, but works on all but the strangest machines
1.14 pazsan 116:
117: : maxaligned ( addr -- f-addr ) \ float
118: [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
119: : maxalign ( -- ) \ float
120: here dup maxaligned swap
121: ?DO
122: bl c,
123: LOOP ;
1.1 pazsan 124:
125: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
126: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
127: \ the code field is aligned if its body is maxaligned
128: ' maxalign Alias cfalign ( -- ) \ gforth
129:
130: : chars ( n1 -- n2 ) \ core
131: ; immediate
132:
133:
134: \ : A! ( addr1 addr2 -- ) \ gforth
135: \ dup relon ! ;
136: \ : A, ( addr -- ) \ gforth
137: \ here cell allot A! ;
138: ' ! alias A! ( addr1 addr2 -- ) \ gforth
139: ' , alias A, ( addr -- ) \ gforth
140:
141:
142: \ on off 23feb93py
143:
144: : on ( addr -- ) \ gforth
145: true swap ! ;
146: : off ( addr -- ) \ gforth
147: false swap ! ;
148:
149: \ dabs roll 17may93jaw
150:
151: : dabs ( d1 -- d2 ) \ double
152: dup 0< IF dnegate THEN ;
153:
154: : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
155: dup 1+ pick >r
156: cells sp@ cell+ dup cell+ rot move drop r> ;
157:
158: \ name> found 17dec92py
159:
160: $80 constant alias-mask \ set when the word is not an alias!
161: $40 constant immediate-mask
162: $20 constant restrict-mask
163:
164: : ((name>)) ( nfa -- cfa )
165: name>string + cfaligned ;
166:
167: : (name>x) ( nfa -- cfa b )
168: \ cfa is an intermediate cfa and b is the flags byte of nfa
169: dup ((name>))
170: swap cell+ c@ dup alias-mask and 0=
171: IF
172: swap @ swap
173: THEN ;
174:
175: \ place bounds 13feb93py
176:
177: : place ( addr len to -- ) \ gforth
178: over >r rot over 1+ r> move c! ;
179: : bounds ( beg count -- end beg ) \ gforth
180: over + swap ;
181:
182: \ input stream primitives 23feb93py
183:
184: : tib ( -- c-addr ) \ core-ext
185: \ obsolescent
186: >tib @ ;
187: Defer source ( -- addr count ) \ core
188: \ used by dodefer:, must be defer
189: : (source) ( -- addr count )
190: tib #tib @ ;
191: ' (source) IS source
192:
193: \ (word) 22feb93py
194:
195: : scan ( addr1 n1 char -- addr2 n2 ) \ gforth
196: \ skip all characters not equal to char
197: >r
198: BEGIN
199: dup
200: WHILE
201: over c@ r@ <>
202: WHILE
203: 1 /string
204: REPEAT THEN
205: rdrop ;
206: : skip ( addr1 n1 char -- addr2 n2 ) \ gforth
207: \ skip all characters equal to char
208: >r
209: BEGIN
210: dup
211: WHILE
212: over c@ r@ =
213: WHILE
214: 1 /string
215: REPEAT THEN
216: rdrop ;
217:
218: : (word) ( addr1 n1 char -- addr2 n2 )
219: dup >r skip 2dup r> scan nip - ;
220:
221: \ (word) should fold white spaces
222: \ this is what (parse-white) does
223:
224: \ word parse 23feb93py
225:
226: : parse-word ( char -- addr len ) \ gforth
227: source 2dup >r >r >in @ over min /string
228: rot dup bl = IF drop (parse-white) ELSE (word) THEN
229: 2dup + r> - 1+ r> min >in ! ;
230: : word ( char -- addr ) \ core
231: parse-word here place bl here count + c! here ;
232:
233: : parse ( char -- addr len ) \ core-ext
234: >r source >in @ over min /string over swap r> scan >r
235: over - dup r> IF 1+ THEN >in +! ;
236:
237: \ name 13feb93py
238:
239: : capitalize ( addr len -- addr len ) \ gforth
240: 2dup chars chars bounds
241: ?DO I c@ toupper I c! 1 chars +LOOP ;
242: : (name) ( -- c-addr count )
243: source 2dup >r >r >in @ /string (parse-white)
244: 2dup + r> - 1+ r> min >in ! ;
245: \ name count ;
246:
247: : name-too-short? ( c-addr u -- c-addr u )
248: dup 0= -&16 and throw ;
249:
250: : name-too-long? ( c-addr u -- c-addr u )
251: dup $1F u> -&19 and throw ;
252:
253: \ Literal 17dec92py
254:
255: : Literal ( compilation n -- ; run-time -- n ) \ core
256: postpone lit , ; immediate restrict
257: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
258: postpone lit A, ; immediate restrict
259:
260: : char ( 'char' -- n ) \ core
261: bl word char+ c@ ;
262: : [char] ( compilation 'char' -- ; run-time -- n )
263: char postpone Literal ; immediate restrict
264:
265: : (compile) ( -- ) \ gforth
266: r> dup cell+ >r @ compile, ;
267:
1.18 ! anton 268: : postpone, ( w xt -- ) \ gforth postpone-comma
1.5 anton 269: \g Compiles the compilation semantics represented by @var{w xt}.
270: dup ['] execute =
271: if
272: drop compile,
273: else
274: dup ['] compile, =
275: if
276: drop POSTPONE (compile) compile,
277: else
278: swap POSTPONE aliteral compile,
279: then
280: then ;
281:
282: : POSTPONE ( "name" -- ) \ core
283: \g Compiles the compilation semantics of @var{name}.
284: COMP' postpone, ; immediate restrict
1.1 pazsan 285:
1.2 anton 286: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
1.1 pazsan 287: Create immediate swap A, A,
288: DOES>
289: abort" executed primary cfa of an interpret/compile: word" ;
290: \ state @ IF cell+ THEN perform ;
291:
292: \ Use (compile) for the old behavior of compile!
293:
294: \ digit? 17dec92py
295:
296: : digit? ( char -- digit true/ false ) \ gforth
297: base @ $100 =
298: IF
299: true EXIT
300: THEN
301: toupper [char] 0 - dup 9 u> IF
302: [ 'A '9 1 + - ] literal -
303: dup 9 u<= IF
304: drop false EXIT
305: THEN
306: THEN
307: dup base @ u>= IF
308: drop false EXIT
309: THEN
310: true ;
311:
312: : accumulate ( +d0 addr digit - +d1 addr )
313: swap >r swap base @ um* drop rot base @ um* d+ r> ;
314:
315: : >number ( d addr count -- d addr count ) \ core
316: 0
317: ?DO
318: count digit?
319: WHILE
320: accumulate
321: LOOP
322: 0
323: ELSE
324: 1- I' I -
325: UNLOOP
326: THEN ;
327:
328: \ number? number 23feb93py
329:
330: Create bases 10 , 2 , A , 100 ,
1.3 pazsan 331: \ 16 2 10 character
1.1 pazsan 332: \ !! this saving and restoring base is an abomination! - anton
333: : getbase ( addr u -- addr' u' )
334: over c@ [char] $ - dup 4 u<
335: IF
336: cells bases + @ base ! 1 /string
337: ELSE
338: drop
339: THEN ;
340: : s>number ( addr len -- d )
341: base @ >r dpl on
342: over c@ '- = dup >r
343: IF
344: 1 /string
345: THEN
346: getbase dpl on 0 0 2swap
347: BEGIN
348: dup >r >number dup
349: WHILE
350: dup r> -
351: WHILE
352: dup dpl ! over c@ [char] . =
353: WHILE
354: 1 /string
355: REPEAT THEN
356: 2drop rdrop dpl off
357: ELSE
358: 2drop rdrop r>
359: IF
360: dnegate
361: THEN
362: THEN
363: r> base ! ;
364:
365: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
366: s>number dpl @ 0=
367: IF
368: 2drop false EXIT
369: THEN
370: dpl @ dup 0> 0= IF
371: nip
372: THEN ;
373: : number? ( string -- string 0 / n -1 / d 0> )
374: dup >r count snumber? dup if
375: rdrop
376: else
377: r> swap
378: then ;
379: : s>d ( n -- d ) \ core s-to-d
380: dup 0< ;
381: : number ( string -- d )
382: number? ?dup 0= abort" ?" 0<
383: IF
384: s>d
385: THEN ;
386:
387: \ space spaces ud/mod 21mar93py
388: decimal
389: Create spaces ( u -- ) \ core
390: bl 80 times \ times from target compiler! 11may93jaw
391: DOES> ( u -- )
392: swap
393: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
394: Create backspaces
395: 08 80 times \ times from target compiler! 11may93jaw
396: DOES> ( u -- )
397: swap
398: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
399: hex
400: : space ( -- ) \ core
401: 1 spaces ;
402:
403: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
404: >r 0 r@ um/mod r> swap >r
405: um/mod r> ;
406:
407: : pad ( -- addr ) \ core-ext
408: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
409:
410: \ hold <# #> sign # #s 25jan92py
411:
412: : hold ( char -- ) \ core
413: pad cell - -1 chars over +! @ c! ;
414:
415: : <# ( -- ) \ core less-number-sign
416: pad cell - dup ! ;
417:
418: : #> ( xd -- addr u ) \ core number-sign-greater
419: 2drop pad cell - dup @ tuck - ;
420:
421: : sign ( n -- ) \ core
422: 0< IF [char] - hold THEN ;
423:
424: : # ( ud1 -- ud2 ) \ core number-sign
425: base @ 2 max ud/mod rot 9 over <
426: IF
427: [ char A char 9 - 1- ] Literal +
428: THEN
429: [char] 0 + hold ;
430:
431: : #s ( +d -- 0 0 ) \ core number-sign-s
432: BEGIN
1.14 pazsan 433: # 2dup or 0=
1.1 pazsan 434: UNTIL ;
435:
436: \ print numbers 07jun92py
437:
438: : d.r ( d n -- ) \ double d-dot-r
439: >r tuck dabs <# #s rot sign #>
440: r> over - spaces type ;
441:
442: : ud.r ( ud n -- ) \ gforth u-d-dot-r
443: >r <# #s #> r> over - spaces type ;
444:
445: : .r ( n1 n2 -- ) \ core-ext dot-r
446: >r s>d r> d.r ;
447: : u.r ( u n -- ) \ core-ext u-dot-r
448: 0 swap ud.r ;
449:
450: : d. ( d -- ) \ double d-dot
451: 0 d.r space ;
452: : ud. ( ud -- ) \ gforth u-d-dot
453: 0 ud.r space ;
454:
455: : . ( n -- ) \ core dot
456: s>d d. ;
457: : u. ( u -- ) \ core u-dot
458: 0 ud. ;
459:
460: \ catch throw 23feb93py
461: \ bounce 08jun93jaw
462:
463: \ !! allow the user to add rollback actions anton
464: \ !! use a separate exception stack? anton
465:
1.14 pazsan 466: has-locals [IF]
1.1 pazsan 467: : lp@ ( -- addr ) \ gforth l-p-fetch
468: laddr# [ 0 , ] ;
1.14 pazsan 469: [THEN]
1.1 pazsan 470:
1.13 pazsan 471: Defer 'catch
472: Defer 'throw
473:
474: ' noop IS 'catch
475: ' noop IS 'throw
476:
1.1 pazsan 477: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
1.13 pazsan 478: 'catch
1.3 pazsan 479: sp@ >r
1.14 pazsan 480: [ has-floats [IF] ]
1.3 pazsan 481: fp@ >r
1.14 pazsan 482: [ [THEN] ]
483: [ has-locals [IF] ]
1.3 pazsan 484: lp@ >r
1.14 pazsan 485: [ [THEN] ]
1.3 pazsan 486: handler @ >r
487: rp@ handler !
488: execute
489: r> handler ! rdrop rdrop rdrop 0 ;
1.1 pazsan 490:
491: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
492: ?DUP IF
1.16 pazsan 493: [ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
1.3 pazsan 494: handler @ dup 0= IF
1.14 pazsan 495: [ has-os [IF] ]
1.3 pazsan 496: 2 (bye)
1.14 pazsan 497: [ [ELSE] ]
498: quit
499: [ [THEN] ]
1.3 pazsan 500: THEN
501: rp!
1.1 pazsan 502: r> handler !
1.14 pazsan 503: [ has-locals [IF] ]
504: r> lp!
505: [ [THEN] ]
506: [ has-floats [IF] ]
1.1 pazsan 507: r> fp!
1.14 pazsan 508: [ [THEN] ]
1.3 pazsan 509: r> swap >r sp! drop r>
1.13 pazsan 510: 'throw
1.1 pazsan 511: THEN ;
512:
513: \ Bouncing is very fine,
514: \ programming without wasting time... jaw
515: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
516: \ a throw without data or fp stack restauration
517: ?DUP IF
1.3 pazsan 518: handler @ rp!
519: r> handler !
1.14 pazsan 520: [ has-locals [IF] ]
1.3 pazsan 521: r> lp!
1.14 pazsan 522: [ [THEN] ]
523: [ has-floats [IF] ]
1.3 pazsan 524: rdrop
1.14 pazsan 525: [ [THEN] ]
1.3 pazsan 526: rdrop
1.13 pazsan 527: 'throw
1.1 pazsan 528: THEN ;
529:
530: \ ?stack 23feb93py
531:
532: : ?stack ( ?? -- ?? ) \ gforth
1.11 pazsan 533: sp@ s0 @ u> IF -4 throw THEN
1.14 pazsan 534: [ has-floats [IF] ]
535: fp@ f0 @ u> IF -&45 throw THEN
536: [ [THEN] ]
537: ;
1.1 pazsan 538: \ ?stack should be code -- it touches an empty stack!
539:
540: \ interpret 10mar92py
541:
542: Defer parser
543: Defer name ( -- c-addr count ) \ gforth
544: \ get the next word from the input buffer
545: ' (name) IS name
546: Defer compiler-notfound ( c-addr count -- )
547: Defer interpreter-notfound ( c-addr count -- )
548:
549: : no.extensions ( addr u -- )
550: 2drop -&13 bounce ;
551: ' no.extensions IS compiler-notfound
552: ' no.extensions IS interpreter-notfound
553:
554: : compile-only-error ( ... -- )
555: -&14 throw ;
556:
557: : interpret ( ?? -- ?? ) \ gforth
558: \ interpret/compile the (rest of the) input buffer
559: BEGIN
560: ?stack name dup
561: WHILE
562: parser
563: REPEAT
564: 2drop ;
565:
566: \ interpreter compiler 30apr92py
567:
568: \ not the most efficient implementations of interpreter and compiler
569: : interpreter ( c-addr u -- )
570: 2dup find-name dup
571: if
572: nip nip name>int execute
573: else
574: drop
575: 2dup 2>r snumber?
576: IF
577: 2rdrop
578: ELSE
579: 2r> interpreter-notfound
580: THEN
581: then ;
582:
583: : compiler ( c-addr u -- )
584: 2dup find-name dup
1.4 anton 585: if ( c-addr u nt )
1.1 pazsan 586: nip nip name>comp execute
587: else
588: drop
589: 2dup snumber? dup
590: IF
591: 0>
592: IF
593: swap postpone Literal
594: THEN
595: postpone Literal
596: 2drop
597: ELSE
598: drop compiler-notfound
599: THEN
600: then ;
601:
602: ' interpreter IS parser
603:
604: : [ ( -- ) \ core left-bracket
605: ['] interpreter IS parser state off ; immediate
606: : ] ( -- ) \ core right-bracket
607: ['] compiler IS parser state on ;
608:
609: \ Strings 22feb93py
610:
611: : ," ( "string"<"> -- ) [char] " parse
612: here over char+ allot place align ;
613: : "lit ( -- addr )
614: r> r> dup count + aligned >r swap >r ;
615: : (.") "lit count type ;
616: : (S") "lit count ;
617: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
618: postpone (S") here over char+ allot place align ;
619: immediate restrict
1.12 anton 620: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren
1.13 pazsan 621: [char] ) parse 2drop ; immediate
1.12 anton 622:
1.1 pazsan 623: : \ ( -- ) \ core-ext backslash
624: blk @
625: IF
626: >in @ c/l / 1+ c/l * >in !
627: EXIT
628: THEN
629: source >in ! drop ; immediate
630:
631: : \G ( -- ) \ gforth backslash
632: POSTPONE \ ; immediate
633:
634: \ error handling 22feb93py
635: \ 'abort thrown out! 11may93jaw
636:
637: : (abort")
638: "lit >r
639: IF
640: r> "error ! -2 throw
641: THEN
642: rdrop ;
643: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote
644: postpone (abort") ," ; immediate restrict
645:
646: \ Header states 23feb93py
647:
648: : cset ( bmask c-addr -- )
649: tuck c@ or swap c! ;
650: : creset ( bmask c-addr -- )
651: tuck c@ swap invert and swap c! ;
652: : ctoggle ( bmask c-addr -- )
653: tuck c@ xor swap c! ;
654:
655: : lastflags ( -- c-addr )
656: \ the address of the flags byte in the last header
657: \ aborts if the last defined word was headerless
658: last @ dup 0= abort" last word was headerless" cell+ ;
659:
1.2 anton 660: : immediate ( -- ) \ core
661: immediate-mask lastflags cset ;
662: : restrict ( -- ) \ gforth
663: restrict-mask lastflags cset ;
664: ' restrict alias compile-only ( -- ) \ gforth
1.1 pazsan 665:
666: \ Header 23feb93py
667:
668: \ input-stream, nextname and noname are quite ugly (passing
669: \ information through global variables), but they are useful for dealing
670: \ with existing/independent defining words
671:
672: defer (header)
673: defer header ( -- ) \ gforth
674: ' (header) IS header
675:
676: : string, ( c-addr u -- ) \ gforth
1.3 pazsan 677: \G puts down string as cstring
1.1 pazsan 678: dup c, here swap chars dup allot move ;
679:
680: : header, ( c-addr u -- ) \ gforth
681: name-too-long?
682: align here last !
683: current @ 1 or A, \ link field; before revealing, it contains the
684: \ tagged reveal-into wordlist
685: string, cfalign
686: alias-mask lastflags cset ;
687:
688: : input-stream-header ( "name" -- )
689: name name-too-short? header, ;
690: : input-stream ( -- ) \ general
1.3 pazsan 691: \G switches back to getting the name from the input stream ;
1.1 pazsan 692: ['] input-stream-header IS (header) ;
693:
694: ' input-stream-header IS (header)
695:
696: \ !! make that a 2variable
697: create nextname-buffer 32 chars allot
698:
699: : nextname-header ( -- )
700: nextname-buffer count header,
701: input-stream ;
702:
703: \ the next name is given in the string
704: : nextname ( c-addr u -- ) \ gforth
705: name-too-long?
706: nextname-buffer c! ( c-addr )
707: nextname-buffer count move
708: ['] nextname-header IS (header) ;
709:
710: : noname-header ( -- )
711: 0 last ! cfalign
712: input-stream ;
713:
714: : noname ( -- ) \ gforth
715: \ the next defined word remains anonymous. The xt of that word is given by lastxt
716: ['] noname-header IS (header) ;
717:
718: : lastxt ( -- xt ) \ gforth
719: \ 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
720: lastcfa @ ;
721:
722: : Alias ( cfa "name" -- ) \ gforth
723: Header reveal
724: alias-mask lastflags creset
725: dup A, lastcfa ! ;
726:
1.4 anton 727: : name>string ( nt -- addr count ) \ gforth name-to-string
728: \g @var{addr count} is the name of the word represented by @var{nt}.
729: cell+ count $1F and ;
1.1 pazsan 730:
731: Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
1.4 anton 732: : >name ( cfa -- nt ) \ gforth to-name
1.1 pazsan 733: $21 cell do
734: dup i - count $9F and + cfaligned over alias-mask + = if
735: i - cell - unloop exit
736: then
737: cell +loop
738: drop ??? ( wouldn't 0 be better? ) ;
739:
740: \ threading 17mar93py
741:
742: : cfa, ( code-address -- ) \ gforth cfa-comma
743: here
744: dup lastcfa !
745: 0 A, 0 , code-address! ;
746: : compile, ( xt -- ) \ core-ext compile-comma
747: A, ;
748: : !does ( addr -- ) \ gforth store-does
749: lastxt does-code! ;
750: : (does>) ( R: addr -- )
1.16 pazsan 751: r> cfaligned /does-handler + !does ;
1.1 pazsan 752: : dodoes, ( -- )
1.16 pazsan 753: cfalign here /does-handler allot does-handler! ;
1.1 pazsan 754:
1.15 pazsan 755: doer? :dovar [IF]
1.1 pazsan 756: : Create ( "name" -- ) \ core
757: Header reveal dovar: cfa, ;
1.15 pazsan 758: [ELSE]
759: : Create ( "name" -- ) \ core
760: Header reveal here lastcfa ! 0 A, 0 , DOES> ;
761: [THEN]
1.1 pazsan 762:
763: \ Create Variable User Constant 17mar93py
764:
765: : Variable ( "name" -- ) \ core
766: Create 0 , ;
767: : AVariable ( "name" -- ) \ gforth
768: Create 0 A, ;
1.15 pazsan 769: : 2Variable ( "name" -- ) \ double
1.1 pazsan 770: create 0 , 0 , ;
1.15 pazsan 771:
772: : uallot ( n -- ) udp @ swap udp +! ;
773:
774: doer? :douser [IF]
1.1 pazsan 775: : User ( "name" -- ) \ gforth
1.15 pazsan 776: Header reveal douser: cfa, cell uallot , ;
1.1 pazsan 777: : AUser ( "name" -- ) \ gforth
1.15 pazsan 778: User ;
779: [ELSE]
780: : User Create uallot , DOES> @ up @ + ;
781: : AUser User ;
782: [THEN]
1.1 pazsan 783:
1.15 pazsan 784: doer? :docon [IF]
785: : (Constant) Header reveal docon: cfa, ;
786: [ELSE]
787: : (Constant) Create DOES> @ ;
788: [THEN]
1.1 pazsan 789: : Constant ( w "name" -- ) \ core
1.3 pazsan 790: \G Defines constant @var{name}
791: \G
792: \G @var{name} execution: @var{-- w}
1.1 pazsan 793: (Constant) , ;
794: : AConstant ( addr "name" -- ) \ gforth
795: (Constant) A, ;
1.15 pazsan 796: : Value ( w "name" -- ) \ core-ext
797: (Constant) , ;
1.1 pazsan 798:
799: : 2Constant ( w1 w2 "name" -- ) \ double
800: Create ( w1 w2 "name" -- )
801: 2,
802: DOES> ( -- w1 w2 )
803: 2@ ;
804:
1.15 pazsan 805: doer? :dofield [IF]
806: : (Field) Header reveal dofield: cfa, ;
807: [ELSE]
808: : (Field) Create DOES> @ + ;
809: [THEN]
1.1 pazsan 810: \ IS Defer What's Defers TO 24feb93py
811:
1.15 pazsan 812: doer? :dodefer [IF]
1.1 pazsan 813: : Defer ( "name" -- ) \ gforth
814: \ !! shouldn't it be initialized with abort or something similar?
815: Header Reveal dodefer: cfa,
816: ['] noop A, ;
1.15 pazsan 817: [ELSE]
818: : Defer ( "name" -- ) \ gforth
819: Create ['] noop A,
820: DOES> @ execute ;
821: [THEN]
1.1 pazsan 822:
823: : Defers ( "name" -- ) \ gforth
824: ' >body @ compile, ; immediate
825:
826: \ : ; 24feb93py
827:
828: defer :-hook ( sys1 -- sys2 )
829: defer ;-hook ( sys2 -- sys1 )
830:
831: : : ( "name" -- colon-sys ) \ core colon
832: Header docol: cfa, defstart ] :-hook ;
833: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
834: ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
835:
836: : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
837: 0 last !
838: cfalign here docol: cfa, 0 ] :-hook ;
839:
840: \ Search list handling 23feb93py
841:
842: AVariable current ( -- addr ) \ gforth
843:
844: : last? ( -- false / nfa nfa )
845: last @ ?dup ;
1.4 anton 846: : (reveal) ( nt wid -- )
1.1 pazsan 847: ( wid>wordlist-id ) dup >r
848: @ over ( name>link ) !
849: r> ! ;
850:
851: \ object oriented search list 17mar93py
852:
853: \ word list structure:
854:
855: struct
1.4 anton 856: 1 cells: field find-method \ xt: ( c_addr u wid -- nt )
857: 1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
1.1 pazsan 858: 1 cells: field rehash-method \ xt: ( wid -- )
859: \ \ !! what else
860: end-struct wordlist-map-struct
861:
862: struct
863: 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
864: 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
865: 1 cells: field wordlist-link \ link field to other wordlists
866: 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
867: end-struct wordlist-struct
868:
1.4 anton 869: : f83find ( addr len wordlist -- nt / false )
1.1 pazsan 870: ( wid>wordlist-id ) @ (f83find) ;
871:
872: \ Search list table: find reveal
873: Create f83search ( -- wordlist-map )
874: ' f83find A, ' (reveal) A, ' drop A,
875:
876: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
877: AVariable lookup G forth-wordlist lookup T !
878: G forth-wordlist current T !
879:
880: \ higher level parts of find
881:
882: ( struct )
883: 0 >body cell
884: 1 cells: field interpret/compile-int
885: 1 cells: field interpret/compile-comp
886: end-struct interpret/compile-struct
887:
888: : interpret/compile? ( xt -- flag )
889: >does-code ['] S" >does-code = ;
890:
891: : (cfa>int) ( cfa -- xt )
892: dup interpret/compile?
893: if
894: interpret/compile-int @
895: then ;
896:
897: : (x>int) ( cfa b -- xt )
898: \ get interpretation semantics of name
899: restrict-mask and
900: if
901: drop ['] compile-only-error
902: else
903: (cfa>int)
904: then ;
905:
1.4 anton 906: : name>int ( nt -- xt ) \ gforth
907: \G @var{xt} represents the interpretation semantics of the word
908: \G @var{nt}. Produces @code{' compile-only-error} if
909: \G @var{nt} is compile-only.
1.1 pazsan 910: (name>x) (x>int) ;
911:
1.4 anton 912: : name?int ( nt -- xt ) \ gforth
913: \G Like name>int, but throws an error if compile-only.
1.1 pazsan 914: (name>x) restrict-mask and
915: if
916: compile-only-error \ does not return
917: then
918: (cfa>int) ;
919:
1.4 anton 920: : name>comp ( nt -- w xt ) \ gforth
1.10 anton 921: \G @var{w xt} is the compilation token for the word @var{nt}.
1.1 pazsan 922: (name>x) >r dup interpret/compile?
923: if
924: interpret/compile-comp @
925: then
926: r> immediate-mask and if
927: ['] execute
928: else
929: ['] compile,
930: then ;
931:
1.4 anton 932: : (search-wordlist) ( addr count wid -- nt / false )
1.1 pazsan 933: dup wordlist-map @ find-method perform ;
934:
935: : flag-sign ( f -- 1|-1 )
936: \ true becomes 1, false -1
937: 0= 2* 1+ ;
938:
939: : (name>intn) ( nfa -- xt +-1 )
940: (name>x) tuck (x>int) ( b xt )
941: swap immediate-mask and flag-sign ;
942:
943: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
944: \ xt is the interpretation semantics
945: (search-wordlist) dup if
946: (name>intn)
947: then ;
948:
1.4 anton 949: : find-name ( c-addr u -- nt/0 ) \ gforth
950: \g Find the name @var{c-addr u} in the current search
951: \g order. Return its nt, if found, otherwise 0.
1.1 pazsan 952: lookup @ (search-wordlist) ;
953:
954: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
955: find-name dup
1.4 anton 956: if ( nt )
1.1 pazsan 957: state @
958: if
959: name>comp ['] execute = flag-sign
960: else
961: (name>intn)
962: then
963: then ;
964:
1.18 ! anton 965: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
1.1 pazsan 966: dup count sfind dup
967: if
968: rot drop
969: then ;
970:
1.4 anton 971: : (') ( "name" -- nt ) \ gforth
1.1 pazsan 972: name find-name dup 0=
973: IF
974: drop -&13 bounce
975: THEN ;
976:
1.4 anton 977: : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
1.1 pazsan 978: (') postpone ALiteral ; immediate restrict
979:
980: : ' ( "name" -- xt ) \ core tick
1.4 anton 981: \g @var{xt} represents @var{name}'s interpretation
982: \g semantics. Performs @code{-14 throw} if the word has no
983: \g interpretation semantics.
1.1 pazsan 984: (') name?int ;
1.4 anton 985: : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
986: \g @var{xt} represents @var{name}'s interpretation
987: \g semantics. Performs @code{-14 throw} if the word has no
988: \g interpretation semantics.
1.1 pazsan 989: ' postpone ALiteral ; immediate restrict
990:
991: : COMP' ( "name" -- w xt ) \ gforth c-tick
1.4 anton 992: \g @var{w xt} represents @var{name}'s compilation semantics.
1.1 pazsan 993: (') name>comp ;
994: : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
1.4 anton 995: \g @var{w xt} represents @var{name}'s compilation semantics.
1.1 pazsan 996: COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
997:
998: \ reveal words
999:
1000: Variable warnings ( -- addr ) \ gforth
1001: G -1 warnings T !
1002:
1003: : check-shadow ( addr count wid -- )
1.3 pazsan 1004: \G prints a warning if the string is already present in the wordlist
1.1 pazsan 1005: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
1006: ." redefined " name>string 2dup type
1007: compare 0<> if
1008: ." with " type
1009: else
1010: 2drop
1011: then
1012: space space EXIT
1013: then
1014: 2drop 2drop ;
1015:
1016: : reveal ( -- ) \ gforth
1017: last?
1018: if \ the last word has a header
1019: dup ( name>link ) @ 1 and
1020: if \ it is still hidden
1.4 anton 1021: dup ( name>link ) @ 1 xor ( nt wid )
1022: 2dup >r name>string r> check-shadow ( nt wid )
1.1 pazsan 1023: dup wordlist-map @ reveal-method perform
1024: then
1025: then ;
1026:
1027: : rehash ( wid -- )
1028: dup wordlist-map @ rehash-method perform ;
1029:
1030: \ Input 13feb93py
1031:
1032: 07 constant #bell ( -- c ) \ gforth
1033: 08 constant #bs ( -- c ) \ gforth
1034: 09 constant #tab ( -- c ) \ gforth
1035: 7F constant #del ( -- c ) \ gforth
1036: 0D constant #cr ( -- c ) \ gforth
1037: \ the newline key code
1038: 0C constant #ff ( -- c ) \ gforth
1039: 0A constant #lf ( -- c ) \ gforth
1040:
1041: : bell #bell emit ;
1042: : cr ( -- ) \ core
1043: \ emit a newline
1044: #lf ( sic! ) emit ;
1045:
1046: \ : backspaces 0 ?DO #bs emit LOOP ;
1047:
1048: : (ins) ( max span addr pos1 key -- max span addr pos2 )
1049: >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
1050: : (bs) ( max span addr pos1 -- max span addr pos2 flag )
1051: dup IF
1052: #bs emit bl emit #bs emit 1- rot 1- -rot
1053: THEN false ;
1.14 pazsan 1054: : (ret) true bl emit ;
1.1 pazsan 1055:
1056: Create ctrlkeys
1057: ] false false false false false false false false
1058: (bs) false (ret) false false (ret) false false
1059: false false false false false false false false
1060: false false false false false false false false [
1061:
1062: defer insert-char
1063: ' (ins) IS insert-char
1064: defer everychar
1065: ' noop IS everychar
1066:
1067: : decode ( max span addr pos1 key -- max span addr pos2 flag )
1068: everychar
1069: dup #del = IF drop #bs THEN \ del is rubout
1070: dup bl < IF cells ctrlkeys + perform EXIT THEN
1071: >r 2over = IF rdrop bell 0 EXIT THEN
1072: r> insert-char 0 ;
1073:
1074: : accept ( addr len -- len ) \ core
1075: dup 0< IF abs over dup 1 chars - c@ tuck type
1076: \ this allows to edit given strings
1.14 pazsan 1077: ELSE 0 THEN rot over
1.1 pazsan 1078: BEGIN key decode UNTIL
1079: 2drop nip ;
1080:
1081: \ Output 13feb93py
1082:
1.14 pazsan 1083: has-os [IF]
1084: 0 Value outfile-id ( -- file-id ) \ gforth
1085:
1.1 pazsan 1086: : (type) ( c-addr u -- ) \ gforth
1087: outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
1088: ;
1089:
1090: : (emit) ( c -- ) \ gforth
1091: outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
1092: ;
1.14 pazsan 1093: [THEN]
1094:
1095: Defer type ( c-addr u -- ) \ core
1096: ' (type) IS Type
1.1 pazsan 1097:
1098: Defer emit ( c -- ) \ core
1099: ' (Emit) IS Emit
1100:
1101: Defer key ( -- c ) \ core
1102: ' (key) IS key
1103:
1104: \ Query 07apr93py
1105:
1.14 pazsan 1106: has-files 0= [IF]
1107: : sourceline# ( -- n ) loadline @ ;
1108: [THEN]
1109:
1.1 pazsan 1110: : refill ( -- flag ) \ core-ext,block-ext,file-ext
1111: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
1112: tib /line
1.14 pazsan 1113: [ has-files [IF] ]
1.1 pazsan 1114: loadfile @ ?dup
1115: IF read-line throw
1.14 pazsan 1116: ELSE
1117: [ [THEN] ]
1118: sourceline# 0< IF 2drop false EXIT THEN
1119: accept true
1120: [ has-files [IF] ]
1.1 pazsan 1121: THEN
1.14 pazsan 1122: [ [THEN] ]
1.1 pazsan 1123: 1 loadline +!
1124: swap #tib ! 0 >in ! ;
1125:
1.8 anton 1126: : query ( -- ) \ core-ext
1.3 pazsan 1127: \G obsolescent
1.13 pazsan 1128: blk off loadfile off
1.8 anton 1129: tib /line accept #tib ! 0 >in ! ;
1.1 pazsan 1130:
1.13 pazsan 1131: \ save-mem extend-mem
1.1 pazsan 1132:
1.14 pazsan 1133: has-os [IF]
1.13 pazsan 1134: : save-mem ( addr1 u -- addr2 u ) \ gforth
1135: \g copy a memory block into a newly allocated region in the heap
1136: swap >r
1137: dup allocate throw
1138: swap 2dup r> -rot move ;
1.1 pazsan 1139:
1.13 pazsan 1140: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
1141: \ extend memory block allocated from the heap by u aus
1142: \ the (possibly reallocated piece is addr2 u2, the extension is at addr
1143: over >r + dup >r resize throw
1144: r> over r> + -rot ;
1.14 pazsan 1145: [THEN]
1.1 pazsan 1146:
1147: \ HEX DECIMAL 2may93jaw
1148:
1149: : decimal ( -- ) \ core
1150: a base ! ;
1151: : hex ( -- ) \ core-ext
1152: 10 base ! ;
1153:
1154: \ DEPTH 9may93jaw
1155:
1156: : depth ( -- +n ) \ core
1157: sp@ s0 @ swap - cell / ;
1158: : clearstack ( ... -- )
1159: s0 @ sp! ;
1160:
1161: \ RECURSE 17may93jaw
1162:
1163: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
1164: lastxt compile, ; immediate restrict
1165: ' reveal alias recursive ( -- ) \ gforth
1166: immediate
1167:
1168: \ */MOD */ 17may93jaw
1169:
1170: \ !! I think */mod should have the same rounding behaviour as / - anton
1171: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
1172: >r m* r> sm/rem ;
1173:
1174: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
1175: */mod nip ;
1176:
1177: \ EVALUATE 17may93jaw
1178:
1.14 pazsan 1179: has-files 0= [IF]
1180: : push-file ( -- ) r>
1181: sourceline# >r tibstack @ >r >tib @ >r #tib @ >r
1182: >tib @ tibstack @ = IF r@ tibstack +! THEN
1183: tibstack @ >tib ! >in @ >r >r ;
1184:
1185: : pop-file ( throw-code -- throw-code )
1186: r>
1187: r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> loadline ! >r ;
1188: [THEN]
1189:
1.1 pazsan 1190: : evaluate ( c-addr len -- ) \ core,block
1191: push-file #tib ! >tib !
1192: >in off blk off loadfile off -1 loadline !
1193: ['] interpret catch
1194: pop-file throw ;
1195:
1196: : abort ( ?? -- ?? ) \ core,exception-ext
1197: -1 throw ;
1198:
1199: \+ environment? true ENV" CORE"
1200: \ core wordset is now complete!
1201:
1202: \ Quit 13feb93py
1203:
1204: Defer 'quit
1205: Defer .status
1206: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
1.8 anton 1207: : (Query) ( -- )
1208: loadfile off blk off refill drop ;
1.14 pazsan 1209: : (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
1.1 pazsan 1210: ' (quit) IS 'quit
1211:
1212: \ DOERROR (DOERROR) 13jun93jaw
1213:
1214: 8 Constant max-errors
1215: Variable error-stack 0 error-stack !
1216: max-errors 6 * cells allot
1217: \ format of one cell:
1218: \ source ( addr u )
1219: \ >in
1220: \ line-number
1221: \ Loadfilename ( addr u )
1222:
1223: : dec. ( n -- ) \ gforth
1224: \ print value in decimal representation
1225: base @ decimal swap . base ! ;
1226:
1227: : hex. ( u -- ) \ gforth
1228: \ print value as unsigned hex number
1229: '$ emit base @ swap hex u. base ! ;
1230:
1231: : typewhite ( addr u -- ) \ gforth
1232: \ like type, but white space is printed instead of the characters
1233: bounds ?do
1.10 anton 1234: i c@ #tab = if \ check for tab
1235: #tab
1.1 pazsan 1236: else
1237: bl
1238: then
1239: emit
1240: loop ;
1241:
1242: DEFER DOERROR
1243:
1244: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
1245: cr error-stack @
1246: IF
1247: ." in file included from "
1248: type ." :" dec. drop 2drop
1249: ELSE
1250: type ." :" dec.
1251: cr dup 2over type cr drop
1252: nip -trailing 1- ( line-start index2 )
1253: 0 >r BEGIN
1254: 2dup + c@ bl > WHILE
1255: r> 1+ >r 1- dup 0< UNTIL THEN 1+
1256: ( line-start index1 )
1257: typewhite
1258: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
1259: [char] ^ emit
1260: loop
1261: THEN
1262: ;
1263:
1264: : (DoError) ( throw-code -- )
1265: sourceline# IF
1266: source >in @ sourceline# 0 0 .error-frame
1267: THEN
1268: error-stack @ 0 ?DO
1269: -1 error-stack +!
1270: error-stack dup @ 6 * cells + cell+
1271: 6 cells bounds DO
1272: I @
1273: cell +LOOP
1274: .error-frame
1275: LOOP
1276: dup -2 =
1277: IF
1278: "error @ ?dup
1279: IF
1280: cr count type
1281: THEN
1282: drop
1283: ELSE
1284: .error
1285: THEN
1286: normal-dp dpp ! ;
1287:
1288: ' (DoError) IS DoError
1289:
1290: : quit ( ?? -- ?? ) \ core
1291: r0 @ rp! handler off >tib @ >r
1292: BEGIN
1293: postpone [
1294: ['] 'quit CATCH dup
1295: WHILE
1296: DoError r@ >tib ! r@ tibstack !
1297: REPEAT
1298: drop r> >tib ! ;
1299:
1300: \ Cold 13feb93py
1301:
1302: \ : .name ( name -- ) name>string type space ;
1303: \ : words listwords @
1304: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
1.18 ! anton 1305: Defer 'cold ( -- ) \ gforth tick-cold
! 1306: \ hook (deferred word) for things to do right before interpreting the
! 1307: \ command-line arguments
! 1308: ' noop IS 'cold
1.1 pazsan 1309:
1310: : cold ( -- ) \ gforth
1.14 pazsan 1311: [ has-files [IF] ]
1.1 pazsan 1312: pathstring 2@ process-path pathdirs 2!
1313: init-included-files
1.14 pazsan 1314: [ [THEN] ]
1.17 pazsan 1315: 'cold
1.14 pazsan 1316: [ has-files [IF] ]
1.1 pazsan 1317: argc @ 1 >
1318: IF
1319: ['] process-args catch ?dup
1320: IF
1321: dup >r DoError cr r> negate (bye)
1322: THEN
1323: cr
1324: THEN
1.14 pazsan 1325: [ [THEN] ]
1.1 pazsan 1326: ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
1.14 pazsan 1327: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
1328: [ has-os [IF] ]
1329: cr ." Type `bye' to exit"
1330: [ [THEN] ]
1.1 pazsan 1331: loadline off quit ;
1332:
1333: : license ( -- ) \ gforth
1334: cr
1335: ." This program is free software; you can redistribute it and/or modify" cr
1336: ." it under the terms of the GNU General Public License as published by" cr
1337: ." the Free Software Foundation; either version 2 of the License, or" cr
1338: ." (at your option) any later version." cr cr
1339:
1340: ." This program is distributed in the hope that it will be useful," cr
1341: ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
1342: ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr
1343: ." GNU General Public License for more details." cr cr
1344:
1345: ." You should have received a copy of the GNU General Public License" cr
1346: ." along with this program; if not, write to the Free Software" cr
1347: ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
1348:
1349: : boot ( path **argv argc -- )
1.15 pazsan 1350: main-task up!
1351: [ has-os [IF] ]
1352: stdout TO outfile-id
1353: [ [THEN] ]
1.14 pazsan 1354: [ has-files [IF] ]
1355: argc ! argv ! pathstring 2!
1356: [ [THEN] ]
1357: sp@ s0 !
1358: [ has-locals [IF] ]
1359: lp@ forthstart 7 cells + @ -
1360: [ [ELSE] ]
1361: [ has-os [IF] ]
1362: sp@ $1040 +
1363: [ [ELSE] ]
1364: sp@ $40 +
1365: [ [THEN] ]
1366: [ [THEN] ]
1367: dup >tib ! tibstack ! #tib off >in off
1368: rp@ r0 !
1369: [ has-floats [IF] ]
1370: fp@ f0 !
1371: [ [THEN] ]
1372: ['] cold catch DoError
1373: [ has-os [IF] ]
1374: bye
1375: [ [THEN] ]
1376: ;
1.1 pazsan 1377:
1.14 pazsan 1378: has-os [IF]
1.1 pazsan 1379: : bye ( -- ) \ tools-ext
1.14 pazsan 1380: [ has-files [IF] ]
1381: script? 0= IF cr THEN
1382: [ [ELSE] ]
1383: cr
1384: [ [THEN] ]
1385: 0 (bye) ;
1386: [THEN]
1.1 pazsan 1387:
1388: \ **argv may be scanned by the C starter to get some important
1389: \ information, as -display and -geometry for an X client FORTH
1390: \ or space and stackspace overrides
1391:
1392: \ 0 arg contains, however, the name of the program.
1393:
1394:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to kernel.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth