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