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