![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to funb.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt|
Return to funb.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file funb
3: "$Header: funb.l,v 1.13 87/12/15 17:02:17 sklower Exp $")
4:
5: ;;; ---- f u n b function compilation
6: ;;;
7: ;;; -[Wed Aug 24 17:14:56 1983 by layer]-
8:
9: ;--- c-declare :: handle the "declare" form
10: ; if a declare is seen inside a function definition, we just
11: ; ignore it. We probably should see what it is declareing, as it
12: ; might be declaring a special.
13: ;
14: (defun c-declare nil nil)
15:
16: ;--- c-do :: compile a "do" expression
17: ;
18: ; a do has this form:
19: ; (do vrbls tst . body)
20: ; we note the special case of tst being nil, in which case the loop
21: ; is evaluated only once, and thus acts like a let with labels allowed.
22: ; The do statement is a cross between a prog and a lambda. It is like
23: ; a prog in that labels are allowed. It is like a lambda in that
24: ; we stack the values of all init forms then bind to the variables, just
25: ; like a lambda expression (that is the initial values of even specials
26: ; are stored on the stack, and then copied into the value cell of the
27: ; atom during the binding phase. From then on the stack location is
28: ; not used).
29: ;
30: (defun c-do nil
31: (let (b-vrbls b-tst b-body chklab bodylab x-repeat x-vrbs x-fst
32: g-loc g-cc oldreguse (g-decls g-decls))
33: (forcecomment '(beginning do))
34: (setq g-loc 'reg chklab (d-genlab) bodylab (d-genlab))
35:
36: (if (and (cadr v-form) (atom (cadr v-form)))
37: then (setq v-form (d-olddo-to-newdo (cdr v-form))))
38:
39: (push (cons 'do 0) g-locs) ; begin our frame
40:
41: (setq b-vrbls (cadr v-form)
42: b-tst (caddr v-form)
43: b-body (cdddr v-form))
44:
45: (d-scanfordecls b-body)
46:
47: ; push value of init forms on stack
48: (d-pushargs (mapcar '(lambda (x)
49: (if (atom x)
50: then nil ; no init form => nil
51: else (cadr x)))
52: b-vrbls))
53:
54: ; now bind to the variables in the vrbls form
55: (d-bindlamb (mapcar '(lambda (x)
56: (if (atom x) then x
57: else (car x)))
58: b-vrbls))
59:
60: ; search through body for all labels and assign them gensymed labels
61: (push (cons (d-genlab)
62: (do ((ll b-body (cdr ll))
63: (res))
64: ((null ll) res)
65: (if (and (car ll) (symbolp (car ll)))
66: then (Push res
67: (cons (car ll) (d-genlab))))))
68: g-labs)
69:
70: ; if the test is non nil, we do the test
71: ; another strange thing, a test form of (pred) will not return
72: ; the value of pred if it is not nil! it will return nil -- in this
73: ; way, it is not like a cond clause
74: (d-clearreg)
75: (if b-tst then (e-label chklab)
76: (let ((g-cc (cons nil bodylab)) g-loc g-ret)
77: (d-exp (car b-tst))) ; eval test
78: ; if false, do body
79: (if (cdr b-tst)
80: then (setq oldreguse (copy g-reguse))
81: (d-exps (cdr b-tst))
82: (setq g-reguse oldreguse)
83: else (d-move 'Nil 'reg))
84: (e-goto (caar g-labs)) ; leave do
85: (e-label bodylab)) ; begin body
86:
87: ; process body
88: (do ((ll b-body (cdr ll))
89: (g-cc) (g-loc)(g-ret))
90: ((null ll))
91: (if (or (null (car ll)) (not (symbolp (car ll))))
92: then (d-exp (car ll))
93: else (e-label (cdr (assoc (car ll) (cdar g-labs))))
94: (d-clearreg)))
95:
96: (if b-tst
97: then ; determine all repeat forms which must be
98: ; evaluated, and all the variables affected.
99: ; store the results in x-repeat and x-vrbs
100: ; if there is just one repeat form, we calculate
101: ; its value directly into where it is stored,
102: ; if there is more than one, we stack them
103: ; and then store them back at once.
104: (do ((ll b-vrbls (cdr ll)))
105: ((null ll))
106: (if (and (dtpr (car ll)) (cddar ll))
107: then (Push x-repeat (caddar ll))
108: (Push x-vrbs (caar ll))))
109: (if x-vrbs
110: then (if (null (cdr x-vrbs)) ; if just one repeat
111: then (let ((g-loc (d-locv (car x-vrbs)))
112: (g-cc nil))
113: (d-exp (car x-repeat)))
114: else (setq x-fst (car x-repeat))
115: (d-pushargs (nreverse
116: (cdr x-repeat)))
117: (let ((g-loc (d-locv (car x-vrbs)))
118: (g-cc)
119: (g-ret))
120: (d-exp x-fst))
121: (do ((ll (cdr x-vrbs) (cdr ll)))
122: ((null ll))
123: (d-move 'unstack
124: (d-locv (car ll)))
125: (setq g-locs (cdr g-locs))
126: (decr g-loccnt))))
127: (e-goto chklab))
128:
129: (e-label (caar g-labs)) ; end of do label
130: (d-clearreg)
131: (d-unbind)
132: (setq g-labs (cdr g-labs))))
133:
134: ;--- d-olddo-to-newdo :: map old do to new do
135: ;
136: ; form of old do is (do var tst . body)
137: ; where var is a symbol, not nil
138: ;
139: (defun d-olddo-to-newdo (v-l)
140: `(do ((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
141: (,(cadddr v-l))
142: ,@(cddddr v-l)))
143:
144: ;--- cc-dtpr :: check for dtprness
145: ;
146: (defun cc-dtpr nil
147: (d-typesimp (cadr v-form) #.(immed-const 3)))
148:
149: ;--- cc-eq :: compile an "eq" expression
150: ;
151: (defun cc-eq nil
152: (let ((arg1 (cadr v-form))
153: (arg2 (caddr v-form))
154: arg1loc
155: arg2loc)
156: (if (setq arg2loc (d-simple arg2))
157: then (if (setq arg1loc (d-simple arg1))
158: then ; eq <simple> <simple>
159: (d-cmp arg1loc arg2loc)
160: else ; eq <nonsimple> <simple>
161: (let ((g-loc 'reg) ; put <nonsimple> in reg
162: ; must rebind because
163: ; cc->& may have modified
164: (g-trueop #+(or for-vax for-tahoe) 'jneq
165: #+for-68k 'jne)
166: (g-falseop #+(or for-vax for-tahoe) 'jeql
167: #+for-68k 'jeq)
168: g-cc
169: g-ret)
170: (d-exp arg1))
171: (d-cmp 'reg arg2loc))
172: else ; since second is nonsimple, must stack first
173: ; arg out of harms way
174: (let ((g-loc 'stack)
175: (g-trueop #+(or for-vax for-tahoe) 'jneq #+for-68k 'jne)
176: (g-falseop #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq)
177: g-cc
178: g-ret)
179: (d-exp arg1)
180: (push nil g-locs)
181: (incr g-loccnt)
182: (setq g-loc 'reg) ; second arg to reg
183: (d-exp arg2))
184: (d-cmp 'unstack 'reg)
185: (setq g-locs (cdr g-locs))
186: (decr g-loccnt)))
187: (d-invert))
188:
189: ;--- cc-equal :: compile `equal'
190: ;
191: (defun cc-equal nil
192: (let ((lab1 (d-genlab))
193: (lab11 (d-genlab))
194: lab2)
195: (d-pushargs (cdr v-form))
196: (e-cmp '(-8 #.np-reg) '(-4 #.np-reg))
197: (e-gotonil lab1)
198: (d-calltran 'equal '2) ; not eq, try equal.
199: (d-clearreg)
200: #+(or for-vax for-tahoe) (e-tst (e-cvt 'reg))
201: #+for-68k (e-cmpnil (e-cvt 'reg))
202: (e-gotot lab11)
203: (if g-loc then (d-move 'Nil g-loc))
204: (if (cdr g-cc) then (e-goto (cdr g-cc))
205: else (e-goto (setq lab2 (d-genlab))))
206: (e-writel lab1)
207: (e-dropnp 2)
208: (e-writel lab11)
209: (if g-loc then (d-move 'T g-loc))
210: (if (car g-cc) then (e-goto (car g-cc)))
211: (if lab2 then (e-writel lab2))
212: (setq g-locs (cddr g-locs))
213: (setq g-loccnt (- g-loccnt 2))))
214:
215: ;--- c-errset :: compile an errset expression
216: ;
217: ; the errset has this form: (errset 'value ['tag])
218: ; where tag defaults to t.
219: ;
220: (defun c-errset nil
221: (let ((g-loc 'reg)
222: (g-cc nil)
223: (g-ret nil)
224: (finlab (d-genlab))
225: (beglab (d-genlab)))
226: (d-exp (if (cddr v-form) then (caddr v-form) else t))
227: (d-pushframe #.F_CATCH (d-loclit 'ER%all nil) 'reg)
228: (push nil g-labs) ; disallow labels
229: ; If retval is non zero then an error has throw us here so we
230: ; must recover the value thrown (from _lispretval) and leave
231: ; If retval is zero then we shoud calculate the expression
232: ; into r0 and put a cons cell around it
233: (e-tst '_retval)
234: (e-write2 #+(or for-vax for-tahoe) 'jeql #+for-68k 'jeq beglab)
235: (e-move '_lispretval (e-cvt 'reg))
236: (e-write2 #+(or for-vax for-tahoe) 'jbr #+for-68k 'jra finlab)
237: (e-label beglab)
238: (let ((g-loc 'stack)
239: (g-cc nil))
240: (d-exp (cadr v-form)))
241: (d-move 'Nil 'stack) ; haven't updated g-loc, g-loccnt but it
242: ; shouldn't hurt (famous last words)
243: (e-quick-call '_qcons)
244: (e-label finlab)
245: (d-popframe)
246: (unpush g-locs) ; remove (catcherrset . 0)
247: (unpush g-labs) ; remove nil
248: (d-clearreg)))
249:
250: ;--- cm-fixnum-cxr :: open code a fixnum-cxr expression.
251: ;
252: ; fixnum-cxr is a compile only hacky function which accesses an element
253: ; of a fixnum space and boxes the resulting fixnum. It can be used
254: ; for rapid access to user defined structures.
255: ;
256: (defun cm-fixnum-cxr ()
257: `(internal-fixnum-box (cxr ,@(cdr v-form))))
258:
259: (defun c-internal-fixnum-box ()
260: (let ((g-cc nil)
261: (g-ret nil)
262: (g-loc '#.fixnum-reg))
263: #+for-68k (d-regused '#.fixnum-reg)
264: (d-exp (cadr v-form))
265: (e-call-qnewint)))
266:
267: ;--- cc-offset-cxr
268: ; return a pointer to the address of the object instead of the object.
269: ;
270: (defun cc-offset-cxr nil
271: (d-supercxr nil t))
272:
273: ;--- cc-fixp :: check for a fixnum or bignum
274: ;
275: (defun cc-fixp nil
276: (d-typecmplx (cadr v-form)
277: '#.(immed-const (plus 1_2 1_9))))
278:
279: ;--- cc-floatp :: check for a flonum
280: ;
281: (defun cc-floatp nil
282: (d-typesimp (cadr v-form) #.(immed-const 4)))
283:
284: ;--- c-funcall :: compile a funcall
285: ;
286: ; we open code a funcall the resulting object is a compiled lambda.
287: ; We don't open code nlambda and macro funcalls since they are
288: ; rarely used and it would waste space to check for them
289: (defun c-funcall nil
290: (if (null (cdr v-form))
291: then (comp-err "funcall requires at least one argument " v-form))
292: (let ((g-locs g-locs)
293: (g-loccnt g-loccnt)
294: (args (length (cdr v-form)))
295: (g-loc nil)
296: (g-ret nil)
297: (g-cc nil))
298: (d-pushargs (cdr v-form))
299: (rplaca (nthcdr (1- args) g-locs) 'funcallfcn)
300:
301: (d-exp '(cond ((and (symbolp funcallfcn)
302: (getd funcallfcn))
303: (setq funcallfcn (getd funcallfcn)))))
304:
305: (d-exp `(cond ((and (bcdp funcallfcn) (eq 'lambda (getdisc funcallfcn)))
306: (Internal-bcdcall ,args t))
307: (t (Internal-bcdcall ,args nil))))))
308:
309: ;--- c-Internal-bcdcall
310: ; this is a compiler internal function call. when this occurs, there
311: ; are argnum objects stacked, the first of which is a function name
312: ; or bcd object. If dobcdcall is t then we want to do a bcdcall of
313: ; the first object stacked. If it is not true then we want to
314: ; call the interpreter funcall function to handle it.
315: ;
316: (defun c-Internal-bcdcall nil
317: (let ((argnum (cadr v-form))
318: (dobcdcall (caddr v-form)))
319: (cond (dobcdcall (d-bcdcall argnum))
320: (t (d-calltran 'funcall argnum)))))
321:
322: ;--- cc-function :: compile a function function
323: ;
324: ; function is an nlambda, which the interpreter treats as 'quote'
325: ; If the argument is a lambda expression, then Liszt will generate
326: ; a new function and generate code to return the name of
327: ; that function. If the argument is a symbol, then 'symbol
328: ; is compiled. It would probably be better to return the function
329: ; cell of the symbol, but Maclisp returns the symbol and it
330: ; would cause compatibility problems.
331: ;
332: (defun cc-function nil
333: (if (or (null (cdr v-form))
334: (cddr v-form))
335: then (comp-err "Wrong number of arguments to 'function': " v-form))
336: (let ((arg (cadr v-form)))
337: (if (symbolp arg)
338: then (d-exp `',arg)
339: elseif (and (dtpr arg)
340: (memq (car arg) '(lambda nlambda lexpr)))
341: then (let ((newname (concat "in-line-lambda:"
342: (setq in-line-lambda-number
343: (add1 in-line-lambda-number)))))
344: (Push liszt-process-forms
345: `(def ,newname ,arg))
346: (d-exp `',newname))
347: else (comp-err "Illegal argument to 'function': " v-form))))
348:
349: ;--- c-get :: do a get from the prop list
350: ;
351: (defun c-get nil
352: (if (not (eq 2 (length (cdr v-form))))
353: then (comp-err "Wrong number of args to get " v-form))
354: (d-pushargs (cdr v-form)) ; there better be 2 args
355: (e-quick-call '_qget)
356: (d-clearreg)
357: (setq g-locs (cddr g-locs))
358: (setq g-loccnt (- g-loccnt 2)))
359:
360: ;--- cm-getaccess :: compile a getaccess instruction
361: ;
362: (defun cm-getaccess nil `(cdr ,(cadr v-form)))
363:
364: ;--- cm-getaux :: compile a getaux instruction
365: ;
366: (defun cm-getaux nil `(car ,(cadr v-form)))
367:
368: ;--- cm-getd :: compile a getd instruction
369: ;
370: ; the getd function is open coded to look in the third part of a symbol
371: ; cell
372: ;
373: (defun cm-getd nil `(cxr 2 ,(cadr v-form)))
374:
375: ;--- cm-getdata :: compile a getdata instruction
376: ;
377: ; the getdata function is open coded to look in the third part of an
378: ; array header.
379: (defun cm-getdata nil `(cxr 2 ,(cadr v-form)))
380:
381: ;--- cm-getdisc :: compile a getdisc expression
382: ; getdisc accessed the discipline field of a binary object.
383: ;
384: (defun cm-getdisc nil `(cxr 1 ,(cadr v-form)))
385:
386: ;--- c-go :: compile a "go" expression
387: ;
388: ; we only compile the (go symbol)type expression, we do not
389: ; allow symbol to be anything by a non null symbol.
390: ;
391: (defun c-go nil
392: ; find number of frames we have to go down to get to the label
393: (do ((labs g-labs (cdr labs))
394: (locs g-locs)
395: (locals 0)
396: (specials 0)
397: (catcherrset 0)
398: (label))
399: ((null labs)
400: (comp-err "go label not found for expression: " (or v-form)))
401:
402: (if (car labs) ; if we have a set of labels to look at...
403: then (if (setq label
404: (do ((lbs (cdar labs) (cdr lbs)))
405: ((null lbs))
406: (if (eq (caar lbs) (cadr v-form))
407: then (return (cdar lbs)))))
408: then (if (not (eq labs g-labs))
409: then (comp-note g-fname ": non local go used : "
410: (or v-form)))
411: ; three stack to pop: namestack, bindstack
412: ; and execution stack
413: (e-pop locals)
414: (if (greaterp specials 0)
415: then (e-unshallowbind specials))
416: (if (greaterp catcherrset 0)
417: then (comp-note g-fname
418: ": Go through a catch or errset "
419: v-form)
420: (do ((i 0 (1+ i)))
421: ((=& catcherrset i))
422: (d-popframe)))
423: (e-goto label)
424: (return)))
425: ; tally all locals, specials and catcherrsets used in this frame
426: (do ()
427: ((dtpr (car locs))
428: (if (eq 'catcherrset (caar locs))
429: then (incr catcherrset)
430: elseif (eq 'progv (caar locs))
431: then (comp-err "Attempt to 'go' through a progv"))
432: (setq specials (+ specials (cdar locs))
433: locs (cdr locs)))
434: (setq locs (cdr locs))
435: (incr locals))))
436:
437: ;--- cc-ignore :: just ignore this code
438: ;
439: (defun cc-ignore nil
440: nil)
441:
442: ;--- c-lambexp :: compile a lambda expression
443: ;
444: (defun c-lambexp nil
445: (let ((g-loc (if (or g-loc g-cc) then 'reg))
446: (g-cc nil)
447: (g-locs (cons (cons 'lambda 0) g-locs))
448: (g-labs (cons nil g-labs)))
449: (d-pushargs (cdr v-form)) ; then push vals
450: (d-lambbody (car v-form))
451: (d-clearreg)))
452:
453: ;--- d-lambbody :: do a lambda body
454: ; - body : body of lambda expression, eg (lambda () dld)
455: ;
456: (defun d-lambbody (body)
457: (let ((g-decls g-decls))
458: (d-scanfordecls (cddr body)) ; look for declarations
459: (d-bindlamb (cadr body)) ; bind locals
460: (d-clearreg)
461: (d-exp (do ((ll (cddr body) (cdr ll))
462: (g-loc)
463: (g-cc)
464: (g-ret))
465: ((null (cdr ll)) (car ll))
466: (d-exp (car ll))))
467:
468: (d-unbind))) ; unbind this frame
469:
470: ;--- d-bindlamb :: bind variables in lambda list
471: ; - vrbs : list of lambda variables, may include nil meaning ignore
472: ;
473: (defun d-bindlamb (vrbs)
474: (let ((res (d-bindlrec (reverse vrbs) g-locs 0 g-loccnt)))
475: (if res then (e-setupbind)
476: (mapc '(lambda (vrb) (e-shallowbind (car vrb) (cdr vrb)))
477: res)
478: (e-unsetupbind))))
479:
480: ;--- d-bindlrec :: recusive routine to bind lambda variables
481: ; - vrb : list of variables yet to bind
482: ; - locs : current location in g-loc
483: ; - specs : number of specials seen so far
484: ; - lev : how far up from the bottom of stack we are.
485: ; returns: list of elements, one for each special, of this form:
486: ; (<specialvrbname> stack <n>)
487: ; where specialvrbname is the name of the special variable, and n is
488: ; the distance from the top of the stack where its initial value is
489: ; located
490: ; also: puts the names of the local variables in the g-locs list, as well
491: ; as placing the number of special variables in the lambda header.
492: ;
493: (defun d-bindlrec (vrb locs specs lev)
494: (if vrb
495: then (let ((spcflg (d-specialp (car vrb)))
496: retv)
497: (if spcflg then (setq specs (1+ specs)))
498:
499: (if (cdr vrb) ; if more vrbls to go ...
500: then (setq retv (d-bindlrec (cdr vrb)
501: (cdr locs)
502: specs
503: (1- lev)))
504: else (rplacd (cadr locs)
505: specs)) ; else fix up lambda hdr
506:
507: (if (not spcflg) then (rplaca locs (car vrb))
508: else (Push retv `(,(car vrb) stack ,lev)))
509:
510: retv)))
511:
512: ;--- d-scanfordecls
513: ; forms - the body of a lambda, prog or do.
514: ; we look down the form for 'declare' forms. They should be at the
515: ; beginning, but there are macros which may unintentionally put forms
516: ; in front of user written forms. Thus we check a little further than
517: ; the first form.
518: (defun d-scanfordecls (forms)
519: ; look for declarations in the first few forms
520: (do ((count 3 (1- count)))
521: ((= 0 count))
522: (cond ((and (dtpr (car forms))
523: (eq 'declare (caar forms))
524: (apply 'liszt-declare (cdar forms)))))
525: (setq forms (cdr forms))))
526:
527: ;--- c-list :: compile a list expression
528: ;
529: ; this is compiled as a bunch of conses with a nil pushed on the
530: ; top for good measure
531: ;
532: (defun c-list nil
533: (prog (nargs)
534: (setq nargs (length (cdr v-form)))
535: (makecomment '(list expression))
536: (if (zerop nargs)
537: then (d-move 'Nil 'reg) ; (list) ==> nil
538: (return))
539: (d-pushargs (cdr v-form))
540: #+(or for-vax for-tahoe) (e-write2 'clrl '#.np-plus) ; stack one nil
541: #+for-68k (L-push (e-cvt 'Nil))
542:
543: ; now do the consing
544: (do ((i (max 1 nargs) (1- i)))
545: ((zerop i))
546: (e-quick-call '_qcons)
547: (d-clearreg)
548: (if (> i 1) then (L-push (e-cvt 'reg))))
549:
550: (setq g-locs (nthcdr nargs g-locs)
551: g-loccnt (- g-loccnt nargs))))
552:
553: ;--- d-mapconvert - access : function to access parts of lists
554: ; - join : function to join results
555: ; - resu : function to apply to result
556: ; - form : mapping form
557: ; This function converts maps to an equivalent do form.
558: ;
559: ; in this function, the variable vrbls contains a list of forms, one form
560: ; per list we are mapping over. The form of the form is
561: ; (dummyvariable realarg (cdr dummyvariable))
562: ; realarg may be surrounded by (setq <variable which holds result> realarg)
563: ; in the case that the result is the list to be mapped over (this only occurs
564: ; with the function mapc).
565: ;
566: (defun d-mapconvert (access join resu form )
567: (prog (vrbls finvar acc accform compform
568: tmp testform tempvar lastvar)
569:
570: (setq finvar (gensym 'X) ; holds result
571:
572: vrbls
573: (reverse
574: (maplist '(lambda (arg)
575: ((lambda (temp)
576: (cond ((or resu (cdr arg))
577: `(,temp ,(car arg)
578: (cdr ,temp)))
579: (t `(,temp
580: (setq ,finvar
581: ,(car arg))
582: (cdr ,temp)))))
583: (gensym 'X)))
584: (reverse (cdr form))))
585:
586: ; the access form will either be nil or car. If it is
587: ; nil, then we are doing something like a maplist,
588: ; if the access form is car, then we are doing something
589: ; like a mapcar.
590: acc (mapcar '(lambda (tem)
591: (cond (access `(,access ,(car tem)))
592: (t (car tem))))
593: vrbls)
594:
595: accform (cond ((or (atom (setq tmp (car form)))
596: (null (setq tmp (d-macroexpand tmp)))
597: (not (member (car tmp) '(quote function))))
598: `(funcall ,tmp ,@acc))
599: (t `(,(cadr tmp) ,@acc)))
600:
601: ; the testform checks if any of the lists we are mapping
602: ; over is nil, in which case we quit.
603: testform (cond ((null (cdr vrbls)) `(null ,(caar vrbls)))
604: (t `(or ,@(mapcar '(lambda (x)
605: `(null ,(car x)))
606: vrbls)))))
607:
608: ; in the case of mapcans and mapcons, you need two
609: ; extra variables to simulate the nconc.
610: ; testvar gets intermediate results and lastvar
611: ; points to then end of the list
612: (if (eq join 'nconc)
613: then (setq tempvar (gensym 'X)
614: lastvar (gensym 'X)
615: vrbls `((,tempvar) (,lastvar) ,@vrbls)))
616:
617: (return
618: `((lambda
619: (,finvar)
620: (liszt-internal-do
621: ( ,@vrbls)
622: (,testform)
623: ,(cond ((eq join 'nconc)
624: `(cond ((setq ,tempvar ,accform)
625: (cond (,lastvar
626: (liszt-internal-do
627: ()
628: ((null (cdr ,lastvar)))
629: (setq ,lastvar
630: (cdr ,lastvar)))
631: (rplacd ,lastvar ,tempvar))
632: (t (setq ,finvar
633: (setq ,lastvar
634: ,tempvar)))))))
635: (join `(setq ,finvar (,join ,accform ,finvar)))
636: (t accform)))
637: ,(cond ((eq resu 'identity) finvar)
638: (resu `(,resu ,finvar))
639: (t finvar)))
640: nil ))))
641:
642: ; apply to successive elements, return second arg
643: (defun cm-mapc nil
644: (d-mapconvert 'car nil nil (cdr v-form)))
645:
646: ; apply to successive elements, return list of results
647: (defun cm-mapcar nil
648: (d-mapconvert 'car 'cons 'nreverse (cdr v-form)))
649:
650: ; apply to successive elements, returned nconc of results
651: (defun cm-mapcan nil
652: (d-mapconvert 'car 'nconc 'identity (cdr v-form)))
653:
654: ; apply to successive sublists, return second arg
655: (defun cm-map nil
656: (d-mapconvert nil nil nil (cdr v-form)))
657:
658: ; apply to successive sublists, return list of results
659: (defun cm-maplist nil
660: (d-mapconvert nil 'cons 'reverse (cdr v-form)))
661:
662: ; apply to successive sublists, return nconc of results
663: (defun cm-mapcon nil
664: (d-mapconvert nil 'nconc 'identity (cdr v-form)))
665:
666: ;--- cc-memq :: compile a memq expression
667: ;
668: #+(or for-vax for-tahoe)
669: (defun cc-memq nil
670: (let ((loc1 (d-simple (cadr v-form)))
671: (loc2 (d-simple (caddr v-form)))
672: looploc finlab)
673: (if loc2
674: then (d-clearreg 'r1)
675: (if loc1
676: then (d-move loc1 'r1)
677: else (let ((g-loc 'r1)
678: g-cc
679: g-ret)
680: (d-exp (cadr v-form))))
681: (d-move loc2 'reg)
682: else (let ((g-loc 'stack)
683: g-cc
684: g-ret)
685: (d-exp (cadr v-form)))
686: (push nil g-locs)
687: (incr g-loccnt)
688: (let ((g-loc 'reg)
689: g-cc
690: g-ret)
691: (d-exp (caddr v-form)))
692: (L-pop 'r1)
693: (d-clearreg 'r1)
694: (unpush g-locs)
695: (decr g-loccnt))
696: ; now set up the jump addresses
697: (if (null g-loc)
698: then (setq loc1 (if (car g-cc) thenret else (d-genlab))
699: loc2 (if (cdr g-cc) thenret else (d-genlab)))
700: else (setq loc1 (d-genlab)
701: loc2 (d-genlab)))
702:
703: (setq looploc (d-genlab))
704: (e-tst 'r0)
705: (e-write2 'jeql loc2)
706: (e-label looploc)
707: (e-cmp 'r1 '(4 r0))
708: (e-write2 'jeql loc1)
709: (e-move '(0 r0) 'r0)
710: (e-write2 'jneq looploc)
711: (if g-loc
712: then (e-label loc2) ; nil result
713: (d-move 'reg g-loc)
714: (if (cdr g-cc)
715: then (e-goto (cdr g-cc))
716: else (e-goto (setq finlab (d-genlab))))
717: else (if (cdr g-cc)
718: then (e-goto (cdr g-cc))
719: else (e-label loc2)))
720: (if g-loc
721: then (e-label loc1) ; non nil result
722: (d-move 'reg g-loc)
723: (if (car g-cc) then (e-goto (car g-cc)))
724: else (if (null (car g-cc)) then (e-label loc1)))
725: (if finlab then (e-label finlab))))
726:
727: #+for-68k
728: (defun cc-memq nil
729: (let ((loc1 (d-simple (cadr v-form)))
730: (loc2 (d-simple (caddr v-form)))
731: looploc finlab
732: (tmp-data-reg (d-alloc-register 'd nil)))
733: (d-clearreg tmp-data-reg)
734: (d-clearreg 'a0)
735: (if loc2
736: then (if loc1
737: then (d-move loc1 tmp-data-reg)
738: else (let ((g-loc tmp-data-reg)
739: g-cc
740: g-ret)
741: (d-exp (cadr v-form))))
742: (d-move loc2 'reg)
743: else (let ((g-loc 'stack)
744: g-cc
745: g-ret)
746: (d-exp (cadr v-form)))
747: (push nil g-locs)
748: (incr g-loccnt)
749: (let ((g-loc 'reg)
750: g-cc
751: g-ret)
752: (d-exp (caddr v-form)))
753: (L-pop tmp-data-reg)
754: (unpush g-locs)
755: (decr g-loccnt))
756: ; now set up the jump addresses
757: (if (null g-loc)
758: then (setq loc1 (if (car g-cc) thenret else (d-genlab))
759: loc2 (if (cdr g-cc) thenret else (d-genlab)))
760: else (setq loc1 (d-genlab)
761: loc2 (d-genlab)))
762: (setq looploc (d-genlab))
763: (e-cmpnil 'd0)
764: (e-write2 'jeq loc2)
765: (e-move 'd0 'a0)
766: (e-label looploc)
767: (e-cmp tmp-data-reg '(4 a0))
768: (e-write2 'jeq loc1)
769: (e-move '(0 a0) 'a0)
770: (e-cmpnil 'a0)
771: (e-write2 'jne looploc)
772: (e-move 'a0 'd0)
773: (if g-loc
774: then (e-label loc2) ; nil result
775: (d-move 'reg g-loc)
776: (if (cdr g-cc)
777: then (e-goto (cdr g-cc))
778: else (e-goto (setq finlab (d-genlab))))
779: else (if (cdr g-cc)
780: then (e-goto (cdr g-cc))
781: else (e-label loc2)))
782: (if g-loc
783: then (e-label loc1) ; non nil result
784: (d-move 'a0 g-loc) ;a0 was cdr of non-nil result
785: (if (car g-cc) then (e-goto (car g-cc)))
786: else (if (null (car g-cc)) then (e-label loc1)))
787: (if finlab then (e-label finlab))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.