1: \ KERNAL.FS ANS figFORTH kernal 17dec92py
2: \ $ID:
3: \ Idea and implementation: Bernd Paysan (py)
4: \ Copyright 1992 by the ANSI figForth Development Group
5:
6: \ Log: ', '- usw. durch [char] ... ersetzt
7: \ man sollte die unterschiedlichen zahlensysteme
8: \ mit $ und & zumindest im interpreter weglassen
9: \ schon erledigt!
10: \ 11may93jaw
11: \ name> 0= nicht vorhanden 17may93jaw
12: \ nfa can be lfa or nfa!
13: \ find splited into find and (find)
14: \ (find) for later use 17may93jaw
15: \ search replaced by lookup because
16: \ it is a word of the string wordset
17: \ 20may93jaw
18: \ postpone added immediate 21may93jaw
19: \ to added immediate 07jun93jaw
20: \ cfa, header put "here lastcfa !" in
21: \ cfa, this is more logical
22: \ and noname: works wothout
23: \ extra "here lastcfa !" 08jun93jaw
24: \ (parse-white) thrown out
25: \ refill added outer trick
26: \ to show there is something
27: \ going on 09jun93jaw
28: \ leave ?leave somebody forgot UNLOOP!!! 09jun93jaw
29: \ leave ?leave unloop thrown out
30: \ unloop after loop is used 10jun93jaw
31:
32: HEX
33:
34: \ Bit string manipulation 06oct92py
35:
36: Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
37: DOES> ( n -- ) + c@ ;
38:
39: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
40: : +bit ( addr n -- ) >bit over c@ or swap c! ;
41:
42: : relinfo ( -- addr ) forthstart dup @ + ;
43: : >rel ( addr -- n ) forthstart - ;
44: : relon ( addr -- ) relinfo swap >rel cell / +bit ;
45:
46: \ here allot , c, A, 17dec92py
47:
48: : dp ( -- addr ) dpp @ ;
49: : here ( -- here ) dp @ ;
50: : allot ( n -- ) dp +! ;
51: : c, ( c -- ) here 1 chars allot c! ;
52: : , ( x -- ) here cell allot ! ;
53: : 2, ( w1 w2 -- ) \ general
54: here 2 cells allot 2! ;
55:
56: : aligned ( addr -- addr' )
57: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
58: : align ( -- ) here dup aligned swap ?DO bl c, LOOP ;
59:
60: : A! ( addr1 addr2 -- ) dup relon ! ;
61: : A, ( addr -- ) here cell allot A! ;
62:
63: \ on off 23feb93py
64:
65: : on ( addr -- ) true swap ! ;
66: : off ( addr -- ) false swap ! ;
67:
68: \ name> found 17dec92py
69:
70: : (name>) ( nfa -- cfa ) count $1F and + aligned ;
71: : name> ( nfa -- cfa )
72: dup (name>) swap c@ $80 and 0= IF @ THEN ;
73:
74: : found ( nfa -- cfa n ) cell+
75: dup c@ >r (name>) r@ $80 and 0= IF @ THEN
76: \ -1 r@ $40 and IF 1- THEN
77: -1 r> $20 and IF negate THEN ;
78:
79: \ (find) 17dec92py
80:
81: \ : (find) ( addr count nfa1 -- nfa2 / false )
82: \ BEGIN dup WHILE dup >r
83: \ cell+ count $1F and dup >r 2over r> =
84: \ IF -text 0= IF 2drop r> EXIT THEN
85: \ ELSE 2drop drop THEN r> @
86: \ REPEAT nip nip ;
87:
88: \ place bounds 13feb93py
89:
90: : place ( addr len to -- ) over >r rot over 1+ r> move c! ;
91: : bounds ( beg count -- end beg ) over + swap ;
92:
93: \ input stream primitives 23feb93py
94:
95: : tib >tib @ ;
96: Defer source
97: : (source) ( -- addr count ) tib #tib @ ;
98: ' (source) IS source
99:
100: \ (word) 22feb93py
101:
102: : scan ( addr1 n1 char -- addr2 n2 ) >r
103: BEGIN dup WHILE over c@ r@ <> WHILE 1 /string
104: REPEAT THEN rdrop ;
105: : skip ( addr1 n1 char -- addr2 n2 ) >r
106: BEGIN dup WHILE over c@ r@ = WHILE 1 /string
107: REPEAT THEN rdrop ;
108:
109: : (word) ( addr1 n1 char -- addr2 n2 )
110: dup >r skip 2dup r> scan nip - ;
111:
112: \ (word) should fold white spaces
113: \ this is what (parse-white) does
114:
115: \ word parse 23feb93py
116:
117: : parse-word ( char -- addr len )
118: source 2dup >r >r >in @ /string
119: rot dup bl = IF drop (parse-white) ELSE (word) THEN
120: 2dup + r> - 1+ r> min >in ! ;
121: : word ( char -- addr )
122: parse-word here place bl here count + c! here ;
123:
124: : parse ( char -- addr len )
125: >r source >in @ /string over swap r> scan >r
126: over - dup r> IF 1+ THEN >in +! ;
127:
128: \ name 13feb93py
129:
130: : capitalize ( addr -- addr )
131: dup count chars bounds
132: ?DO I c@ toupper I c! 1 chars +LOOP ;
133: : (name) ( -- addr ) bl word ;
134:
135: \ Literal 17dec92py
136:
137: : Literal ( n -- ) state @ 0= ?EXIT postpone lit , ;
138: immediate
139: : ALiteral ( n -- ) state @ 0= ?EXIT postpone lit A, ;
140: immediate
141:
142: : char ( 'char' -- n ) bl word char+ c@ ;
143: : [char] ( 'char' -- n ) char postpone Literal ; immediate
144: ' [char] Alias Ascii immediate
145:
146: : (compile) ( -- ) r> dup cell+ >r @ A, ;
147: : postpone ( "name" -- )
148: name find dup 0= abort" Can't compile "
149: 0> IF A, ELSE postpone (compile) A, THEN ;
150: immediate restrict
151:
152: \ Use (compile) for the old behavior of compile!
153:
154: \ digit? 17dec92py
155:
156: : digit? ( char -- digit true/ false )
157: base @ $100 = ?dup ?EXIT
158: toupper [char] 0 - dup 9 u> IF
159: [ 'A '9 1 + - ] literal -
160: dup 9 u<= IF
161: drop false EXIT
162: THEN
163: THEN
164: dup base @ u>= IF
165: drop false EXIT
166: THEN
167: true ;
168:
169: : accumulate ( +d0 addr digit - +d1 addr )
170: swap >r swap base @ um* drop rot base @ um* d+ r> ;
171: : >number ( d addr count -- d addr count )
172: 0 ?DO count digit? WHILE accumulate LOOP 0
173: ELSE 1- I' I - UNLOOP THEN ;
174:
175: \ number? number 23feb93py
176:
177: Create bases 10 , 2 , A , 100 ,
178: \ 16 2 10 Zeichen
179: \ !! this saving and restoring base is an abomination! - anton
180: : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u<
181: IF cells bases + @ base ! 1 /string ELSE drop THEN ;
182: : number? ( string -- string 0 / n -1 ) base @ >r
183: dup count over c@ [char] - = dup >r IF 1 /string THEN
184: getbase dpl on 0 0 2swap
185: BEGIN dup >r >number dup WHILE dup r> - WHILE
186: dup dpl ! over c@ [char] . = WHILE
187: 1 /string
188: REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN
189: 2drop rot drop rdrop r> IF dnegate THEN
190: dpl @ dup 0< IF nip THEN r> base ! ;
191: : s>d ( n -- d ) dup 0< ;
192: : number ( string -- d )
193: number? ?dup 0= abort" ?" 0< IF s>d THEN ;
194:
195: \ space spaces ud/mod 21mar93py
196: decimal
197: Create spaces bl 80 times \ times from target compiler! 11may93jaw
198: DOES> ( u -- ) swap
199: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
200: hex
201: : space 1 spaces ;
202:
203: : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r
204: um/mod r> ;
205:
206: : pad ( -- addr )
207: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
208:
209: \ hold <# #> sign # #s 25jan92py
210:
211: : hold ( char -- ) pad cell - -1 chars over +! @ c! ;
212:
213: : <# pad cell - dup ! ;
214:
215: : #> ( 64b -- addr +n ) 2drop pad cell - dup @ tuck - ;
216:
217: : sign ( n -- ) 0< IF [char] - hold THEN ;
218:
219: : # ( +d1 -- +d2 ) base @ 2 max ud/mod rot 9 over <
220: IF [ char A char 9 - 1- ] Literal + THEN [char] 0 + hold ;
221:
222: : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
223:
224: \ print numbers 07jun92py
225:
226: : d.r >r tuck dabs <# #s rot sign #>
227: r> over - spaces type ;
228:
229: : ud.r >r <# #s #> r> over - spaces type ;
230:
231: : .r >r s>d r> d.r ;
232: : u.r 0 swap ud.r ;
233:
234: : d. 0 d.r space ;
235: : ud. 0 ud.r space ;
236:
237: : . s>d d. ;
238: : u. 0 ud. ;
239:
240: \ catch throw 23feb93py
241: \ bounce 08jun93jaw
242:
243: \ !! what about the other stacks (FP, locals) anton
244: \ !! allow the user to add rollback actions anton
245: \ !! use a separate exception stack? anton
246:
247: : lp@ ( -- addr )
248: laddr# [ 0 , ] ;
249:
250: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
251: >r sp@ r> swap >r \ don't count xt! jaw
252: fp@ >r
253: lp@ >r
254: handler @ >r
255: rp@ handler !
256: execute
257: r> handler ! rdrop rdrop rdrop 0 ;
258:
259: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
260: ?DUP IF
261: handler @ rp!
262: r> handler !
263: r> lp!
264: r> fp!
265: r> swap >r sp! r>
266: THEN ;
267:
268: \ Bouncing is very fine,
269: \ programming without wasting time... jaw
270: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
271: \ a throw without data or fp stack restauration
272: ?DUP IF
273: handler @ rp!
274: r> handler !
275: r> lp!
276: rdrop
277: rdrop
278: THEN ;
279:
280: \ ?stack 23feb93py
281:
282: : ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ;
283: \ ?stack should be code -- it touches an empty stack!
284:
285: \ interpret 10mar92py
286:
287: Defer parser
288: Defer name ' (name) IS name
289: Defer notfound
290:
291: : no.extensions ( string -- ) IF &-13 bounce THEN ;
292:
293: ' no.extensions IS notfound
294:
295: : interpret
296: BEGIN ?stack name dup c@ WHILE parser REPEAT drop ;
297:
298: \ interpreter compiler 30apr92py
299:
300: : interpreter ( name -- ) find ?dup
301: IF 1 and IF execute EXIT THEN -&14 throw THEN
302: number? 0= IF notfound THEN ;
303:
304: ' interpreter IS parser
305:
306: : compiler ( name -- ) find ?dup
307: IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup
308: IF 0> IF swap postpone Literal THEN postpone Literal
309: ELSE drop notfound THEN ;
310:
311: : [ ['] interpreter IS parser state off ; immediate
312: : ] ['] compiler IS parser state on ;
313:
314: \ Structural Conditionals 12dec92py
315:
316: : ?struc ( flag -- ) abort" unstructured " ;
317: : sys? ( sys -- ) dup 0= ?struc ;
318: : >mark ( -- sys ) here 0 , ;
319: : >resolve ( sys -- ) here over - swap ! ;
320: : <resolve ( sys -- ) here - , ;
321:
322: : BUT sys? swap ; immediate restrict
323: : YET sys? dup ; immediate restrict
324:
325: \ Structural Conditionals 12dec92py
326:
327: : AHEAD postpone branch >mark ; immediate restrict
328: : IF postpone ?branch >mark ; immediate restrict
329: : ?DUP-IF \ general
330: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
331: \ better handled by tools like stack checkers
332: postpone ?dup postpone IF ; immediate restrict
333: : ?DUP-NOT-IF \ general
334: postpone ?dup postpone 0= postpone if ; immediate restrict
335: : THEN sys? dup @ ?struc >resolve ; immediate restrict
336: ' THEN alias ENDIF immediate restrict \ general
337: \ Same as "THEN". This is what you use if your program will be seen by
338: \ people who have not been brought up with Forth (or who have been
339: \ brought up with fig-Forth).
340:
341: : ELSE sys? postpone AHEAD swap postpone THEN ;
342: immediate restrict
343:
344: : BEGIN here ; immediate restrict
345: : WHILE sys? postpone IF swap ; immediate restrict
346: : AGAIN sys? postpone branch <resolve ; immediate restrict
347: : UNTIL sys? postpone ?branch <resolve ; immediate restrict
348: : REPEAT over 0= ?struc postpone AGAIN postpone THEN ;
349: immediate restrict
350:
351: \ Structural Conditionals 12dec92py
352:
353: variable locals-size \ this is the current size of the locals stack
354: \ frame of the current word
355:
356: : compile-lp+!# ( n -- )
357: ?DUP IF
358: dup negate locals-size +!
359: postpone lp+!# ,
360: THEN ;
361:
362: \ : EXIT ( -- )
363: \ locals-size @ compile-lp+!# POSTPONE ;s ; immediate restrict
364: \ : ?EXIT ( -- )
365: \ postpone IF postpone EXIT postpone THEN ; immediate restrict
366:
367: Variable leavings
368:
369: : (leave) here leavings @ , leavings ! ;
370: : LEAVE postpone branch (leave) ; immediate restrict
371: : ?LEAVE postpone 0= postpone ?branch (leave) ;
372: immediate restrict
373: : DONE ( addr -- )
374: leavings @
375: BEGIN
376: 2dup u<=
377: WHILE
378: dup @ swap >resolve
379: REPEAT
380: leavings ! drop ; immediate restrict
381:
382: \ Structural Conditionals 12dec92py
383:
384: : DO postpone (do) here ; immediate restrict
385:
386: : ?DO postpone (?do) (leave) here ;
387: immediate restrict
388: : FOR postpone (for) here ; immediate restrict
389:
390: : loop] dup <resolve 2 cells - postpone done postpone unloop ;
391:
392: : LOOP sys? postpone (loop) loop] ; immediate restrict
393: : +LOOP sys? postpone (+loop) loop] ; immediate restrict
394: : S+LOOP \ general
395: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" will iterate as often as "high low ?DO inc S+LOOP". For positive increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for negative increments.
396: sys? postpone (s+loop) loop] ; immediate restrict
397: : NEXT sys? postpone (next) loop] ; immediate restrict
398:
399: \ Strings 22feb93py
400:
401: : ," ( "string"<"> -- ) [char] " parse
402: here over char+ allot place align ;
403: : "lit ( -- addr )
404: r> r> dup count + aligned >r swap >r ; restrict
405: : (.") "lit count type ; restrict
406: : (S") "lit count ; restrict
407: : SLiteral postpone (S") here over char+ allot place align ;
408: immediate restrict
409: : S" [char] " parse state @ IF postpone SLiteral THEN ;
410: immediate
411: : ." state @ IF postpone (.") ," align
412: ELSE [char] " parse type THEN ; immediate
413: : ( [char] ) parse 2drop ; immediate
414: : \ source >in ! drop ; immediate
415:
416: \ error handling 22feb93py
417: \ 'abort thrown out! 11may93jaw
418:
419: : (abort") "lit >r IF r> "error ! -2 throw THEN
420: rdrop ;
421: : abort" postpone (abort") ," ; immediate restrict
422:
423: \ Header states 23feb93py
424:
425: : flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ;
426: : immediate $20 flag! ;
427: \ : restrict $40 flag! ;
428: ' noop alias restrict
429:
430: \ Header 23feb93py
431:
432: \ input-stream, nextname and noname are quite ugly (passing
433: \ information through global variables), but they are useful for dealing
434: \ with existing/independent defining words
435:
436: defer header
437:
438: : name, ( "name" -- )
439: name c@ 1+ chars allot align ;
440: : input-stream-header ( "name" -- )
441: \ !! this is f83-implementation-dependent
442: align here last ! -1 A,
443: name, $80 flag! ;
444:
445: : input-stream ( -- ) \ general
446: \ switches back to getting the name from the input stream ;
447: ['] input-stream-header IS header ;
448:
449: ' input-stream-header IS header
450:
451: \ !! make that a 2variable
452: create nextname-buffer 32 chars allot
453:
454: : nextname-header ( -- )
455: \ !! f83-implementation-dependent
456: nextname-buffer count
457: align here last ! -1 A,
458: dup c, here swap chars dup allot move align
459: $80 flag!
460: input-stream ;
461:
462: \ the next name is given in the string
463: : nextname ( c-addr u -- ) \ general
464: dup 31 u> -19 and throw ( is name too long? )
465: nextname-buffer c! ( c-addr )
466: nextname-buffer count move
467: ['] nextname-header IS header ;
468:
469: : noname-header ( -- )
470: 0 last !
471: input-stream ;
472:
473: : noname ( -- ) \ general
474: \ the next defined word remains anonymous. The xt of that word is given by lastxt
475: ['] noname-header IS header ;
476:
477: : lastxt ( -- xt ) \ general
478: \ 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
479: lastcfa @ ;
480:
481: : Alias ( cfa "name" -- )
482: Header reveal , $80 flag! ;
483:
484: : name>string ( nfa -- addr count )
485: cell+ count $1F and ;
486:
487: Create ??? ," ???"
488: : >name ( cfa -- nfa )
489: $21 cell do
490: dup i - count $9F and + aligned over $80 + = if
491: i - cell - unloop exit
492: then
493: cell +loop
494: drop ??? ( wouldn't 0 be better? ) ;
495:
496: \ indirect threading 17mar93py
497:
498: : cfa, ( code-address -- )
499: here lastcfa !
500: here 0 A, 0 , code-address! ;
501: : compile, ( xt -- ) A, ;
502: : !does ( addr -- ) lastcfa @ does-code! ;
503: : (;code) ( R: addr -- ) r> /does-handler + !does ;
504: : dodoes, ( -- )
505: here /does-handler allot does-handler! ;
506:
507: \ direct threading is implementation dependent
508:
509: : Create Header reveal [ :dovar ] Literal cfa, ;
510:
511: \ DOES> 17mar93py
512:
513: : DOES> ( compilation: -- )
514: state @
515: IF
516: ;-hook postpone (;code) dodoes,
517: ELSE
518: dodoes, here !does 0 ]
519: THEN
520: :-hook ; immediate
521:
522: \ Create Variable User Constant 17mar93py
523:
524: : Variable Create 0 , ;
525: : AVariable Create 0 A, ;
526: : 2VARIABLE ( "name" -- ) \ double
527: create 0 , 0 , ;
528:
529: : User Variable ;
530: : AUser AVariable ;
531:
532: : (Constant) Header reveal [ :docon ] Literal cfa, ;
533: : Constant (Constant) , ;
534: : AConstant (Constant) A, ;
535:
536: : 2CONSTANT
537: create ( w1 w2 "name" -- )
538: 2,
539: does> ( -- w1 w2 )
540: 2@ ;
541:
542: \ IS Defer What's Defers TO 24feb93py
543:
544: : Defer
545: Create ( -- )
546: ['] noop A,
547: DOES> ( ??? )
548: @ execute ;
549:
550: : IS ( addr "name" -- )
551: ' >body
552: state @
553: IF postpone ALiteral postpone !
554: ELSE !
555: THEN ; immediate
556: ' IS Alias TO immediate
557:
558: : What's ( "name" -- addr ) ' >body
559: state @ IF postpone ALiteral postpone @ ELSE @ THEN ;
560: immediate
561: : Defers ( "name" -- ) ' >body @ compile, ;
562: immediate restrict
563:
564: \ : ; 24feb93py
565:
566: defer :-hook ( sys1 -- sys2 )
567: defer ;-hook ( sys2 -- sys1 )
568:
569: : EXIT ( -- ) postpone ;s ; immediate
570:
571: : : ( -- colon-sys ) Header [ :docol ] Literal cfa, 0 ] :-hook ;
572: : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ;
573: immediate restrict
574:
575: : :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] :-hook ;
576:
577: \ Search list handling 23feb93py
578:
579: AVariable current
580:
581: : last? ( -- false / nfa nfa ) last @ ?dup ;
582: : (reveal) ( -- )
583: last?
584: IF
585: dup @ 0<
586: IF
587: current @ @ over ! current @ !
588: ELSE
589: drop
590: THEN
591: THEN ;
592:
593: \ object oriented search list 17mar93py
594:
595: \ word list structure:
596: \ struct
597: \ 1 cells: field find-method \ xt: ( c_addr u w1 -- name-id ) w1 is a method-\ specific wordlist-id (not the same as wid)
598: \ 1 cells: field reveal-method \ xt: ( -- )
599: \ \ !! what else
600: \ end-struct wordlist-map-struct
601:
602: \ struct
603: \ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
604: \ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
605: \ 1 cells: field ????
606: \ 1 cells: field ????
607: \ end-struct wordlist-struct
608:
609:
610: \ Search list table: find reveal
611: Create f83search ' (f83find) A, ' (reveal) A,
612: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
613: AVariable search G forth-wordlist search T !
614: G forth-wordlist current T !
615:
616: : (search-wordlist) ( addr count wid -- nfa / false )
617: dup @ swap cell+ @ @ execute ;
618:
619: : search-wordlist ( addr count wid -- 0 / xt +-1 )
620: (search-wordlist) dup IF found THEN ;
621:
622: Variable warnings G -1 warnings T !
623:
624: : check-shadow ( addr count wid -- )
625: \ prints a warning if the string is already present in the wordlist
626: \ !! should be refined so the user can suppress the warnings
627: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
628: ." redefined " name>string 2dup type
629: compare 0<> if
630: ." with " type
631: else
632: 2drop
633: then
634: space space EXIT
635: then
636: 2drop 2drop ;
637:
638: : find ( addr -- cfa +-1 / string false ) dup
639: count search @ search-wordlist dup IF rot drop THEN ;
640:
641: : reveal ( -- )
642: last? if
643: name>string current @ check-shadow
644: then
645: current @ cell+ @ cell+ @ execute ;
646:
647: : ' ( "name" -- addr ) name find 0= no.extensions ;
648: : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
649: \ Input 13feb93py
650:
651: 07 constant #bell
652: 08 constant #bs
653: 7F constant #del
654: 0D constant #cr \ the newline key code
655: 0A constant #lf
656:
657: : bell #bell emit ;
658:
659: : backspaces 0 ?DO #bs emit LOOP ;
660: : >string ( span addr pos1 -- span addr pos1 addr2 len )
661: over 3 pick 2 pick chars /string ;
662: : type-rest ( span addr pos1 -- span addr pos1 back )
663: >string tuck type ;
664: : (del) ( max span addr pos1 -- max span addr pos2 )
665: 1- >string over 1+ -rot move
666: rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
667: : (ins) ( max span addr pos1 char -- max span addr pos2 )
668: >r >string over 1+ swap move 2dup chars + r> swap c!
669: rot 1+ -rot type-rest 1- backspaces 1+ ;
670: : ?del ( max span addr pos1 -- max span addr pos2 0 )
671: dup IF (del) THEN 0 ;
672: : (ret) type-rest drop true space ;
673: : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
674: : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
675:
676: Create crtlkeys
677: ] false false back false false false forw false
678: ?del false (ret) false false (ret) false false
679: false false false false false false false false
680: false false false false false false false false [
681:
682: : decode ( max span addr pos1 key -- max span addr pos2 flag )
683: dup #del = IF drop #bs THEN \ del is rubout
684: dup bl < IF cells crtlkeys + @ execute EXIT THEN
685: >r 2over = IF rdrop bell 0 EXIT THEN
686: r> (ins) 0 ;
687:
688: \ decode should better use a table for control key actions
689: \ to define keyboard bindings later
690:
691: : accept ( addr len -- len )
692: dup 0< IF abs over dup 1 chars - c@ tuck type
693: \ this allows to edit given strings
694: ELSE 0 THEN rot over
695: BEGIN key decode UNTIL
696: 2drop nip ;
697:
698: \ Output 13feb93py
699:
700: DEFER type \ defer type for a output buffer or fast
701: \ screen write
702:
703: : (type) ( addr len -- )
704: bounds ?DO I c@ emit LOOP ;
705:
706: ' (TYPE) IS Type
707:
708: \ DEFER Emit
709:
710: \ ' (Emit) IS Emit
711:
712: \ : form ( -- rows cols ) &24 &80 ;
713: \ form should be implemented using TERMCAPS or CURSES
714: \ : rows form drop ;
715: \ : cols form nip ;
716:
717: \ Query 07apr93py
718:
719: : refill ( -- flag )
720: tib /line
721: loadfile @ ?dup
722: IF dup file-position throw linestart 2!
723: read-line throw
724: ELSE linestart @ IF 2drop false EXIT THEN
725: accept true
726: THEN
727: 1 loadline +!
728: swap #tib ! >in off ;
729:
730: : Query ( -- ) loadfile off refill drop ;
731:
732: \ File specifiers 11jun93jaw
733:
734:
735: \ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c,
736: \ 2 c, here char r c, char + c, 0 c,
737: \ 2 c, here char w c, char + c, 0 c, align
738: 4 Constant w/o
739: 2 Constant r/w
740: 0 Constant r/o
741:
742: \ BIN WRITE-LINE 11jun93jaw
743:
744: \ : bin dup 1 chars - c@
745: \ r/o 4 chars + over - dup >r swap move r> ;
746:
747: : bin 1+ ;
748:
749: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
750: \ or not unix environments if
751: \ bin is not selected
752:
753: : write-line dup >r write-file ?dup IF r> drop EXIT THEN
754: nl$ count r> write-file ;
755:
756: \ include-file 07apr93py
757:
758: : include-file ( i*x fid -- j*x )
759: linestart @ >r loadline @ >r loadfile @ >r
760: blk @ >r >tib @ >r #tib @ dup >r >in @ >r
761:
762: >tib +! loadfile !
763: 0 loadline ! blk off
764: BEGIN refill WHILE interpret REPEAT
765: loadfile @ close-file throw
766:
767: r> >in ! r> #tib ! r> >tib ! r> blk !
768: r> loadfile ! r> loadline ! r> linestart ! ;
769:
770: : included ( i*x addr u -- j*x )
771: r/o open-file throw include-file ;
772:
773: \ HEX DECIMAL 2may93jaw
774:
775: : decimal a base ! ;
776: : hex 10 base ! ;
777:
778: \ DEPTH 9may93jaw
779:
780: : depth ( -- +n ) sp@ s0 @ swap - cell / ;
781:
782: \ INCLUDE 9may93jaw
783:
784: : include ( "file" -- )
785: bl word count included ;
786:
787: \ RECURSE 17may93jaw
788:
789: : recurse last @ cell+ name> a, ; immediate restrict
790: \ !! does not work with anonymous words; use lastxt compile,
791:
792: \ */MOD */ 17may93jaw
793:
794: : */mod >r m* r> sm/rem ;
795:
796: : */ */mod nip ;
797:
798: \ EVALUATE 17may93jaw
799:
800: : evaluate ( c-addr len -- )
801: linestart @ >r loadline @ >r loadfile @ >r
802: blk @ >r >tib @ >r #tib @ dup >r >in @ >r
803:
804: >tib +! dup #tib ! >tib @ swap move
805: >in off blk off loadfile off -1 linestart !
806:
807: BEGIN interpret >in @ #tib @ u>= UNTIL
808:
809: r> >in ! r> #tib ! r> >tib ! r> blk !
810: r> loadfile ! r> loadline ! r> linestart ! ;
811:
812:
813: : abort -1 throw ;
814:
815: \+ environment? true ENV" CORE"
816: \ core wordset is now complete!
817:
818: \ Quit 13feb93py
819:
820: Defer 'quit
821: Defer .status
822: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
823: : (quit) BEGIN .status cr query interpret prompt AGAIN ;
824: ' (quit) IS 'quit
825:
826: \ DOERROR (DOERROR) 13jun93jaw
827:
828: DEFER DOERROR
829:
830: : (DoError) ( throw-code -- )
831: LoadFile @
832: IF
833: ." Error in line: " Loadline @ . cr
834: THEN
835: cr source type cr
836: source drop >in @ -trailing
837: here c@ 1F min dup >r - 1- 0 max nip
838: dup spaces
839: IF
840: ." ^"
841: THEN
842: r> 0 ?DO
843: ." -"
844: LOOP
845: ." ^"
846: dup -2 =
847: IF
848: "error @ ?dup
849: IF
850: cr count type
851: THEN
852: drop
853: ELSE
854: .error
855: THEN
856: normal-dp dpp ! ;
857:
858: ' (DoError) IS DoError
859:
860: : quit r0 @ rp! handler off >tib @ >r
861: BEGIN
862: postpone [
863: ['] 'quit CATCH dup
864: WHILE
865: DoError r@ >tib !
866: REPEAT
867: drop r> >tib ! ;
868:
869: \ Cold 13feb93py
870:
871: \ : .name ( name -- ) cell+ count $1F and type space ;
872: \ : words listwords @
873: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
874:
875: : >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ;
876: : arg ( n -- addr count ) cells argv @ + @ >len ;
877: : #! postpone \ ; immediate
878:
879: Variable env
880: Variable argv
881: Variable argc
882:
883: : get-args ( -- ) #tib off
884: argc @ 1 ?DO I arg 2dup source + swap move
885: #tib +! drop bl source + c! 1 #tib +! LOOP
886: >in off #tib @ 0<> #tib +! ;
887:
888: : script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ;
889:
890: : cold ( -- )
891: argc @ 1 >
892: IF script?
893: IF 1 arg ['] included ELSE get-args ['] interpret THEN
894: catch ?dup IF dup >r DoError cr r> (bye) THEN THEN
895: ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
896:
897: : boot ( **env **argv argc -- )
898: argc ! argv ! env ! main-task up!
899: sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;
900:
901: : bye cr 0 (bye) ;
902:
903: \ **argv may be scanned by the C starter to get some important
904: \ information, as -display and -geometry for an X client FORTH
905: \ or space and stackspace overrides
906:
907: \ 0 arg contains, however, the name of the program.
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to kernal.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth