![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to car.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / liszt|
Return to car.l CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / liszt |
1.1 root 1: ; l i s z t v 4
2: ;
3: ;
4: ;
5: ; A compiler for Franz lisp
6: ;
7: ; Copyright (c) 1980 , The Regents of the University of California.
8: ; All rights reserved.
9: ; author: j. foderaro
10: ;
11: ; Section INIT -- initialization and macros
12:
13: (include "caspecs.l")
14:
15: (eval-when (compile eval)
16: (cond ((not (getd 'If))
17: (fasl 'camacs))))
18:
19: ;the version number is maintained by hand, and is written twice
20: ; once for the benefit of the user
21: (setq compiler-name "Lisp Compiler 5.0")
22: ; and the other time for SCCS's what command
23: (setq sccs-compiler-name "@(#)Liszt version 5.0")
24:
25: (setq sectioncarid "@(#)car.l 5.4 11/11/80") ; id for SCCS
26:
27: (setq original-readtable readtable)
28: (setq raw-readtable (makereadtable t))
29:
30: ;--- special handlers
31: (putprop 'and 'cc-and 'fl-exprcc)
32: (putprop 'arg 'cc-arg 'fl-exprcc)
33: (putprop 'atom 'cc-atom 'fl-exprcc)
34: (putprop 'bigp 'cc-bigp 'fl-exprcc)
35: (putprop 'bcdp 'cc-bcdp 'fl-exprcc)
36: (putprop '*catch 'c-*catch 'fl-expr)
37: (putprop 'comment 'cc-ignore 'fl-exprcc)
38: (putprop 'cond 'c-cond 'fl-expr)
39: (putprop 'cons 'c-cons 'fl-expr)
40: (putprop 'cxr 'c-cxr 'fl-exprcc)
41: (putprop 'declare 'c-declare 'fl-expr)
42: (putprop 'do 'c-do 'fl-expr)
43: (putprop 'dtpr 'cc-dtpr 'fl-exprcc)
44: (putprop 'eq 'cc-eq 'fl-exprcc)
45: (putprop 'equal 'cc-equal 'fl-exprcc)
46: (putprop '= 'cc-equal 'fl-exprcc)
47: (putprop 'errset 'c-errset 'fl-expr)
48: (putprop 'fixp 'cc-fixp 'fl-exprcc)
49: (putprop 'floatp 'cc-floatp 'fl-exprcc)
50: (putprop 'get 'c-get 'fl-expr)
51: (putprop 'go 'c-go 'fl-expr)
52: (putprop 'list 'c-list 'fl-expr)
53: (putprop 'map 'cm-map 'fl-exprm)
54: (putprop 'mapc 'cm-mapc 'fl-exprm)
55: (putprop 'mapcan 'cm-mapcan 'fl-exprm)
56: (putprop 'mapcar 'cm-mapcar 'fl-exprm)
57: (putprop 'mapcon 'cm-mapcon 'fl-exprm)
58: (putprop 'maplist 'cm-maplist 'fl-exprm)
59: (putprop 'memq 'cc-memq 'fl-exprcc)
60: (putprop 'not 'cc-not 'fl-exprcc)
61: (putprop 'null 'cc-not 'fl-exprcc)
62: (putprop 'numberp 'cc-numberp 'fl-exprcc)
63: (putprop 'or 'cc-or 'fl-exprcc)
64: (putprop 'prog 'c-prog 'fl-expr)
65: (putprop 'progn 'cm-progn 'fl-exprm)
66: (putprop 'prog1 'cm-prog1 'fl-exprm)
67: (putprop 'prog2 'cm-prog2 'fl-exprm)
68: (putprop 'quote 'cc-quote 'fl-exprcc)
69: (putprop 'return 'c-return 'fl-expr)
70: (putprop 'rplaca 'c-rplaca 'fl-expr)
71: (putprop 'rplacd 'c-rplacd 'fl-expr)
72: (putprop 'setarg 'c-setarg 'fl-expr)
73: (putprop 'setq 'cc-setq 'fl-exprcc)
74: (putprop 'stringp 'cc-stringp 'fl-exprcc)
75: (putprop 'symbolp 'cc-symbolp 'fl-exprcc)
76: (putprop 'symeval 'cm-symeval 'fl-exprm)
77: (putprop '*throw 'c-*throw 'fl-expr)
78: (putprop 'typep 'cc-typep 'fl-exprcc)
79: (putprop 'zerop 'cm-zerop 'fl-exprm)
80:
81: (putprop '1+ 'c-1+ 'fl-expr)
82: (putprop '1- 'c-1- 'fl-expr)
83: (putprop '+ 'c-+ 'fl-expr)
84: (putprop '- 'c-- 'fl-expr)
85: (putprop '* 'c-* 'fl-expr)
86: (putprop '/ 'c-/ 'fl-expr)
87: (putprop '\\ 'c-\\ 'fl-expr)
88:
89:
90:
91:
92: ; Section INTERF -- user interface
93:
94:
95: ;--- lisztinit : called upon compiler startup. If there are any args
96: ; on the command line, we build up a call to lcf, which
97: ; will do the compile. Afterwards we exit.
98: ;
99: (def lisztinit
100: (lambda nil
101: (cond ((greaterp (argv -1) 1) ; build up list of args
102: (do ((i (1- (argv -1)) (1- i)) (arglis))
103: ((lessp i 1)
104: (setq user-top-level nil)
105: (exit (apply 'liszt arglis)))
106: (setq arglis (cons (argv i) arglis))))
107: (t (patom compiler-name)
108: (terpr poport)
109: (setq user-top-level nil)))))
110:
111: (setq user-top-level 'lisztinit)
112:
113:
114:
115: ;--- lcf - v-x : list containing file name to compile and optionaly
116: ; and output file name for the assembler source.
117: ;
118: (def liszt
119: (nlambda (v-x)
120: (prog (piport v-root v-ifile v-sfile v-ofile
121: vp-ifile vp-sfile vps-crap
122: vps-include
123: tmp rootreal
124: g-fname
125: tem temr starttime startptime startgccount
126: fl-asm fl-warn fl-verb fl-inter fl-xref fl-uci
127: g-skipcode g-dropnpcnt)
128:
129: ; turn on monitoring if it exists
130: #+monitoring
131: (errset (progn (monitor t) ; turn it on
132: (print 'monitor-on)
133: (terpr))
134: nil)
135: (setq starttime (syscall 13) ; real time in seconds
136: startptime (ptime)
137: startgccount $gccount$)
138: (cond ((null (boundp 'internal-macros))
139: (setq internal-macros nil)))
140: (cond ((null (boundp 'macros))
141: (setq macros nil)))
142: (setq er-fatal 0)
143: (setq vps-include nil)
144: (setq twa-list nil)
145: (setq liszt-eof-forms nil)
146:
147: ; set up once only g variables
148: (setq g-comments nil
149: g-current nil ; current function name
150: g-funcs nil
151: g-lits nil
152: g-trueloc nil
153: g-tran nil
154: g-allf nil ; used in xrefs
155: g-reguse '((r5 0 . nil) (r4 0 . nil) (r3 0 . nil)
156: (r2 0 . nil) (r7 0 . nil) (r1 0 . nil))
157: g-trancnt 0
158: g-ignorereg nil
159: g-litcnt 0)
160: (setq g-spec (gensym 'S)) ; flag for special atom
161: (setq special nil) ; t if all vrbs are special
162: (setq g-functype (gensym)
163: g-bindloc (gensym)
164: g-localf (gensym)
165: g-tranloc (gensym))
166:
167: ; declare these special
168:
169: (sstatus feature complr)
170: (d-makespec 't) ; always special
171:
172: ; process input form
173: (setq fl-asm t ; assembler file assembled
174: fl-warn t ; print warnings
175: fl-verb t ; be verbose
176: fl-macl nil ; compile maclisp file
177: fl-inter nil ; do interlisp compatablity
178: fl-tty nil ; put .s on tty
179: fl-comments nil ; put in comments
180: fl-profile nil ; profiling
181: fl-tran t ; use transfer tables
182: fl-vms nil ; vms hacks
183: fl-xref nil ; xrefs
184: fl-uci nil ; uci lisp compatibility
185: )
186:
187: (do ((i v-x (cdr i))) ; for each argument
188: ((null i))
189: (setq tem (aexplodec (car i)))
190:
191: (cond ((eq '- (car tem)) ; if switch
192: (do ((j (cdr tem) (cdr j)))
193: ((null j))
194: (cond ((eq 'S (car j)) (setq fl-asm nil))
195: ((eq 'C (car j)) (setq fl-comments t))
196: ((eq 'm (car j)) (setq fl-macl t))
197: ((eq 'o (car j)) (setq v-ofile (cadr i)
198: i (cdr i)))
199: ((eq 'w (car j)) (setq fl-warn nil))
200: ((eq 'q (car j)) (setq fl-verb nil))
201: ((eq 'T (car j)) (setq fl-tty t))
202: ((eq 'i (car j)) (setq fl-inter t))
203: ((eq 'p (car j)) (setq fl-profile t))
204: ((eq 'F (car j)) (setq fl-tran nil))
205: ((eq 'v (car j)) (setq fl-vms t))
206: ((eq 'x (car j)) (setq fl-xref t))
207: ((eq 'u (car j)) (setq fl-uci t))
208: (t (comp-gerr "Unknown switch: "
209: (car j))))))
210: ((null v-root)
211: (setq temr (reverse tem))
212: (cond ((and (eq 'l (car temr))
213: (eq '\. (cadr temr)))
214: (setq rootreal nil)
215: (setq v-root (apply 'concat (reverse (cddr temr)))))
216: (t (setq v-root (car i)
217: rootreal t))))
218:
219: (t (comp-gerr "Extra input file name: " (car i)))))
220:
221:
222: (cond (fl-vms (setq fl-tran nil))) ; no transfer tables in vms
223:
224: ; now see what the arguments have left us
225:
226: (cond ((null v-root)
227: (comp-gerr "No file for input"))
228: ((or (portp
229: (setq vp-ifile
230: (car (errset (infile
231: (setq v-ifile
232: (concat v-root '".l")))
233: nil))))
234: (and rootreal
235: (portp
236: (setq vp-ifile
237: (car (errset
238: (infile (setq v-ifile v-root))
239: nil)))))))
240: (t (comp-gerr "Couldn't open the source file :"
241: (or v-ifile))))
242:
243:
244: ; determine the name of the .s file
245: ; strategy: if fl-asm is t (only assemble) use (v-root).s
246: ; else use /tmp/(PID).s
247: ;
248: ; direct asm to tty temporarily
249: (setq v-sfile '"tty")
250: (setq vp-sfile nil)
251: (If (null fl-tty) then
252: (cond (fl-asm (setq v-sfile (concat '"/tmp/jkf"
253: (boole 1 65535
254: (syscall 20))
255: '".s")))
256: (t (setq v-sfile (concat v-root '".s"))))
257:
258: (cond ((not (portp (setq vp-sfile
259: (car (errset (outfile v-sfile)
260: nil)))))
261: (comp-gerr "Couldn't open the .s file: "
262: (or v-sfile)))))
263:
264:
265: ; determine the name of the .o file (object file)
266: ; strategy: if we aren't supposed to assemble the .s file
267: ; don't worry about a name
268: ; else if a name is given, use it
269: ; else if use (v-root).o
270: ; if profiling, use .o
271: (cond ((or v-ofile (null fl-asm))) ;ignore
272: ((null fl-profile) (setq v-ofile (concat v-root '".o")))
273: (t (setq v-ofile (concat v-root ".o"))))
274:
275: ; determine the name of the .x file (xref file)
276: ; strategy: if fl-xref is true, then use (v-root).x
277: ;
278: (cond (fl-xref
279: (cond ((not
280: (portp
281: (setq vp-xfile
282: (car (errset (outfile (setq v-xfile
283: (concat v-root ".x"))))))))
284: (comp-gerr "Can't open the .x file" (or v-xfile))))))
285: (cond ((checkfatal) (return 1)))
286:
287: (setq readtable (makereadtable nil)) ; use new readtable
288:
289:
290: ; if the macsyma flag is set, change the syntax to the
291: ; maclisp standard syntax. We must be careful that we
292: ; dont clobber any syntax changes made by files preloaded
293: ; into the compiler.
294:
295: (cond (fl-macl (setsyntax '\/ 143) ; 143 = vesc
296:
297: (cond ((equal 143 (status syntax \\))
298: (setsyntax '\\ 2)))
299:
300: (setsyntax '\| 138) ; 138 = vdq
301: (cond ((equal 198 (status syntax \[))
302: (setsyntax '\[ 2)
303: (setsyntax '\] 2)))
304: (setq ibase 8.)
305: (sstatus uctolc t)
306:
307: (d-makespec 'ibase) ; to be special
308: (d-makespec 'base)
309: (d-makespec 'tty)
310:
311: (errset (cond ((null (getd 'macsyma-env))
312: (fasl '/usr/lib/lisp/machacks)))
313: nil))
314: (fl-uci (load "/usr/lib/lisp/ucifnc")
315: (cvttoucilisp)))
316:
317: (cond (fl-inter (putprop '* 'cc-ignore 'fl-exprcc) ;comment
318: (remprop '* 'fl-expr)
319: ))
320:
321: (cond ((checkfatal) (return 1))) ; leave if fatal errors
322:
323: (comp-note "Compilation begins with " compiler-name)
324: (comp-note "source: " v-ifile ", result: "
325: (cond (fl-asm v-ofile) (t v-sfile)))
326: (setq piport vp-ifile) ; set to standard input
327: (setq liszt-root-name v-root
328: liszt-file-name v-ifile)
329:
330:
331: (If fl-profile then (e-write1 '".globl mcount"))
332: loop
333:
334: (cond ((atom (errset ; list for debugging,
335: ; errset for production.
336: (do ((i (read piport '<<end-of-file>>)
337: (read piport '<<end-of-file>>)))
338: ((eq i '<<end-of-file>>) nil)
339: (catch (liszt-form i) Comp-error))))
340: (comp-note "Lisp error during compilation")
341: (setq piport nil)
342: (setq er-fatal (1+ er-fatal))
343: (return 1)))
344:
345: (close piport)
346:
347: (cond ((checkfatal) (return 1)))
348:
349: ; if doing special character stuff (maclisp) reassert
350: ; the state
351:
352: (cond (vps-include
353: (comp-note " done include")
354: (setq piport (car vps-include))
355: (setq vps-include (cdr vps-include))
356: (go loop)))
357:
358: (cond (liszt-eof-forms
359: (do ((ll liszt-eof-forms (cdr ll)))
360: ((null ll))
361: (cond ((atom (errset (liszt-form (car ll))))
362: (comp-note "Lisp error during eof forms")
363: (setq piport nil)
364: (return 1))))))
365:
366: ; reset input base
367: (setq ibase 10.)
368: (setq readtable (makereadtable t))
369: (d-bindtab)
370:
371:
372: (close vp-sfile) ; close assembler language file
373: (comp-note "Compilation complete")
374:
375: (setq tem (Divide (difference (syscall 13) starttime) 60))
376: (comp-note " Real time: " (car tem) " minutes, "
377: (cadr tem) " seconds")
378: (setq tem (ptime))
379: (setq temr (Divide (difference (car tem) (car startptime))
380: 3600))
381: (comp-note " CPU time: " (car temr) " minutes, "
382: (quotient (cadr temr) 60.0) " seconds")
383: (setq temr (Divide (difference (cadr tem) (cadr startptime))
384: 3600))
385: (comp-note " of which " (car temr) " minutes and "
386: (quotient (cadr temr) 60.0)
387: " seconds were for the "
388: (difference $gccount$ startgccount)
389: " gcs which were done")
390:
391: (cond (fl-xref
392: (comp-note "Cross reference being generated")
393: (print (list 'File v-ifile) vp-xfile)
394: (terpr vp-xfile)
395: (do ((ii g-allf (cdr ii)))
396: ((null ii))
397: (print (car ii) vp-xfile)
398: (terpr vp-xfile))
399: (close vp-xfile)))
400:
401:
402: ; the assember we use must generate the new a.out format
403: ; with a string table. We will assume that the assembler
404: ; is in /usr/lib/lisp/as so that other sites can run
405: ; the new assembler without installing the new assembler
406: ; as /bin/as
407: (cond (fl-asm ; assemble file
408: (comp-note "Assembly begins")
409: (cond ((not
410: (zerop
411: (setq tmp
412: (apply 'process
413: (ncons (concat
414: "/usr/lib/lisp/as -o "
415: v-ofile
416: '" "
417: v-sfile))))))
418: (comp-gerr "Assembler detected error, code: "
419: tmp)
420: (comp-note "Assembler temp file " v-sfile
421: " is not unlinked"))
422: (t (comp-note "Assembly completed successfully")
423: (syscall 10 v-sfile))))) ; unlink tmp file
424:
425: (setq readtable original-readtable)
426: #+monitoring
427: (errset (progn (monitor) ; turn off monitoring
428: (print 'monitor-off))
429: nil)
430: (return 0))))
431:
432: (def checkfatal
433: (lambda nil
434: (cond ((greaterp er-fatal 0)
435: (comp-note "Compilation aborted")
436: t))))
437:
438: ;--- liszt-form - i : form to compile
439: ; This compiles one form.
440: ;
441: (def liszt-form
442: (lambda (i)
443: (prog (tmp v-x)
444: ; macro expand
445: loop
446: (If (and (dtpr i) (eq 'macro (d-functyp (car i))))
447: then (setq i (apply (car i) i))
448: (go loop))
449: ; now look at what is left
450: (cond ((eq (car i) 'def) ; jkf mod
451: (cond (fl-verb (print (cadr i)) (terpr)(drain)))
452: (d-dodef i))
453: ((eq (car i) 'declare) (funcall 'complr-declare (cdr i)))
454: ((eq (car i) 'eval-when) (doevalwhen i))
455: ((and (eq (car i) 'progn) (equal (cadr i) '(quote compile)))
456: ((lambda (internal-macros) ; compile macros too
457: (mapc 'liszt-form (cddr i)))
458: t))
459: ((or (and (eq (car i) 'includef) (setq tmp (eval (cadr i))))
460: (and (eq (car i) 'include ) (setq tmp (cadr i))))
461: (cond ((or (portp (setq v-x
462: (car (errset (infile tmp) nil))))
463: (portp (setq v-x
464: (car (errset (infile (concat '"/usr/lib/lisp"
465: tmp))
466: nil))))
467: (portp (setq v-x
468: (car (errset (infile (concat tmp
469: '".l"))
470: nil)))))
471: (setq vps-include (cons piport vps-include))
472: (setq piport v-x)
473: (comp-note " INCLUDEing file: " tmp))
474: (t (comp-gerr "Cannot open include file: " tmp))))
475: ((eq (car i) 'comment) nil) ; just ignore comments
476: (t (Push g-funcs `(eval ,i)))))))
477:
478: ;--- d-dodef :: handle the def form
479: ; - form : a def form: (def name (type args . body))
480: ;
481: (defun d-dodef (form)
482: (prog nil
483:
484: loop
485:
486: (let ( ((g-fname (g-ftype g-args . body)) (cdr form))
487: (lambdaform (caddr form))
488: (symlab (gensym 'F)))
489: (If (or (memq '&rest g-args)
490: (memq '&optional g-args)
491: (memq '&aux g-args))
492: then (setq form
493: `(def ,(cadr form) ,(lambdacvt (cdr lambdaform))))
494: (go loop))
495: (If (null (atom g-fname))
496: then (comp-err "bad function name")
497: else (setq g-flocal (get g-fname g-localf))
498: (If (eq g-ftype 'macro)
499: then (eval form)
500: (If (and (null macros)
501: (null internal-macros))
502: then (comp-note " macro will not be compiled")
503: (return nil))
504: (Push g-funcs `(macro ,symlab ,g-fname))
505: elseif g-flocal
506: then (If (null (or (eq g-ftype 'lambda)
507: (eq g-ftype 'nlambda)))
508: then (comp-err "bad type for fcn" (or g-ftype)))
509: elseif (or (eq g-ftype 'lambda)
510: (eq g-ftype 'lexpr))
511: then (Push g-funcs `(lambda ,symlab ,g-fname))
512: elseif (eq g-ftype 'nlambda)
513: then (Push g-funcs `(nlambda ,symlab ,g-fname))
514: else (comp-err " bad function type " g-ftype)))
515: (setq g-skipcode nil) ;make sure we aren't skipping code
516: (forcecomment `(fcn ,g-ftype ,g-fname))
517: (If g-flocal
518: then (comp-note "is a local function")
519: (e-writel (car g-flocal))
520: else
521: (If (null fl-vms) then (e-write2 '".globl" symlab))
522: (e-writel symlab))
523: (setq g-locs nil g-loccnt 0 g-labs nil g-loc 'reg g-cc nil
524: g-ret t g-topsym (d-genlab))
525: (If fl-xref then (setq g-refseen (gensym) g-reflst nil))
526: (d-clearreg)
527: (Push g-locs (cons 'lambda 0))
528: (setq g-currentargs (length g-args))
529: (mapc '(lambda (x) (Push g-locs nil) (incr g-loccnt))
530: g-args)
531: (d-prelude) ; do beginning stuff
532: (d-lambbody lambdaform) ; emit code
533: (d-fini)
534: (If fl-xref then
535: (Push g-allf
536: (cons g-fname
537: (cons (cond (g-flocal (cons g-ftype 'local))
538: (t g-ftype))
539: g-reflst)))))))
540:
541:
542: ;--- d-prelude :: emit code common to beginning of all functions
543: ;
544: (defun d-prelude nil
545: (If g-flocal
546: then (e-write3 'movl 'r10 '"-(sp)") ; (faster than pushl)
547: (e-write3 'movab `(,(* -4 g-currentargs) r6) 'r10)
548: (e-writel g-topsym)
549: else
550: (e-write2 '".word" '0x5c0)
551: (If fl-profile
552: then (e-write3 'movab 'mcounts 'r0)
553: (e-write2 'jsb 'mcount))
554: (e-write3 'movab 'linker '#.bind-reg)
555: (If (eq g-ftype 'lexpr)
556: then
557: (e-write4 'subl3 '$4 Lbot-reg '"-(sp)") ; set up base for (arg)
558: (e-writel g-topsym)
559: (e-write3 'movl Np-reg oLbot-reg) ; will stack num of args
560: (e-write4 'subl3 Lbot-reg Np-reg 'r0) ; arg cnt again
561: (e-write3 'movab '"0x1400(r0)" np-plus) ; stack lispval
562: (e-write3 'movl '(0 #.oLbot-reg) '"-(sp)") ; also on runtime stk
563: else
564: ; set up old lbot register, base register for variable
565: ; references
566: (e-write3 'movl '#.Lbot-reg '#.oLbot-reg)
567: ; make sure the np register points where it should since
568: ; the caller might have given too few or too many args
569: (e-write3 'movab `(,(* 4 g-currentargs) #.oLbot-reg)
570: '#.Np-reg)
571: (e-writel g-topsym))))
572:
573: ;--- d-fini :: emit code at end of function
574:
575: (defun d-fini nil
576: (If g-flocal then (e-write3 'movl '"(sp)+" 'r10)
577: (e-write1 'rsb)
578: else (e-return)))
579:
580:
581: ;--- d-bindtab :: emit binder table when all functions compiled
582: ;
583: (defun d-bindtab nil
584: (setq g-skipcode nil) ; make sure this isnt ignored
585: (e-writel "bind_org")
586: (e-write2 ".set linker_size," (length g-lits))
587: (e-write2 ".set trans_size," (length g-tran))
588: (do ((ll (setq g-funcs (nreverse g-funcs)) (cdr ll)))
589: ((null ll))
590: (If (memq (caar ll) '(lambda nlambda macro eval))
591: then (e-write2 '".long" (cdr (assoc (caar ll)
592: '((lambda . 0)
593: (nlambda . 1)
594: (macro . 2)
595: (eval . 99)))))
596: else (comp-err " bad type in lit list " (car ll))))
597:
598: (e-write1 ".long -1")
599: (e-write1 '"lit_org:")
600: (d-asciiout (nreverse g-lits))
601: (If g-tran then (d-asciiout (nreverse g-tran)))
602: (d-asciiout (mapcar '(lambda (x) (If (eq (car x) 'eval)
603: then (cadr x)
604: else (caddr x)))
605: g-funcs))
606:
607: (e-write1 '"lit_end:"))
608:
609: ;--- d-asciiout :: print a list of asciz strings
610: ;
611: (defun d-asciiout (args)
612: (do ((lits args (cdr lits))
613: (form))
614: ((null lits))
615: (setq form (explode (car lits))
616: formsiz (length form))
617: (do ((remsiz formsiz)
618: (curform form)
619: (thissiz))
620: ((zerop remsiz))
621: (If (greaterp remsiz 60) then (sfilewrite '".ascii \"")
622: else (sfilewrite '".asciz \""))
623: (setq thissiz (min 60 remsiz))
624: (do ((count thissiz (1- count)))
625: ((zerop count)
626: (sfilewrite (concat '\" (ascii 10)))
627: (setq remsiz (difference remsiz thissiz)))
628: (If (eq ch-newline (car curform))
629: then (sfilewrite '\\012)
630: else (If (or (eq '\\ (car curform))
631: (eq '\" (car curform)))
632: then (sfilewrite '\\))
633: (sfilewrite (car curform)))
634: (setq curform (cdr curform))))))
635:
636: ;--- doevalwhen, process evalwhen directive. This is inadequate.
637: ;
638: (def doevalwhen
639: (lambda (v-f)
640: (prog (docom dolod)
641: (setq docom (memq 'compile (cadr v-f))
642:
643: dolod (memq 'load (cadr v-f)))
644: (mapc '(lambda (frm) (cond (docom (eval frm)))
645: (cond (dolod
646: ((lambda (internal-macros)
647: (liszt-form frm))
648: t))))
649: (cddr v-f)))))
650:
651:
652: ;---- dodcl - forms declare form
653: ; process the declare form given. We evaluate each arg
654: ;
655: (defun complr-declare fexpr (forms)
656: (do ((i forms (cdr i)))
657: ((null i))
658: (cond ((and (atom (caar i))
659: (getd (caar i)))
660: (eval (car i))) ; if this is a function
661: (t (comp-warn "Unknown declare attribute: " (car i))))))
662:
663: ;---> handlers for declare forms
664: ;
665: (def *fexpr
666: (nlambda (args)
667: (mapc '(lambda (v-a)
668: (putprop v-a 'nlambda g-functype))
669: args)))
670:
671: (def nlambda
672: (nlambda (args)
673: (mapc '(lambda (v-a)
674: (putprop v-a 'nlambda g-functype))
675: args)))
676:
677: (def special
678: (nlambda (v-l)
679: (mapc '(lambda (v-a)
680: (putprop v-a t g-spec) )
681: v-l)
682: t))
683: (def unspecial
684: (nlambda (v-l)
685: (mapc '(lambda (v-a)
686: (putprop v-a nil g-spec))
687: v-l)
688: t))
689:
690: (def *expr
691: (nlambda (args)
692: (mapc
693: '(lambda (v-a)
694: (cond ((atom v-a) (putprop v-a 'lambda g-functype))
695: (t (comp-warn "Bad declare form " v-a
696: " in list " args))))
697: args)
698: t))
699:
700: (def *lexpr
701: (nlambda (args)
702: (mapc '(lambda (v-a)
703: (putprop v-a 'lexpr g-functype))
704: args)
705: t)) ; ignore
706:
707: (def fixnum
708: (nlambda (args)
709: nil)) ; ignore
710:
711: (def flonum
712: (nlambda (args)
713: nil)) ; ignore
714:
715: (def macros
716: (nlambda (args) (setq macros (car args))))
717:
718: (def localf
719: (nlambda (args) (mapc '(lambda (ar)
720: (If (null (get ar g-localf))
721: then (putprop ar
722: (cons (d-genlab) -1)
723: g-localf)))
724: args)))
725: ;---> end declare form handlers
726:
727:
728:
729:
730:
731:
732:
733:
734:
735: ;--- lambdacvt
736: ; converts a lambda expression with &optional, &rest and &aux forms in
737: ; the argument list into a lexpr which will do the desired function.
738: ; method of operation
739: ; the argument list is examined and the following lists are made:
740: ; vbs - list of variables to be lambda bound
741: ; opl - list of optional forms
742: ; vals - list of values to be assigned to the vbs
743: ;
744: (def lambdacvt
745: (lambda (exp)
746: (prog (arg vbs vals opl rest opflg restflg narg narg2 narg3 auxflg
747: avbs)
748: (do ((ll (car exp) (cdr ll))
749: (count 1 (1+ count)))
750: ((null ll))
751: (cond ((eq '&rest (car ll))
752: (setq restflg t opflg nil count (1- count)))
753: ((eq '&optional (car ll))
754: (setq opflg t count (1- count)))
755: ((eq '&aux (car ll))
756: (setq auxflg t
757: opflg nil
758: restflg nil
759: count (1- count)))
760: (opflg
761: (cond ((atom (setq arg (car ll)))
762: (setq opl (cons (cons (ncons arg) count) opl)
763: vbs (cons arg vbs)
764: vals (cons nil vals)))
765: ((cddr arg)
766: (setq vbs (cons (car arg)
767: (cons (caddr arg)
768: vbs))
769: vals (cons nil
770: (cons nil vals))
771: opl (cons (cons arg count) opl)))
772: (t (setq vbs (cons (car arg) vbs)
773: vals (cons nil vals)
774: opl (cons (cons arg count) opl)))))
775: (restflg
776: (setq vbs (cons (car ll) vbs)
777: vals (cons nil vals)
778: rest (cons (car ll) count)))
779: (auxflg
780: (setq count (1- count))
781: (cond ((atom (setq arg (car ll)))
782: (setq avbs (cons (ncons arg) avbs)))
783: (t (setq avbs (cons arg avbs)))))
784: (t (setq vbs (cons (car ll) vbs)
785: vals (cons `(arg ,count) vals)))))
786: (setq narg (gensym))
787:
788: (return
789: `(lexpr (,narg)
790: ((lambda ,(nreverse vbs)
791: ,@(mapcar
792: '(lambda (arg)
793: `(cond ((greaterp ,(cdr arg)
794: ,narg)
795: ,@(cond ((cadar arg)
796: `((setq ,(caar arg)
797: ,(cadar arg))))))
798: (t (setq ,(caar arg) (arg ,(cdr arg)))
799: ,@(cond ((cddar arg)
800: `((setq ,(caddar arg)
801: t)))))))
802: (nreverse opl))
803: ,@(cond (rest (setq narg2 (gensym)
804: narg3 (gensym))
805: `((do ((,narg2 ,narg (1- ,narg2))
806: (,narg3 nil (cons (arg ,narg2)
807: ,narg3)))
808: ((lessp ,narg2 ,(cdr rest))
809: (setq ,(car rest) ,narg3))))))
810: ,@(cond (auxflg `((let* ,(nreverse avbs)
811: ,@(cdr exp))))
812: (t (cdr exp))))
813: ,@(nreverse vals)))))))
814:
815: ; this routine is copied from ccb.l so we can make it a local function
816: ; in both files
817:
818: ;--- d-genlab :: generate a pseudo label
819: ;
820: (defun d-genlab nil
821: (gensym 'L))
822:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.