File:
[gforth] /
gforth /
prims2x.fs
Revision
1.15:
download - view:
text,
annotated -
select for diffs
Mon Oct 16 18:33:12 1995 UTC (28 years, 5 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines
1: \ This is not very nice (hard limits, no checking, assumes 1 chars = 1)
2:
3: \ Optimizations:
4: \ superfluous stores are removed. GCC removes the superfluous loads by itself
5: \ TOS and FTOS can be kept in register( variable)s.
6: \
7: \ Problems:
8: \ The TOS optimization is somewhat hairy. The problems by example:
9: \ 1) dup ( w -- w w ): w=TOS; sp-=1; sp[1]=w; TOS=w;
10: \ The store is not superfluous although the earlier opt. would think so
11: \ Alternatively: sp[0]=TOS; w=TOS; sp-=1; TOS=w;
12: \ 2) ( -- .. ): sp[0] = TOS; ... /* This additional store is necessary */
13: \ 3) ( .. -- ): ... TOS = sp[0]; /* as well as this load */
14: \ 4) ( -- ): /* but here they are unnecessary */
15: \ 5) Words that call NEXT themselves have to be done very carefully.
16: \
17: \ To do:
18: \ add the store optimization for doubles
19: \ regarding problem 1 above: It would be better (for over) to implement
20: \ the alternative
21:
22: warnings off
23:
24: [IFUNDEF] vocabulary include search-order.fs [THEN]
25: [IFUNDEF] environment? include environ.fs [THEN]
26: include gray.fs
27:
28: 100 constant max-effect \ number of things on one side of a stack effect
29: 4096 constant batch-size \ no meaning, just make sure it's >0
30: 255 constant maxchar
31: maxchar 1+ constant eof-char
32: 9 constant tab-char
33: 10 constant nl-char
34:
35: : read-whole-file ( c-addr1 file-id -- c-addr2 )
36: \ reads the contents of the file file-id puts it into memory at c-addr1
37: \ c-addr2 is the first address after the file block
38: begin ( c-addr file-id )
39: 2dup batch-size swap read-file
40: if
41: true abort" I/O error"
42: endif
43: ( c-addr file-id actual-size ) rot over + -rot
44: batch-size <>
45: until
46: drop ;
47:
48: variable input \ pointer to next character to be parsed
49: variable endinput \ pointer to the end of the input (the char after the last)
50:
51: : start ( -- addr )
52: input @ ;
53:
54: : end ( addr -- addr u )
55: input @ over - ;
56:
57: variable output \ xt ( -- ) of output word
58:
59: : printprim ( -- )
60: output @ execute ;
61:
62: : field
63: <builds-field ( n1 n2 -- n3 )
64: does> ( addr1 -- addr2 )
65: @ + ;
66:
67: : const-field
68: <builds-field ( n1 n2 -- n3 )
69: does> ( addr -- w )
70: @ + @ ;
71:
72: struct
73: 2 cells field item-name
74: cell field item-d-offset
75: cell field item-f-offset
76: cell field item-type
77: constant item-descr
78:
79: 2variable forth-name
80: 2variable wordset
81: 2variable c-name
82: 2variable doc
83: 2variable c-code
84: 2variable forth-code
85: 2variable stack-string
86: create effect-in max-effect item-descr * allot
87: create effect-out max-effect item-descr * allot
88: variable effect-in-end ( pointer )
89: variable effect-out-end ( pointer )
90: 2variable effect-in-size
91: 2variable effect-out-size
92:
93: variable primitive-number -10 primitive-number !
94:
95: \ for several reasons stack items of a word are stored in a wordlist
96: \ since neither forget nor marker are implemented yet, we make a new
97: \ wordlist for every word and store it in the variable items
98: variable items
99:
100: \ a few more set ops
101:
102: : bit-equivalent ( w1 w2 -- w3 )
103: xor invert ;
104:
105: : complement ( set1 -- set2 )
106: empty ['] bit-equivalent binary-set-operation ;
107:
108: \ the parser
109:
110: eof-char max-member \ the whole character set + EOF
111:
112: : getinput ( -- n )
113: input @
114: dup endinput @ =
115: if
116: drop eof-char
117: else
118: c@
119: endif ;
120:
121: :noname ( n -- )
122: dup bl > if
123: emit space
124: else
125: .
126: endif ;
127: print-token !
128:
129: : testchar? ( set -- f )
130: getinput member? ;
131: ' testchar? test-vector !
132:
133: : ?nextchar ( f -- )
134: ?not? if
135: ." syntax error" cr
136: getinput . cr
137: input @ endinput @ over - 100 min type cr
138: abort
139: endif
140: input @ endinput @ <> if
141: 1 input +!
142: endif ;
143:
144: : charclass ( set "name" -- )
145: ['] ?nextchar terminal ;
146:
147: : .. ( c1 c2 -- set )
148: ( creates a set that includes the characters c, c1<=c<=c2 )
149: empty copy-set
150: swap 1+ rot do
151: i over add-member
152: loop ;
153:
154: : ` ( -- terminal ) ( use: ` c )
155: ( creates anonymous terminal for the character c )
156: [compile] ascii singleton ['] ?nextchar make-terminal ;
157:
158: char a char z .. char A char Z .. union char _ singleton union charclass letter
159: char 0 char 9 .. charclass digit
160: bl singleton charclass blank
161: tab-char singleton charclass tab
162: nl-char singleton eof-char over add-member complement charclass nonl
163: nl-char singleton eof-char over add-member char : over add-member complement charclass nocolonnl
164: bl 1+ maxchar .. charclass nowhite
165: char " singleton eof-char over add-member complement charclass noquote
166: nl-char singleton charclass nl
167: eof-char singleton charclass eof
168:
169:
170: (( letter (( letter || digit )) **
171: )) <- c-name ( -- )
172:
173: nowhite ++
174: <- name ( -- )
175:
176: (( ` \ nonl ** nl
177: )) <- comment ( -- )
178:
179: (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
180: ` - ` - blank **
181: {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
182: )) <- stack-effect ( -- )
183:
184: (( {{ s" " doc 2! s" " forth-code 2! }}
185: (( comment || nl )) **
186: (( {{ start }} name {{ end 2dup forth-name 2! c-name 2! }} tab ++
187: {{ start }} stack-effect {{ end stack-string 2! }} tab ++
188: {{ start }} name {{ end wordset 2! }} tab **
189: (( {{ start }} c-name {{ end c-name 2! }} )) ?? nl
190: ))
191: (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
192: {{ start }} (( nocolonnl nonl ** nl )) ** {{ end c-code 2! }}
193: (( ` : nl
194: {{ start }} (( nonl ++ nl )) ++ {{ end forth-code 2! }}
195: )) ??
196: (( nl || eof ))
197: )) <- primitive ( -- )
198:
199: (( (( primitive {{ printprim }} )) ** eof ))
200: parser primitives2something
201: warnings @ [IF]
202: .( parser generated ok ) cr
203: [THEN]
204:
205: : primfilter ( file-id xt -- )
206: \ fileid is for the input file, xt ( -- ) is for the output word
207: output !
208: here input !
209: here swap read-whole-file
210: dup endinput !
211: here - allot
212: align
213: primitives2something ;
214:
215: \ types
216:
217: struct
218: 2 cells field type-c-name
219: cell const-field type-d-size
220: cell const-field type-f-size
221: cell const-field type-fetch-handler
222: cell const-field type-store-handler
223: constant type-description
224:
225: : data-stack-access ( n1 n2 n3 -- )
226: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
227: drop swap - 1- dup
228: if
229: ." sp[" 0 .r ." ]"
230: else
231: drop ." TOS"
232: endif ;
233:
234: : fp-stack-access ( n1 n2 n3 -- )
235: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
236: nip swap - 1- dup
237: if
238: ." fp[" 0 .r ." ]"
239: else
240: drop ." FTOS"
241: endif ;
242:
243: : fetch-single ( item -- )
244: >r
245: r@ item-name 2@ type
246: ." = ("
247: r@ item-type @ type-c-name 2@ type ." ) "
248: r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
249: rdrop ;
250:
251: : fetch-double ( item -- )
252: >r
253: r@ item-name 2@ type
254: ." = ({Double_Store _d; _d.cells.low = "
255: r@ item-d-offset @ dup effect-in-size 2@ data-stack-access
256: ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access
257: ." ; _d.dcell;});" cr
258: rdrop ;
259:
260: : fetch-float ( item -- )
261: >r
262: r@ item-name 2@ type
263: ." = "
264: \ ." (" r@ item-type @ type-c-name 2@ type ." ) "
265: r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
266: rdrop ;
267:
268: : d-same-as-in? ( item -- f )
269: \ f is true iff the offset of item is the same as on input
270: >r
271: r@ item-name 2@ items @ search-wordlist 0=
272: abort" bug"
273: execute @
274: dup r@ =
275: if \ item first appeared in output
276: drop false
277: else
278: item-d-offset @ r@ item-d-offset @ =
279: endif
280: rdrop ;
281:
282: : is-in-tos? ( item -- f )
283: \ true if item has the same offset as the input TOS
284: item-d-offset @ 1+ effect-in-size 2@ drop = ;
285:
286: : really-store-single ( item -- )
287: >r
288: r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)"
289: r@ item-name 2@ type ." ;"
290: rdrop ;
291:
292: : store-single ( item -- )
293: >r
294: r@ d-same-as-in?
295: if
296: r@ is-in-tos?
297: if
298: ." IF_TOS(" r@ really-store-single ." );" cr
299: endif
300: else
301: r@ really-store-single cr
302: endif
303: rdrop ;
304:
305: : store-double ( item -- )
306: \ !! store optimization is not performed, because it is not yet needed
307: >r
308: ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; "
309: r@ item-d-offset @ dup effect-out-size 2@ data-stack-access
310: ." = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
311: ." = _d.cells.high;}" cr
312: rdrop ;
313:
314: : f-same-as-in? ( item -- f )
315: \ f is true iff the offset of item is the same as on input
316: >r
317: r@ item-name 2@ items @ search-wordlist 0=
318: abort" bug"
319: execute @
320: dup r@ =
321: if \ item first appeared in output
322: drop false
323: else
324: item-f-offset @ r@ item-f-offset @ =
325: endif
326: rdrop ;
327:
328: : is-in-ftos? ( item -- f )
329: \ true if item has the same offset as the input TOS
330: item-f-offset @ 1+ effect-in-size 2@ nip = ;
331:
332: : really-store-float ( item -- )
333: >r
334: r@ item-f-offset @ effect-out-size 2@ fp-stack-access ." = "
335: r@ item-name 2@ type ." ;"
336: rdrop ;
337:
338: : store-float ( item -- )
339: >r
340: r@ f-same-as-in?
341: if
342: r@ is-in-ftos?
343: if
344: ." IF_FTOS(" r@ really-store-float ." );" cr
345: endif
346: else
347: r@ really-store-float cr
348: endif
349: rdrop ;
350:
351: : single-type ( -- xt1 xt2 n1 n2 )
352: ['] fetch-single ['] store-single 1 0 ;
353:
354: : double-type ( -- xt1 xt2 n1 n2 )
355: ['] fetch-double ['] store-double 2 0 ;
356:
357: : float-type ( -- xt1 xt2 n1 n2 )
358: ['] fetch-float ['] store-float 0 1 ;
359:
360: : s, ( addr u -- )
361: \ allocate a string
362: here swap dup allot move ;
363:
364: : starts-with ( addr u xt1 xt2 n1 n2 "prefix" -- )
365: \ describes a type
366: \ addr u specifies the C type name
367: \ n1 is the size of the type on the data stack
368: \ n2 is the size of the type on the FP stack
369: \ stack effect entries of the type start with prefix
370: >r >r >r >r
371: dup >r here >r s,
372: create
373: r> r> 2,
374: r> r> r> , r> , swap , , ;
375:
376: wordlist constant types
377: get-current
378: types set-current
379:
380: s" Bool" single-type starts-with f
381: s" Char" single-type starts-with c
382: s" Cell" single-type starts-with n
383: s" Cell" single-type starts-with w
384: s" UCell" single-type starts-with u
385: s" DCell" double-type starts-with d
386: s" UDCell" double-type starts-with ud
387: s" Float" float-type starts-with r
388: s" Cell *" single-type starts-with a_
389: s" Char *" single-type starts-with c_
390: s" Float *" single-type starts-with f_
391: s" DFloat *" single-type starts-with df_
392: s" SFloat *" single-type starts-with sf_
393: s" Xt" single-type starts-with xt
394: s" WID" single-type starts-with wid
395: s" F83Name *" single-type starts-with f83name
396:
397: set-current
398:
399: : get-type ( addr1 u1 -- type-descr )
400: \ get the type of the name in addr1 u1
401: \ type-descr is a pointer to a type-descriptor
402: 0 swap ?do
403: dup i types search-wordlist
404: if \ ok, we have the type ( addr1 xt )
405: execute nip
406: UNLOOP EXIT
407: endif
408: -1 s+loop
409: \ we did not find a type, abort
410: true abort" unknown type prefix" ;
411:
412: : declare ( addr "name" -- )
413: \ remember that there is a stack item at addr called name
414: create , ;
415:
416: : declaration ( item -- )
417: dup item-name 2@ items @ search-wordlist
418: if \ already declared ( item xt )
419: execute @ item-type @ swap item-type !
420: else ( addr )
421: dup item-name 2@ nextname dup declare ( addr )
422: dup >r item-name 2@ 2dup get-type ( addr1 u type-descr )
423: dup r> item-type ! ( addr1 u type-descr )
424: type-c-name 2@ type space type ." ;" cr
425: endif ;
426:
427: : declaration-list ( addr1 addr2 -- )
428: swap ?do
429: i declaration
430: item-descr +loop ;
431:
432: : fetch ( addr -- )
433: dup item-type @ type-fetch-handler execute ;
434:
435: : declarations ( -- )
436: wordlist dup items ! set-current
437: effect-in effect-in-end @ declaration-list
438: effect-out effect-out-end @ declaration-list ;
439:
440: \ offset computation
441: \ the leftmost (i.e. deepest) item has offset 0
442: \ the rightmost item has the highest offset
443:
444: : compute-offset ( n1 n2 item -- n3 n4 )
445: \ n1, n3 are data-stack-offsets
446: \ n2, n4 are the fp-stack-offsets
447: >r
448: swap dup r@ item-d-offset !
449: r@ item-type @ type-d-size +
450: swap dup r@ item-f-offset !
451: r@ item-type @ type-f-size +
452: rdrop ;
453:
454: : compute-list ( addr1 addr2 -- n1 n2 )
455: \ n1, n2 are the final offsets
456: 0 0 2swap swap ?do
457: i compute-offset
458: item-descr +loop ;
459:
460: : compute-offsets ( -- )
461: effect-in effect-in-end @ compute-list effect-in-size 2!
462: effect-out effect-out-end @ compute-list effect-out-size 2! ;
463:
464: : flush-tos ( -- )
465: effect-in-size 2@ effect-out-size 2@
466: 0<> rot 0= and
467: if
468: ." IF_FTOS(fp[0] = FTOS);" cr
469: endif
470: 0<> swap 0= and
471: if
472: ." IF_TOS(sp[0] = TOS);" cr
473: endif ;
474:
475: : fill-tos ( -- )
476: effect-in-size 2@ effect-out-size 2@
477: 0= rot 0<> and
478: if
479: ." IF_FTOS(FTOS = fp[0]);" cr
480: endif
481: 0= swap 0<> and
482: if
483: ." IF_TOS(TOS = sp[0]);" cr
484: endif ;
485:
486: : fetches ( -- )
487: effect-in-end @ effect-in ?do
488: i fetch
489: item-descr +loop ;
490:
491: : stack-pointer-updates ( -- )
492: \ we need not check if an update is a noop; gcc does this for us
493: effect-in-size 2@
494: effect-out-size 2@
495: rot swap - ( d-in d-out f-diff )
496: rot rot - ( f-diff d-diff )
497: ?dup IF ." sp += " 0 .r ." ;" cr THEN
498: ?dup IF ." fp += " 0 .r ." ;" cr THEN ;
499:
500: : store ( item -- )
501: \ f is true if the item should be stored
502: \ f is false if the store is probably not necessary
503: dup item-type @ type-store-handler execute ;
504:
505: : stores ( -- )
506: effect-out-end @ effect-out ?do
507: i store
508: item-descr +loop ;
509:
510: : .stack-list ( start end -- )
511: swap ?do
512: i item-name 2@ type space
513: item-descr +loop ;
514:
515: : output-c ( -- )
516: ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
517: ." /* " doc 2@ type ." */" cr
518: ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
519: ." {" cr
520: ." DEF_CA" cr
521: declarations
522: compute-offsets \ for everything else
523: ." NEXT_P0;" cr
524: flush-tos
525: fetches
526: stack-pointer-updates
527: ." {" cr
528: c-code 2@ type
529: ." }" cr
530: ." NEXT_P1;" cr
531: stores
532: fill-tos
533: ." NEXT_P2;" cr
534: ." }" cr
535: cr
536: ;
537:
538: : output-label ( -- )
539: ." &&I_" c-name 2@ type ." ," cr ;
540:
541: : output-alias ( -- )
542: primitive-number @ . ." alias " forth-name 2@ type cr
543: -1 primitive-number +! ;
544:
545: : output-forth ( -- )
546: forth-code @ 0=
547: IF output-alias
548: ELSE ." : " forth-name 2@ type ." ( "
549: effect-in effect-in-end @ .stack-list ." -- "
550: effect-out effect-out-end @ .stack-list ." )" cr
551: forth-code 2@ type cr
552: -1 primitive-number +!
553: THEN ;
554:
555: [IFDEF] documentation
556: : register-doc ( -- )
557: get-current documentation set-current
558: forth-name 2@ nextname create
559: forth-name 2@ 2,
560: stack-string 2@ condition-stack-effect 2,
561: wordset 2@ 2,
562: c-name 2@ condition-pronounciation 2,
563: doc 2@ 2,
564: set-current ;
565: [THEN]
566:
567: : process-file ( addr u xt -- )
568: >r r/o open-file abort" cannot open file"
569: warnings @ if
570: ." ------------ CUT HERE -------------" cr endif
571: r> primfilter ;
572:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>