![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to expr.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt|
Return to expr.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file expr
3: "$Header: expr.l,v 1.12 83/09/06 21:46:46 layer Exp $")
4:
5: ;;; ---- e x p r expression compilation
6: ;;;
7: ;;; -[Fri Sep 2 22:10:20 1983 by layer]-
8:
9:
10: ;--- d-exp :: compile a lisp expression
11: ; v-form : a lisp expression to compile
12: ; returns an IADR which tells where the value was located.
13: ;
14:
15: (defun d-exp (v-form)
16: (prog (first resloc tmp ftyp nomacrop)
17: begin
18: (if (atom v-form)
19: then (setq tmp (d-loc v-form)) ;locate vrble
20: (if (null g-loc)
21: then (if g-cc then (d-cmpnil tmp))
22: else (d-move tmp g-loc)
23: #+for-68k (if g-cc then (d-cmpnil tmp)))
24: (d-handlecc)
25: (return tmp)
26:
27: elseif (atom (setq first (car v-form)))
28: then ; the form (*no-macroexpand* <expr>)
29: ; turns into <expr>, and prevents <expr> from
30: ; being macroexpanded (at the top level)
31: (if (eq '*no-macroexpand* first)
32: then (setq v-form (cadr v-form)
33: nomacrop t)
34: (go begin))
35: (if (and fl-xref (not (get first g-refseen)))
36: then (Push g-reflst first)
37: (putprop first t g-refseen))
38: (setq ftyp (d-functyp first (if nomacrop then nil
39: else 'macros-ok)))
40: ; if nomacrop is t, then under no circumstances
41: ; permit the form to be macroexpanded
42: (if (and nomacrop (eq ftyp 'macro))
43: then (setq ftyp 'lambda))
44: ; If the resulting form is type macro or cmacro,
45: ; then call the appropriate function to macro-expand
46: ; it.
47: (if (memq ftyp '(macro cmacro))
48: then (setq tmp v-form) ; remember original form
49: (if (eq 'macro ftyp)
50: then (setq v-form (apply first v-form))
51: elseif (eq 'cmacro ftyp)
52: then (setq v-form (apply (get first 'cmacro)
53: v-form)))
54: ; If the resulting form is the same as
55: ; the original form, then we don't want to
56: ; macro expand again. We call d-functyp and tell
57: ; it that we want a second opinion
58: (if (and (eq (car v-form) first)
59: (equal tmp v-form))
60: then (setq ftyp (d-functyp first nil))
61: else (go begin))) ; retry with what we have
62:
63: (if (and (setq tmp (get first 'if-fixnum-args))
64: (d-allfixnumargs (cdr v-form)))
65: then (setq v-form (cons tmp (cdr v-form)))
66: (go begin)
67: elseif (setq tmp (get first 'fl-exprcc))
68: then (d-argnumchk 'hard)
69: (return (funcall tmp))
70: elseif (setq tmp (get first 'fl-exprm))
71: then (d-argnumchk 'hard)
72: (setq v-form (funcall tmp))
73: (go begin)
74: elseif (setq tmp (get first 'fl-expr))
75: then (d-argnumchk 'hard)
76: (funcall tmp)
77: elseif (setq tmp (or (and (eq 'car first)
78: '( a ))
79: (and (eq 'cdr first)
80: '( d ))
81: (d-cxxr first)))
82: then (d-argcheckit '(1 . 1) (length (cdr v-form)) 'hard)
83: (return (cc-cxxr (cadr v-form) tmp))
84: elseif (eq 'nlambda ftyp)
85: then (d-argnumchk 'soft)
86: (d-callbig first `(',(cdr v-form)) nil)
87: elseif (or (eq 'lambda ftyp) (eq 'lexpr ftyp))
88: then (setq tmp (length v-form))
89: (d-argnumchk 'soft)
90: (d-callbig first (cdr v-form) nil)
91: elseif (eq 'array ftyp)
92: then (d-handlearrayref)
93: elseif (eq 'macro ftyp)
94: then (comp-err "infinite macro expansion " v-form)
95: else (comp-err "internal liszt err in d-exp" v-form))
96:
97: elseif (eq 'lambda (car first))
98: then (c-lambexp)
99:
100: elseif (or (eq 'quote (car first)) (eq 'function (car first)))
101: then (comp-warn "bizzare function name " (or first))
102: (setq v-form (cons (cadr first) (cdr v-form)))
103: (go begin)
104:
105: else (comp-err "bad expression" (or v-form)))
106:
107: (if (null g-loc)
108: then (if g-cc then (d-cmpnil 'reg))
109: elseif (memq g-loc '(reg #+for-vax r0 #+for-68k d0))
110: then (if g-cc then (d-cmpnil 'reg))
111: else (d-move 'reg g-loc)
112: #+for-68k (if g-cc then (d-cmpnil 'reg)))
113: (if g-cc then (d-handlecc))))
114:
115: ;--- d-exps :: compile a list of expressions
116: ; - exps : list of expressions
117: ; the last expression is evaluated according to g-loc and g-cc, the others
118: ; are evaluated with g-loc and g-cc nil.
119: ;
120: (defun d-exps (exps)
121: (d-exp (do ((ll exps (cdr ll))
122: (g-loc nil)
123: (g-cc nil)
124: (g-ret nil))
125: ((null (cdr ll)) (car ll))
126: (d-exp (car ll)))))
127:
128:
129: ;--- d-argnumchk :: check that the correct number of arguments are given
130: ; v-form (global) contains the expression to check
131: ; class: hard or soft, hard means that failure is an error, soft means
132: ; warning
133: (defun d-argnumchk (class)
134: (let ((info (car (get (car v-form) 'fcn-info)))
135: (argsize (length (cdr v-form))))
136: (if info then (d-argcheckit info argsize class))))
137:
138: ;--- d-argcheckit
139: ; info - arg information form: (min# . max#) max# of nil means no max
140: ; numargs - number of arguments given
141: ; class - hard or soft
142: ; v-form(global) - expression begin checked
143: ;
144: (defun d-argcheckit (info numargs class)
145: (if (and (car info) (< numargs (car info)))
146: then (if (eq class 'hard)
147: then (comp-err
148: (difference (car info) numargs)
149: " too few argument(s) given in this expression:" N
150: v-form)
151: else (comp-warn
152: (difference (car info) numargs)
153: " too few argument(s) given in this expression:" N
154: v-form))
155: elseif (and (cdr info) (> numargs (cdr info)))
156: then (if (eq class 'hard)
157: then (comp-err
158: (difference numargs (cdr info))
159: " too many argument(s) given in this expression:" N
160: v-form)
161: else (comp-warn
162: (difference numargs (cdr info))
163: " too many argument(s) given in this expression:" N
164: v-form))))
165:
166: ;--- d-pushargs :: compile and push a list of expressions
167: ; - exps : list of expressions
168: ; compiles and stacks a list of expressions
169: ;
170: (defun d-pushargs (args)
171: (if args then
172: (do ((ll args (cdr ll))
173: (g-loc 'stack)
174: (g-cc nil)
175: (g-ret nil))
176: ((null ll))
177: (d-exp (car ll))
178: (push nil g-locs)
179: (incr g-loccnt))))
180:
181: ;--- d-cxxr :: split apart a cxxr function name
182: ; - name : a possible cxxr function name
183: ; returns the a's and d's between c and r in reverse order, or else
184: ; returns nil if this is not a cxxr name
185: ;
186: (defun d-cxxr (name)
187: (let ((expl (explodec name)))
188: (if (eq 'c (car expl)) ; must begin with c
189: then (do ((ll (cdr expl) (cdr ll))
190: (tmp)
191: (res))
192: (nil)
193: (setq tmp (car ll))
194: (if (null (cdr ll))
195: then (if (eq 'r tmp) ; must end in r
196: then (return res)
197: else (return nil))
198: elseif (or (eq 'a tmp) ; and contain only a's and d's
199: (eq 'd tmp))
200: then (setq res (cons tmp res))
201: else (return nil))))))
202:
203:
204: ;--- d-callbig :: call a local, global or bcd function
205: ;
206: ; name is the name of the function we are to call
207: ; args are the arguments to evaluate and call the function with
208: ; if bcdp is t then we are calling through a binary object and thus
209: ; name is ingored.
210: ;
211: #+for-vax
212: (defun d-callbig (name args bcdp)
213: (let ((tmp (get name g-localf))
214: c)
215: (forcecomment `(calling ,name))
216: (if (d-dotailrecursion name args) thenret
217: elseif tmp then ;-- local function call
218: (d-pushargs args)
219: (e-quick-call (car tmp))
220: (setq g-locs (nthcdr (setq c (length args)) g-locs))
221: (setq g-loccnt (- g-loccnt c))
222: else (if bcdp ;-- bcdcall
223: then (d-pushargs args)
224: (setq c (length args))
225: (d-bcdcall c)
226: elseif fl-tran ;-- transfer table linkage
227: then (d-pushargs args)
228: (setq c (length args))
229: (d-calltran name c)
230: (putprop name t g-stdref) ; remember we've called this
231: else ;--- shouldn't get here
232: (comp-err " bad args to d-callbig : "
233: (or name args)))
234: (setq g-locs (nthcdr c g-locs))
235: (setq g-loccnt (- g-loccnt c)))
236: (d-clearreg)))
237:
238: #+for-68k
239: (defun d-callbig (name args bcdp)
240: (let ((tmp (get name g-localf))
241: c)
242: (forcecomment `(calling ,name))
243: (if (d-dotailrecursion name args)
244: thenret
245: elseif tmp then ;-- local function call
246: (d-pushargs args)
247: (setq c (length args))
248: (if (null $global-reg$) then
249: (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
250: (e-move 'a5 '#.lbot-sym)
251: (e-move '#.np-reg '#.np-sym))
252: (e-quick-call (car tmp))
253: (setq g-locs (nthcdr c g-locs))
254: (setq g-loccnt (- g-loccnt c))
255: else (if bcdp ;-- bcdcall
256: then (d-pushargs args)
257: (setq c (length args))
258: (d-bcdcall c)
259: elseif fl-tran ;-- transfer table linkage
260: then (d-pushargs args)
261: (setq c (length args))
262: (d-calltran name c)
263: (putprop name t g-stdref) ; remember we've called this
264: else ;--- shouldn't get here
265: (comp-err " bad args to d-callbig : "
266: (or name args)))
267: (setq g-locs (nthcdr c g-locs))
268: (setq g-loccnt (- g-loccnt c)))
269: (d-clearreg)))
270:
271: ;--- d-calltran :: call a function through the transfer table
272: ; name - name of function to call
273: ; c - number of arguments to the function
274: ;
275: #+for-vax
276: (defun d-calltran (name c)
277: (if $global-reg$
278: then (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-reg)
279: else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-sym)
280: (e-move '#.np-reg '#.np-sym))
281: (e-write3 'calls '$0 (concat "*trantb+" (d-tranloc name)))
282: (if $global-reg$
283: then (e-move '#.lbot-reg '#.np-reg)
284: else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.np-reg)))
285:
286: #+for-68k
287: (defun d-calltran (name c)
288: (if $global-reg$
289: then (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
290: (e-move 'a5 '#.lbot-reg)
291: else (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
292: (e-move 'a5 '#.lbot-sym)
293: (e-move '#.np-reg '#.np-sym))
294: (e-move (concat "trantb+" (d-tranloc name)) 'a5)
295: (e-quick-call '(0 a5))
296: (if $global-reg$
297: then (e-move '#.lbot-reg '#.np-reg)
298: else (e-write3 'lea `(,(* -4 c) #.np-reg) '#.np-reg)))
299:
300: ;--- d-calldirect :: call a function directly
301: ;
302: ; name - name of a function in the C code (known about by fasl)
303: ; c - number of args
304: ;
305: #+for-vax
306: (defun d-calldirect (name c)
307: (if $global-reg$
308: then (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-reg)
309: else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.lbot-sym)
310: (e-move '#.np-reg '#.np-sym))
311: (e-write3 'calls '$0 name)
312: (if $global-reg$
313: then (e-move '#.lbot-reg '#.np-reg)
314: else (e-write3 'movab `(,(* -4 c) #.np-reg) '#.np-reg)))
315:
316: #+for-68k
317: (defun d-calldirect (name c)
318: (if $global-reg$
319: then (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
320: (e-move 'a5 '#.lbot-reg)
321: else (e-write3 'lea `(,(* -4 c) #.np-reg) 'a5)
322: (e-move 'a5 '#.lbot-sym)
323: (e-move '#.np-reg '#.np-sym))
324: (e-quick-call name)
325: (if $global-reg$
326: then (e-move '#.lbot-reg '#.np-reg)
327: else (e-write3 'lea `(,(* -4 c) #.np-reg) '#.np-reg)))
328:
329: ;--- d-bcdcall :: call a function through a binary data object
330: ;
331: ; at this point the stack contains n-1 arguments and a binary object which
332: ; is the address of the compiled lambda expression to go to. We set
333: ; up lbot right above the binary on the stack and call the function.
334: ;
335: #+for-vax
336: (defun d-bcdcall (n)
337: (if $global-reg$
338: then (e-write3 'movab `(,(* -4 (- n 1)) #.np-reg) '#.lbot-reg)
339: else (e-write3 'movab `(,(* -4 (- n 1)) #.np-reg) '#.lbot-sym)
340: (e-move '#.np-reg '#.np-sym))
341: (e-move `(* ,(* -4 n) #.np-reg) 'r0) ;get address to call to
342: (e-write3 'calls '$0 "(r0)")
343: (if $global-reg$
344: then (e-write3 'movab '(-4 #.lbot-reg) '#.np-reg)
345: else (e-write3 'movab `(,(* -4 n) #.np-reg) '#.np-reg)))
346:
347: #+for-68k
348: (defun d-bcdcall (n)
349: (if $global-reg$
350: then (e-write3 'lea `(,(* -4 (- n 1)) #.np-reg) 'a5)
351: (e-move 'a5 '#.lbot-reg)
352: else (e-write3 'lea `(,(* -4 (- n 1)) #.np-reg) 'a5)
353: (e-move 'a5 '#.lbot-sym)
354: (e-move '#.np-reg '#.np-sym))
355: (e-move `(,(* -4 n) #.np-reg) 'a5) ; get address to call to
356: (e-move `(0 a5) 'a5)
357: (e-quick-call '(0 a5))
358: (if $global-reg$
359: then (e-move '#.lbot-reg 'a5)
360: (e-write3 'lea '(-4 a5) '#.np-reg)
361: else (e-write3 'lea `(,(* -4 n) #.np-reg) '#.np-reg)))
362:
363: ;--- d-dotailrecursion :: do tail recursion if possible
364: ; name - function name we are to call
365: ; args - arguments to give to function
366: ;
367: ; return t iff we were able to do tail recursion
368: ; We can do tail recursion if:
369: ; g-ret is set indicating that the result of this call will be returned
370: ; as the value of the function we are compiling
371: ; the function we are calling, name, is the same as the function we are
372: ; compiling, g-fname
373: ; there are no variables shallow bound, since we would have to unbind
374: ; them, which may cause problems in the function.
375: ;
376: (defun d-dotailrecursion (name args)
377: (prog (nargs lbot)
378: (if (null (and g-ret
379: (eq name g-fname)
380: (do ((loccnt 0)
381: (ll g-locs (cdr ll)))
382: ((null ll) (return t))
383: (if (dtpr (car ll))
384: then (if (or (eq 'catcherrset (caar ll))
385: (greaterp (cdar ll) 0))
386: then (return nil))
387: else (incr loccnt)))))
388: then (return nil))
389:
390: (makecomment '(tail merging))
391: (comp-note g-fname ": Tail merging being done: " v-form)
392:
393: (setq nargs (length args))
394:
395: ; evalate the arguments, putting them above the arguments to the
396: ; function we are executing...
397: (let ((g-locs g-locs)
398: (g-loccnt g-loccnt))
399: (d-pushargs args))
400:
401: (if $global-reg$
402: then (setq lbot #+for-68k 'a5 #+for-vax '#.lbot-reg)
403: #+for-68k (e-move '#.lbot-reg lbot)
404: else (setq lbot #+for-68k 'a5 #+for-vax '#.fixnum-reg)
405: (e-move '#.lbot-sym lbot))
406:
407: ; setup lbot-reg to point to the bottom of the original
408: ;args...
409: (if (eq 'lexpr g-ftype)
410: then #+for-vax
411: (e-write4 'ashl '($ 2) '(* -4 #.olbot-reg) lbot)
412: #+for-68k
413: (progn
414: (d-regused 'd6)
415: (e-move '(* -4 #.olbot-reg) 'd6)
416: (e-write3 'asll '($ 2) 'd6)
417: (e-move 'd6 lbot))
418: (e-sub lbot '#.olbot-reg)
419: (e-sub3 '($ 4) '#.olbot-reg lbot)
420: else (e-move '#.olbot-reg lbot))
421:
422: ; copy the new args down into the place of the original ones...
423: (do ((i nargs (1- i))
424: (off-top (* nargs -4) (+ off-top 4))
425: (off-bot 0 (+ off-bot 4)))
426: ((zerop i))
427: (e-move `(,off-top #.np-reg) `(,off-bot ,lbot)))
428:
429: ; setup np for the coming call...
430: (e-add3 `($ ,(* 4 nargs)) lbot '#.np-reg)
431:
432: (e-goto g-topsym)
433: ;return t to indicate that tailrecursion was successful
434: (return t)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.