![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to func.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt|
Return to func.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file func
3: "$Header: func.l,v 1.13 84/10/18 12:36:57 jkf Exp $")
4:
5: ;;; ---- f u n c function compilation
6: ;;;
7: ;;; -[Wed Aug 24 10:51:11 1983 by layer]-
8:
9: ; cm-ncons :: macro out an ncons expression
10: ;
11: (defun cm-ncons nil
12: `(cons ,(cadr v-form) nil))
13:
14: ; cc-not :: compile a "not" or "null" expression
15: ;
16: (defun cc-not nil
17: (makecomment '(beginning not))
18: (if (null g-loc)
19: then (let ((g-cc (cons (cdr g-cc) (car g-cc)))
20: (g-ret nil))
21: (d-exp (cadr v-form)))
22: else (let ((finlab (d-genlab))
23: (finlab2 (d-genlab))
24: (g-ret nil))
25: ; eval arg and jump to finlab if nil
26: (let ((g-cc (cons finlab nil))
27: g-loc)
28: (d-exp (cadr v-form)))
29: ; didn't jump, answer must be t
30: (d-move 'T g-loc)
31: (if (car g-cc)
32: then (e-goto (car g-cc))
33: else (e-goto finlab2))
34: (e-label finlab)
35: ; answer is nil
36: (d-move 'Nil g-loc)
37: (if (cdr g-cc) then (e-goto (cdr g-cc)))
38: (e-label finlab2))))
39:
40: ;--- cc-numberp :: check for numberness
41: ;
42: (defun cc-numberp nil
43: (d-typecmplx (cadr v-form)
44: '#.(immed-const (plus 1_2 1_4 1_9))))
45:
46: ;--- cc-or :: compile an "or" expression
47: ;
48: (defun cc-or nil
49: (let ((finlab (d-genlab))
50: (finlab2)
51: (exps (if (cdr v-form) thenret else '(nil)))) ; (or) => nil
52: (if (null (car g-cc))
53: then (d-exp (do ((g-cc (cons finlab nil))
54: (g-loc (if g-loc then 'reg))
55: (g-ret nil)
56: (ll exps (cdr ll)))
57: ((null (cdr ll)) (car ll))
58: (d-exp (car ll))))
59: (if g-loc
60: then (setq finlab2 (d-genlab))
61: (e-goto finlab2)
62: (e-label finlab)
63: (d-move 'reg g-loc)
64: (e-label finlab2)
65: else (e-label finlab))
66: else (if (null g-loc) then (setq finlab (car g-cc)))
67: (d-exp (do ((g-cc (cons finlab nil))
68: (g-loc (if g-loc then 'reg))
69: (g-ret nil)
70: (ll exps (cdr ll)))
71: ((null (cdr ll)) (car ll))
72: (d-exp (car ll))))
73: (if g-loc
74: then (setq finlab2 (d-genlab))
75: (e-goto finlab2)
76: (e-label finlab)
77: (d-move 'reg g-loc)
78: (e-goto (car g-cc)) ; result is t
79: (e-label finlab2)))
80: (d-clearreg))) ;we are not sure of the state due to possible branches.
81:
82: ;--- c-prog :: compile a "prog" expression
83: ;
84: ; for interlisp compatibility, we allow the formal variable list to
85: ; contain objects of this form (vrbl init) which gives the initial value
86: ; for that variable (instead of nil)
87: ;
88: (defun c-prog nil
89: (let ((g-decls g-decls))
90: (let (g-loc g-cc seeninit initf
91: (p-rettrue g-ret) (g-ret nil)
92: ((spcs locs initsv . initsn) (d-classify (cadr v-form))))
93:
94: (e-pushnil (length locs)) ; locals initially nil
95: (d-bindprg spcs locs) ; bind locs and specs
96:
97: (cond (initsv (d-pushargs initsv)
98: (mapc '(lambda (x)
99: (d-move 'unstack (d-loc x))
100: (decr g-loccnt)
101: (unpush g-locs))
102: (nreverse initsn))))
103:
104: ; determine all possible labels
105: (do ((ll (cddr v-form) (cdr ll))
106: (labs nil))
107: ((null ll) (setq g-labs `((,(d-genlab) ,@labs)
108: ,@g-labs)))
109: (if (and (car ll) (symbolp (car ll)))
110: then (if (assq (car ll) labs)
111: then (comp-err "label is mulitiply defined " (car ll))
112: else (setq labs (cons (cons (car ll) (d-genlab))
113: labs)))))
114:
115: ; compile each form which is not a label
116: (d-clearreg) ; unknown state after binding
117: (do ((ll (cddr v-form) (cdr ll)))
118: ((null ll))
119: (if (or (null (car ll)) (not (symbolp (car ll))))
120: then (d-exp (car ll))
121: else (e-label (cdr (assq (car ll) (cdar g-labs))))
122: (d-clearreg)))) ; dont know state after label
123:
124: ; result is nil if fall out and care about value
125: (if (or g-cc g-loc) then (d-move 'Nil 'reg))
126:
127: (e-label (caar g-labs)) ; return to label
128: (setq g-labs (cdr g-labs))
129: (d-unbind))) ; unbind our frame
130:
131: ;--- d-bindprg :: do binding for a prog expression
132: ; - spcs : list of special variables
133: ; - locs : list of local variables
134: ; - specinit : init values for specs (or nil if all are nil)
135: ;
136: (defun d-bindprg (spcs locs)
137: ; place the local vrbls and prog frame entry on the stack
138: (setq g-loccnt (+ g-loccnt (length locs))
139: g-locs (nconc locs `((prog . ,(length spcs)) ,@g-locs)))
140:
141: ; now bind the specials, if any, to nil
142: (if spcs then (e-setupbind)
143: (mapc '(lambda (vrb)
144: (e-shallowbind vrb 'Nil))
145: spcs)
146: (e-unsetupbind)))
147:
148: ;--- d-unbind :: remove one frame from g-locs
149: ;
150: (defun d-unbind nil
151: (do ((count 0 (1+ count)))
152: ((dtpr (car g-locs))
153: (if (not (zerop (cdar g-locs)))
154: then (e-unshallowbind (cdar g-locs)))
155: (cond ((not (zerop count))
156: (e-dropnp count)
157:
158: (setq g-loccnt (- g-loccnt count))))
159: (setq g-locs (cdr g-locs)))
160: (setq g-locs (cdr g-locs))))
161:
162: ;--- d-classify :: seperate variable list into special and non-special
163: ; - lst : list of variables
164: ; returns ( xxx yyy zzz . aaa)
165: ; where xxx is the list of special variables and
166: ; yyy is the list of local variables
167: ; zzz are the non nil initial values for prog variables
168: ; aaa are the names corresponding to the values in zzz
169: ;
170: (defun d-classify (lst)
171: (do ((ll lst (cdr ll))
172: (locs) (spcs) (init) (initsv) (initsn)
173: (name))
174: ((null ll) (cons spcs (cons locs (cons initsv initsn))))
175: (if (atom (car ll))
176: then (setq name (car ll))
177: else (setq name (caar ll))
178: (push name initsn)
179: (push (cadar ll) initsv))
180: (if (d-specialp name)
181: then (push name spcs)
182: else (push name locs))))
183:
184: ; cm-progn :: compile a "progn" expression
185: ;
186: (defun cm-progn nil
187: `((lambda nil ,@(cdr v-form))))
188:
189: ; cm-prog1 :: compile a "prog1" expression
190: ;
191: (defun cm-prog1 nil
192: (let ((gl (d-genlab)))
193: `((lambda (,gl)
194: ,@(cddr v-form)
195: ,gl)
196: ,(cadr v-form))))
197:
198: ; cm-prog2 :: compile a "prog2" expression
199: ;
200: (defun cm-prog2 nil
201: (let ((gl (d-genlab)))
202: `((lambda (,gl)
203: ,(cadr v-form)
204: (setq ,gl ,(caddr v-form))
205: ,@(cdddr v-form)
206: ,gl)
207: nil)))
208:
209: ;--- cm-progv :: compile a progv form
210: ; a progv form looks like (progv 'l-vars 'l-inits 'g-exp1 ... 'g-expn)
211: ; l-vars should be a list of variables, l-inits a list of initial forms
212: ; We cannot permit returns and go-s through this form.
213: ;
214: ; we stack a (progv . 0) form on g-locs so that return and go will know
215: ; not to try to go through this form.
216: ;
217: (defun c-progv nil
218: (let ((gl (d-genlab))
219: (g-labs (cons nil g-labs))
220: (g-locs (cons '(progv . 0) g-locs)))
221: (d-exp `((lambda (,gl)
222: (prog1 (progn ,@(cdddr v-form))
223: (internal-unbind-vars ,gl)))
224: (internal-bind-vars ,(cadr v-form) ,(caddr v-form))))))
225:
226: (defun c-internal-bind-vars nil
227: (let ((g-locs g-locs)
228: (g-loccnt g-loccnt))
229: (d-pushargs (cdr v-form))
230: (d-calldirect '_Ibindvars (length (cdr v-form)))))
231:
232: (defun c-internal-unbind-vars nil
233: (let ((g-locs g-locs)
234: (g-loccnt g-loccnt))
235: (d-pushargs (cdr v-form))
236: (d-calldirect '_Iunbindvars (length (cdr v-form)))))
237:
238: ;--- cc-quote : compile a "quote" expression
239: ;
240: ; if we are just looking to set the ; cc, we just make sure
241: ; we set the cc depending on whether the expression quoted is
242: ; nil or not.
243: (defun cc-quote nil
244: (let ((arg (cadr v-form))
245: argloc)
246: (if (null g-loc)
247: then (if (and (null arg) (cdr g-cc))
248: then (e-goto (cdr g-cc))
249: elseif (and arg (car g-cc))
250: then (e-goto (car g-cc))
251: elseif (null g-cc)
252: then (comp-warn "losing the value of this expression "
253: (or v-form)))
254: else (d-move (d-loclit arg nil) g-loc)
255: (d-handlecc))))
256:
257: ;--- c-setarg :: set a lexpr's arg
258: ; form is (setarg index value)
259: ;
260: (defun c-setarg nil
261: (if (not (eq 'lexpr g-ftype))
262: then (comp-err "setarg only allowed in lexprs"))
263: (if (and fl-inter (eq (length (cdr v-form)) 3)) ; interlisp setarg
264: then (if (not (eq (cadr v-form) (car g-args)))
265: then (comp-err "setarg: can only compile local setargs "
266: v-form)
267: else (setq v-form (cdr v-form))))
268: ; compile index into fixnum-reg, was (d-pushargs (list (cadr v-form)))
269: (let ((g-cc) (g-ret)
270: (g-loc '#.fixnum-reg))
271: (d-exp (cadr v-form)))
272: (let ((g-loc 'reg)
273: (g-cc nil)
274: (g-ret nil))
275: (d-exp (caddr v-form)))
276: #+for-vax
277: (progn
278: (e-sub3 `(* -4 #.olbot-reg) '(0 #.fixnum-reg) '#.fixnum-reg)
279: (e-move 'r0 '(-8 #.olbot-reg #.fixnum-reg)))
280: #+for-68k
281: (progn
282: (e-sub `(-4 #.olbot-reg) '#.fixnum-reg)
283: (e-write3 'lea '(% -8 #.olbot-reg #.fixnum-reg) 'a5)
284: (e-move 'd0 '(0 a5))))
285:
286: ;--- cc-stringp :: check for string ness
287: ;
288: (defun cc-stringp nil
289: (d-typesimp (cadr v-form) #.(immed-const 0)))
290:
291: ;--- cc-symbolp :: check for symbolness
292: ;
293: (defun cc-symbolp nil
294: (d-typesimp (cadr v-form) #.(immed-const 1)))
295:
296: ;--- c-return :: compile a "return" statement
297: ;
298: (defun c-return nil
299: ; value is always put in reg
300: (let ((g-loc 'reg)
301: g-cc
302: g-ret)
303: (d-exp (cadr v-form)))
304:
305: ; if we are doing a non local return, compute number of specials to unbind
306: ; and locals to pop
307: (if (car g-labs)
308: then (e-goto (caar g-labs))
309: else (do ((loccnt 0) ;; locals
310: (speccnt 0) ;; special
311: (catcherrset 0) ;; catch/errset frames
312: (ll g-labs (cdr ll))
313: (locs g-locs))
314: ((null ll) (comp-err "return used not within a prog or do"))
315: (if (car ll)
316: then (comp-note g-fname ": non local return used ")
317: ; unbind down to but not including
318: ; this frame.
319: (if (greaterp loccnt 0)
320: then (e-pop loccnt))
321: (if (greaterp speccnt 0)
322: then (e-unshallowbind speccnt))
323: (if (greaterp catcherrset 0)
324: then (comp-note
325: g-fname
326: ": return through a catch or errset"
327: v-form)
328: (do ((i 0 (1+ i)))
329: ((=& catcherrset i))
330: (d-popframe)))
331: (e-goto (caar ll))
332: (return)
333: else ; determine number of locals and special on
334: ; stack for this frame, add to running
335: ; totals
336: (do ()
337: ((dtpr (car locs))
338: (if (eq 'catcherrset (caar locs)) ; catchframe
339: then (incr catcherrset)
340: elseif (eq 'progv (caar locs))
341: then (comp-err "Attempt to 'return' through a progv"))
342: (setq speccnt (+ speccnt (cdar locs))
343: locs (cdr locs)))
344: (incr loccnt)
345: (setq locs (cdr locs)))))))
346:
347: ; c-rplaca :: compile a "rplaca" expression
348: ;
349: #+for-vax
350: (defun c-rplaca nil
351: (let ((ssimp (d-simple (caddr v-form)))
352: (g-ret nil))
353: (let ((g-loc (if ssimp then 'reg else 'stack))
354: (g-cc nil))
355: (d-exp (cadr v-form)))
356: (if (null ssimp)
357: then (push nil g-locs)
358: (incr g-loccnt)
359: (let ((g-loc 'r1)
360: (g-cc nil))
361: (d-exp (caddr v-form)))
362: (d-move 'unstack 'reg)
363: (unpush g-locs)
364: (decr g-loccnt)
365: (e-move 'r1 '(4 r0))
366: else (e-move (e-cvt ssimp) '(4 r0)))
367: (d-clearreg))) ; cant tell what we are clobbering
368:
369: #+for-68k
370: (defun c-rplaca nil
371: (let ((ssimp (d-simple (caddr v-form)))
372: (g-ret nil))
373: (makecomment `(c-rplaca starting :: v-form = ,v-form))
374: (let ((g-loc (if ssimp then 'areg else 'stack))
375: (g-cc nil))
376: (d-exp (cadr v-form)))
377: (if (null ssimp)
378: then (push nil g-locs)
379: (incr g-loccnt)
380: (let ((g-loc 'd1)
381: (g-cc nil))
382: (d-exp (caddr v-form)))
383: (d-move 'unstack 'areg)
384: (unpush g-locs)
385: (decr g-loccnt)
386: (e-move 'd1 '(4 a0))
387: else (e-move (e-cvt ssimp) '(4 a0)))
388: (e-move 'a0 'd0)
389: (d-clearreg)
390: (makecomment `(c-rplaca done))))
391:
392: ; c-rplacd :: compile a "rplacd" expression
393: ;
394: #+for-vax
395: (defun c-rplacd nil
396: (let ((ssimp (d-simple (caddr v-form)))
397: (g-ret nil))
398: (let ((g-loc (if ssimp then 'reg else 'stack))
399: (g-cc nil))
400: (d-exp (cadr v-form)))
401: (if (null ssimp)
402: then (push nil g-locs)
403: (incr g-loccnt)
404: (let ((g-loc 'r1)
405: (g-cc nil))
406: (d-exp (caddr v-form)))
407: (d-move 'unstack 'reg)
408: (unpush g-locs)
409: (decr g-loccnt)
410: (e-move 'r1 '(0 r0))
411: else (e-move (e-cvt ssimp) '(0 r0)))
412: (d-clearreg)))
413:
414: #+for-68k
415: (defun c-rplacd nil
416: (let ((ssimp (d-simple (caddr v-form)))
417: (g-ret nil))
418: (makecomment `(c-rplacd starting :: v-form = ,v-form))
419: (let ((g-loc (if ssimp then 'areg else 'stack))
420: (g-cc nil))
421: (d-exp (cadr v-form)))
422: (if (null ssimp)
423: then (push nil g-locs)
424: (incr g-loccnt)
425: (let ((g-loc 'd1)
426: (g-cc nil))
427: (d-exp (caddr v-form)))
428: (d-move 'unstack 'areg)
429: (unpush g-locs)
430: (decr g-loccnt)
431: (e-move 'd1 '(0 a0))
432: else (e-move (e-cvt ssimp) '(0 a0)))
433: (e-move 'a0 'd0)
434: (d-clearreg)
435: (makecomment `(d-rplacd done))))
436:
437: ;--- cc-setq :: compile a "setq" expression
438: ;
439: (defun cc-setq nil
440: (prog nil
441: (let (tmp tmp2)
442: (if (null (cdr v-form))
443: then (d-exp nil) ; (setq)
444: (return)
445: elseif (oddp (length (cdr v-form)))
446: then (comp-err "wrong number of args to setq "
447: (or v-form))
448: elseif (cdddr v-form) ; if multiple setq's
449: then (do ((ll (cdr v-form) (cddr ll))
450: (g-loc)
451: (g-cc nil))
452: ((null (cddr ll)) (setq tmp ll))
453: (setq g-loc (d-locv (car ll)))
454: (d-exp (cadr ll))
455: (d-clearuse (car ll)))
456: else (setq tmp (cdr v-form)))
457:
458: ; do final setq
459: (let ((g-loc (d-locv (car tmp)))
460: (g-cc (if g-loc then nil else g-cc))
461: (g-ret nil))
462: (d-exp (cadr tmp))
463: (d-clearuse (car tmp)))
464: (if g-loc
465: then (d-move (setq tmp2 (d-locv (car tmp))) g-loc)
466: (if g-cc
467: then #+for-68k (d-cmpnil tmp2)
468: (d-handlecc))))))
469:
470: ; cc-typep :: compile a "typep" expression
471: ;
472: ; this returns the type of the expression, it is always non nil
473: ;
474: #+for-vax
475: (defun cc-typep nil
476: (let ((argloc (d-simple (cadr v-form)))
477: (g-ret))
478: (if (null argloc)
479: then (let ((g-loc 'reg) g-cc)
480: (d-exp (cadr v-form)))
481: (setq argloc 'reg))
482: (if g-loc
483: then (e-write4 'ashl '($ -9) (e-cvt argloc) 'r0)
484: (e-write3 'cvtbl "_typetable+1[r0]" 'r0)
485: (e-move "_tynames+4[r0]" 'r0)
486: (e-move '(0 r0) (e-cvt g-loc)))
487: (if (car g-cc) then (e-goto (car g-cc)))))
488:
489: #+for-68k
490: (defun cc-typep nil
491: (let ((argloc (d-simple (cadr v-form)))
492: (g-ret))
493: (if (null argloc)
494: then (let ((g-loc 'reg) g-cc)
495: (d-exp (cadr v-form)))
496: (setq argloc 'reg))
497: (if g-loc
498: then (e-move (e-cvt argloc) 'd0)
499: (e-sub '#.nil-reg 'd0)
500: (e-write3 'moveq '($ 9) 'd1)
501: (e-write3 'asrl 'd1 'd0)
502: (e-write3 'lea '"_typetable+1" 'a5)
503: (e-add 'd0 'a5)
504: (e-write3 'movb '(0 a5) 'd0)
505: (e-write2 'extw 'd0)
506: (e-write2 'extl 'd0)
507: (e-write3 'asll '($ 2) 'd0)
508: (e-write3 'lea "_tynames+4" 'a5)
509: (e-add 'd0 'a5)
510: (e-move '(0 a5) 'a5)
511: (e-move '(0 a5) (e-cvt g-loc)))
512: (if (car g-cc) then (e-goto (car g-cc)))))
513:
514: ; cm-symeval :: compile a symeval expression.
515: ; the symbol cell in franz lisp is just the cdr.
516: ;
517: (defun cm-symeval nil
518: `(cdr ,(cadr v-form)))
519:
520: ; c-*throw :: compile a "*throw" expression
521: ;
522: ; the form of *throw is (*throw 'tag 'val) .
523: ; we calculate and stack the value of tag, then calculate val
524: ; we call Idothrow to do the actual work, and only return if the
525: ; throw failed.
526: ;
527: (defun c-*throw nil
528: (let ((arg2loc (d-simple (caddr v-form)))
529: g-cc
530: g-ret
531: arg1loc)
532: ; put on the C runtime stack value to throw, and
533: ; tag to throw to.
534: (if arg2loc
535: then (if (setq arg1loc (d-simple (cadr v-form)))
536: then (C-push (e-cvt arg2loc))
537: (C-push (e-cvt arg1loc))
538: else (let ((g-loc 'reg))
539: (d-exp (cadr v-form)) ; calc tag
540: (C-push (e-cvt arg2loc))
541: (C-push (e-cvt 'reg))))
542: else (let ((g-loc 'stack))
543: (d-exp (cadr v-form)) ; calc tag to stack
544: (push nil g-locs)
545: (incr g-loccnt)
546: (setq g-loc 'reg)
547: (d-exp (caddr v-form)) ; calc value into reg
548: (C-push (e-cvt 'reg))
549: (C-push (e-cvt 'unstack))
550: (unpush g-locs)
551: (decr g-loccnt)))
552: ; now push the type of non local go we are doing, in this case
553: ; it is a C_THROW
554: (C-push '($ #.C_THROW))
555: #+for-vax
556: (e-write3 'calls '$3 '_Inonlocalgo)
557: #+for-68k
558: (e-quick-call '_Inonlocalgo)))
559:
560: ;--- cm-zerop :: convert zerop to a quick test
561: ; zerop is only allowed on fixnum and flonum arguments. In both cases,
562: ; if the value of the first 32 bits is zero, then we have a zero.
563: ; thus we can define it as a macro:
564: #+for-vax
565: (defun cm-zerop nil
566: (cond ((atom (cadr v-form))
567: `(and (null (cdr ,(cadr v-form))) (not (bigp ,(cadr v-form)))))
568: (t (let ((gnsy (gensym)))
569: `((lambda (,gnsy)
570: (and (null (cdr ,gnsy))
571: (not (bigp ,gnsy))))
572: ,(cadr v-form))))))
573:
574: #+for-68k
575: (defun cm-zerop nil
576: (cond ((atom (cadr v-form))
577: `(and (=& 0 ,(cadr v-form)) ;was (cdr ,(cadr v-form))
578: (not (bigp ,(cadr v-form)))))
579: (t (let ((gnsy (gensym)))
580: `((lambda (,gnsy)
581: (and (=& 0 ,gnsy) ;was (cdr ,gnsy)
582: (not (bigp ,gnsy))))
583: ,(cadr v-form))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.