File:
[gforth] /
gforth /
prims2x.fs
Revision
1.4:
download - view:
text,
annotated -
select for diffs
Wed Jul 13 19:21:07 1994 UTC (29 years, 8 months ago) by
pazsan
Branches:
MAIN
CVS tags:
HEAD
Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).
Added restrict's functionalitz to cross.fs
removed all occurency of cell+ name>, because the bug in name> is
fixed.
Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.
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: include gray.fs
25: include search-order.fs
26:
27: 100 constant max-effect \ number of things on one side of a stack effect
28: 4096 constant batch-size \ no meaning, just make sure it's >0
29: 255 constant maxchar
30: maxchar 1+ constant eof-char
31: 9 constant tab-char
32: 10 constant nl-char
33:
34: : read-whole-file ( c-addr1 file-id -- c-addr2 )
35: \ reads the contents of the file file-id puts it into memory at c-addr1
36: \ c-addr2 is the first address after the file block
37: begin ( c-addr file-id )
38: 2dup batch-size swap read-file
39: if
40: abort" I/O error"
41: endif
42: ( c-addr file-id actual-size ) rot over + -rot
43: batch-size <>
44: until
45: drop ;
46:
47: variable input \ pointer to next character to be parsed
48: variable endinput \ pointer to the end of the input (the char after the last)
49:
50: : start ( -- addr )
51: input @ ;
52:
53: : end ( addr -- addr u )
54: input @ over - ;
55:
56: variable output \ xt ( -- ) of output word
57:
58: : printprim ( -- )
59: output @ execute ;
60:
61: : field
62: <builds-field ( n1 n2 -- n3 )
63: does> ( addr1 -- addr2 )
64: @ + ;
65:
66: : const-field
67: <builds-field ( n1 n2 -- n3 )
68: does> ( addr -- w )
69: @ + @ ;
70:
71: struct
72: 2 cells field item-name
73: cell field item-d-offset
74: cell field item-f-offset
75: cell field item-type
76: constant item-descr
77:
78: 2variable forth-name
79: 2variable wordset
80: 2variable c-name
81: 2variable doc
82: 2variable c-code
83: 2variable forth-code
84: 2variable stack-string
85: create effect-in max-effect item-descr * allot
86: create effect-out max-effect item-descr * allot
87: variable effect-in-end ( pointer )
88: variable effect-out-end ( pointer )
89: 2variable effect-in-size
90: 2variable effect-out-size
91:
92: variable primitive-number -8 primitive-number !
93:
94: \ for several reasons stack items of a word are stored in a wordlist
95: \ since neither forget nor marker are implemented yet, we make a new
96: \ wordlist for every word and store it in the variable items
97: variable items
98:
99: \ a few more set ops
100:
101: : bit-equivalent ( w1 w2 -- w3 )
102: xor invert ;
103:
104: : complement ( set1 -- set2 )
105: empty ['] bit-equivalent binary-set-operation ;
106:
107: \ the parser
108:
109: eof-char max-member \ the whole character set + EOF
110:
111: : getinput ( -- n )
112: input @
113: dup endinput @ =
114: if
115: drop eof-char
116: else
117: c@
118: endif ;
119:
120: :noname ( n -- )
121: dup bl > if
122: emit space
123: else
124: .
125: endif ;
126: print-token !
127:
128: : testchar? ( set -- f )
129: getinput member? ;
130: ' testchar? test-vector !
131:
132: : ?nextchar ( f -- )
133: ?not? if
134: ." syntax error" cr
135: getinput . cr
136: input @ endinput @ over - 100 min type cr
137: abort
138: endif
139: input @ endinput @ <> if
140: 1 input +!
141: endif ;
142:
143: : charclass ( set "name" -- )
144: ['] ?nextchar terminal ;
145:
146: : .. ( c1 c2 -- set )
147: ( creates a set that includes the characters c, c1<=c<=c2 )
148: empty copy-set
149: swap 1+ rot do
150: i over add-member
151: loop ;
152:
153: : ` ( -- terminal ) ( use: ` c )
154: ( creates anonymous terminal for the character c )
155: [compile] ascii singleton ['] ?nextchar make-terminal ;
156:
157: char a char z .. char A char Z .. union char _ singleton union charclass letter
158: char 0 char 9 .. charclass digit
159: bl singleton charclass blank
160: tab-char singleton charclass tab
161: nl-char singleton eof-char over add-member complement charclass nonl
162: nl-char singleton eof-char over add-member char : over add-member complement charclass nocolonnl
163: bl 1+ maxchar .. charclass nowhite
164: char " singleton eof-char over add-member complement charclass noquote
165: nl-char singleton charclass nl
166: eof-char singleton charclass eof
167:
168:
169: (( letter (( letter || digit )) **
170: )) <- c-name ( -- )
171:
172: nowhite ++
173: <- name ( -- )
174:
175: (( ` \ nonl ** nl
176: )) <- comment ( -- )
177:
178: (( {{ effect-in }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-in-end ! }}
179: ` - ` - blank **
180: {{ effect-out }} (( {{ start }} c-name {{ end 2 pick item-name 2! item-descr + }} blank ** )) ** {{ effect-out-end ! }}
181: )) <- stack-effect ( -- )
182:
183: (( {{ s" " doc 2! s" " forth-code 2! }}
184: (( comment || nl )) **
185: (( {{ start }} name {{ end 2dup forth-name 2! c-name 2! }} tab ++
186: {{ start }} stack-effect {{ end stack-string 2! }} tab ++
187: {{ start }} name {{ end wordset 2! }} tab **
188: (( {{ start }} c-name {{ end c-name 2! }} )) ?? nl
189: ))
190: (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- doc 2! }} ` " nl )) ??
191: {{ start }} (( nocolonnl nonl ** nl )) ** {{ end c-code 2! }}
192: (( ` : nl
193: {{ start }} (( nonl ++ nl )) ++ {{ end forth-code 2! }}
194: )) ??
195: (( nl || eof ))
196: )) <- primitive ( -- )
197:
198: (( (( primitive {{ printprim }} )) ** eof ))
199: parser primitives2something
200: warnings @ [IF]
201: .( parser generated ok ) cr
202: [THEN]
203:
204: : primfilter ( file-id xt -- )
205: \ fileid is for the input file, xt ( -- ) is for the output word
206: output !
207: here input !
208: here swap read-whole-file
209: dup endinput !
210: here - allot
211: align
212: primitives2something ;
213:
214: \ types
215:
216: struct
217: 2 cells field type-c-name
218: cell const-field type-d-size
219: cell const-field type-f-size
220: cell const-field type-fetch-handler
221: cell const-field type-store-handler
222: constant type-description
223:
224: : data-stack-access ( n1 n2 n3 -- )
225: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
226: drop swap - 1- dup
227: if
228: ." sp[" 0 .r ." ]"
229: else
230: drop ." TOS"
231: endif ;
232:
233: : fp-stack-access ( n1 n2 n3 -- )
234: \ n1 is the offset of the accessed item, n2, n3 are effect-*-size
235: nip swap - 1- dup
236: if
237: ." fp[" 0 .r ." ]"
238: else
239: drop ." FTOS"
240: endif ;
241:
242: : fetch-single ( item -- )
243: >r
244: r@ item-name 2@ type ." = ("
245: r@ item-type @ type-c-name 2@ type ." ) "
246: r@ item-d-offset @ effect-in-size 2@ data-stack-access ." ;" cr
247: rdrop ;
248:
249: : fetch-double ( item -- )
250: >r
251: ." {Double_Store _d; _d.cells.low = "
252: r@ item-d-offset @ dup effect-in-size 2@ data-stack-access
253: ." ; _d.cells.high = " 1+ effect-in-size 2@ data-stack-access ." ; "
254: r@ item-name 2@ type ." = _d.dcell;}" cr
255: rdrop ;
256:
257: : fetch-float ( item -- )
258: >r
259: r@ item-name 2@ type ." = "
260: \ ." (" r@ item-type @ type-c-name 2@ type ." ) "
261: r@ item-f-offset @ effect-in-size 2@ fp-stack-access ." ;" cr
262: rdrop ;
263:
264: : d-same-as-in? ( item -- f )
265: \ f is true iff the offset of item is the same as on input
266: >r
267: r@ item-name 2@ items @ search-wordlist 0=
268: if
269: ." bug" cr abort
270: endif
271: execute @
272: dup r@ =
273: if \ item first appeared in output
274: drop false
275: else
276: item-d-offset @ r@ item-d-offset @ =
277: endif
278: rdrop ;
279:
280: : is-in-tos? ( item -- f )
281: \ true if item has the same offset as the input TOS
282: item-d-offset @ 1+ effect-in-size 2@ drop = ;
283:
284: : really-store-single ( item -- )
285: >r
286: r@ item-d-offset @ effect-out-size 2@ data-stack-access ." = (Cell)"
287: r@ item-name 2@ type ." ;"
288: rdrop ;
289:
290: : store-single ( item -- )
291: >r
292: r@ d-same-as-in?
293: if
294: r@ is-in-tos?
295: if
296: ." IF_TOS(" r@ really-store-single ." );" cr
297: endif
298: else
299: r@ really-store-single cr
300: endif
301: rdrop ;
302:
303: : store-double ( item -- )
304: \ !! store optimization is not performed, because it is not yet needed
305: >r
306: ." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; "
307: r@ item-d-offset @ dup effect-out-size 2@ data-stack-access
308: ." = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
309: ." = _d.cells.high;}" cr
310: rdrop ;
311:
312: : f-same-as-in? ( item -- f )
313: \ f is true iff the offset of item is the same as on input
314: >r
315: r@ item-name 2@ items @ search-wordlist 0=
316: if
317: ." bug" cr abort
318: endif
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 ( -- xt n1 n2 )
352: ['] fetch-single ['] store-single 1 0 ;
353:
354: : double-type ( -- xt n1 n2 )
355: ['] fetch-double ['] store-double 2 0 ;
356:
357: : float-type ( -- xt 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: ." unknown type prefix" cr ABORT ;
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: : declarations ( -- )
433: wordlist dup items ! set-current
434: effect-in effect-in-end @ declaration-list
435: effect-out effect-out-end @ declaration-list ;
436:
437: \ offset computation
438: \ the leftmost (i.e. deepest) item has offset 0
439: \ the rightmost item has the highest offset
440:
441: : compute-offset ( n1 n2 item -- n3 n4 )
442: \ n1, n3 are data-stack-offsets
443: \ n2, n4 are the fp-stack-offsets
444: >r
445: swap dup r@ item-d-offset !
446: r@ item-type @ type-d-size +
447: swap dup r@ item-f-offset !
448: r@ item-type @ type-f-size +
449: rdrop ;
450:
451: : compute-list ( addr1 addr2 -- n1 n2 )
452: \ n1, n2 are the final offsets
453: 0 0 2swap swap ?do
454: i compute-offset
455: item-descr +loop ;
456:
457: : compute-offsets ( -- )
458: effect-in effect-in-end @ compute-list effect-in-size 2!
459: effect-out effect-out-end @ compute-list effect-out-size 2! ;
460:
461: : flush-tos ( -- )
462: effect-in-size 2@ effect-out-size 2@
463: 0<> rot 0= and
464: if
465: ." IF_FTOS(fp[0] = FTOS);" cr
466: endif
467: 0<> swap 0= and
468: if
469: ." IF_TOS(sp[0] = TOS);" cr
470: endif ;
471:
472: : fill-tos ( -- )
473: effect-in-size 2@ effect-out-size 2@
474: 0= rot 0<> and
475: if
476: ." IF_FTOS(FTOS = fp[0]);" cr
477: endif
478: 0= swap 0<> and
479: if
480: ." IF_TOS(TOS = sp[0]);" cr
481: endif ;
482:
483: : fetch ( addr -- )
484: dup item-type @ type-fetch-handler execute ;
485:
486: : fetches ( -- )
487: effect-in-end @ effect-in ?do
488: i fetch
489: item-descr +loop ;
490:
491: : stack-pointer-updates ( -- )
492: \ we do 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: : output-c ( -- )
511: ." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
512: ." /* " doc 2@ type ." */" cr
513: ." {" cr
514: ." DEF_CA" cr
515: declarations
516: compute-offsets \ for everything else
517: flush-tos
518: fetches
519: stack-pointer-updates cr
520: ." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
521: ." {" cr
522: c-code 2@ type
523: ." }" cr
524: ." NEXT_P1;" cr
525: stores
526: fill-tos
527: ." NEXT1_P2;" cr
528: ." }" cr
529: cr
530: ;
531:
532: : output-label ( -- )
533: ." &&I_" c-name 2@ type ." ," cr ;
534:
535: : output-alias ( -- )
536: primitive-number @ . ." alias " forth-name 2@ type cr
537: -1 primitive-number +! ;
538:
539: : process-file ( addr u xt -- )
540: >r r/o open-file
541: if
542: ." cannot open file" cr abort
543: endif
544: warnings @ if
545: ." ------------ CUT HERE -------------" cr endif
546: r> [ ] primfilter [ 0 ] ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>