![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.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 io.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 io
3: "$Header: io.l,v 1.15 83/09/06 21:47:47 layer Exp $")
4:
5: ;;; ---- i o input output
6: ;;;
7: ;;; -[Fri Sep 2 21:37:05 1983 by layer]-
8:
9:
10: ;--- d-prelude :: emit code common to beginning of all functions
11: ;
12: (defun d-prelude nil
13: (let ((loada-op #+for-vax 'movab #+for-68k 'lea)
14: (sub2-op #+for-vax 'subl2 #+for-68k 'subl)
15: (add2-op #+for-vax 'addl2 #+for-68k 'addl)
16: (temp-reg #+for-68k 'a5 #+for-vax '#.fixnum-reg))
17: #+for-68k (setq g-stackspace (d-genlab) g-masklab (d-genlab))
18: (if g-flocal
19: then (C-push '#.olbot-reg)
20: (e-write3 loada-op
21: `(,(* -4 g-currentargs) #.np-reg) '#.olbot-reg)
22: (e-writel g-topsym)
23: else #+for-vax (e-write2 '".word" '0x5c0)
24: #+for-68k
25: (progn
26: (e-write3 'link 'a6 (concat "#-" g-stackspace))
27: (e-write2 'tstb '(-132 sp))
28: (e-write3 'moveml `($ ,g-masklab)
29: (concat "a6@(-" g-stackspace ")"))
30: (e-move '#.Nilatom '#.nil-reg))
31: (if fl-profile
32: then (e-write3 loada-op 'mcounts
33: #+for-vax 'r0 #+for-68k 'a0)
34: (e-quick-call 'mcount))
35: (e-write3 loada-op 'linker '#.bind-reg)
36: (if (eq g-ftype 'lexpr)
37: then ; Here is the method:
38: ; We push the number of arguments, nargs,
39: ; on the name stack twice, setting olbot-reg
40: ; to point to the second one, so that the user
41: ; has a copy that he can set, and we have
42: ; one that we can use for address calcs.
43: ; So, the stack will look like this, after
44: ; the setup:
45: ;np ->
46: ;olbot -> nargs (II)
47: ; -> nargs (I)
48: ; -> (arg nargs)
49: ; -> (arg nargs-1)
50: ;...
51: ; -> (arg 1)
52: ;
53: (if (null $global-reg$)
54: then (e-move '#.np-sym '#.np-reg))
55: (e-writel g-topsym)
56: (e-move '#.np-reg temp-reg)
57: (e-write3 sub2-op
58: (if $global-reg$
59: then '#.lbot-reg
60: else '#.lbot-sym) temp-reg)
61: (e-write3 add2-op (e-cvt '(fixnum 0)) temp-reg)
62: (L-push temp-reg)
63: (e-move '#.np-reg '#.olbot-reg)
64: (L-push temp-reg)
65: else ; Set up old lbot register, base reg for variable
66: ; references, and make sure the np points where
67: ; it should since the caller might
68: ; have given too few or too many args.
69: (e-move
70: (if $global-reg$
71: then '#.lbot-reg
72: else '#.lbot-sym)
73: '#.olbot-reg)
74: #+for-68k
75: (e-write3 loada-op
76: `(,(* 4 g-currentargs) #.olbot-reg)
77: '#.np-reg)
78: (e-writel g-topsym)))))
79:
80: ;--- d-fini :: emit code at end of function
81: ;
82: (defun d-fini nil
83: (if g-flocal
84: then (C-pop '#.olbot-reg)
85: (e-write1 #+for-vax 'rsb #+for-68k 'rts)
86: else #+for-68k
87: (progn
88: (e-write3 'moveml (concat "a6@(-" g-stackspace ")")
89: `($ ,g-masklab))
90: (e-write2 'unlk 'a6))
91: (e-return)))
92:
93: ;--- d-bindtab :: emit binder table when all functions compiled
94: ;
95: (defun d-bindtab nil
96: (setq g-skipcode nil) ; make sure this isnt ignored
97: (e-writel "bind_org")
98: #+for-vax
99: (progn
100: (e-write2 ".set linker_size," (length g-lits))
101: (e-write2 ".set trans_size," (length g-tran)))
102: #+for-68k
103: (progn
104: (e-write2 "linker_size = " (length g-lits))
105: (e-write2 "trans_size = " (length g-tran)))
106: (do ((ll (setq g-funcs (nreverse g-funcs)) (cdr ll)))
107: ((null ll))
108: (if (memq (caar ll) '(lambda nlambda macro eval))
109: then (e-write2 '".long"
110: (cdr (assoc (caar ll)
111: '((lambda . 0) (nlambda . 1)
112: (macro . 2) (eval . 99)))))
113: else (comp-err " bad type in lit list " (car ll))))
114:
115: (e-write1 ".long -1")
116: (e-writel "lit_org")
117: (d-asciiout (nreverse g-lits))
118: (if g-tran then (d-asciiout (nreverse g-tran)))
119: (d-asciiout (mapcar '(lambda (x) (if (eq (car x) 'eval)
120: then (cadr x)
121: else (caddr x)))
122: g-funcs))
123: (e-writel "lit_end"))
124:
125: ;--- d-asciiout :: print a list of asciz strings
126: ;
127: (defun d-asciiout (args)
128: (do ((lits args (cdr lits))
129: (form))
130: ((null lits))
131: (setq form (explode (car lits))
132: formsiz (length form))
133: (do ((remsiz formsiz)
134: (curform form)
135: (thissiz))
136: ((zerop remsiz))
137: (if (greaterp remsiz 60) then (sfilewrite '".ascii \"")
138: else (sfilewrite '".asciz \""))
139: (setq thissiz (min 60 remsiz))
140: (do ((count thissiz (1- count)))
141: ((zerop count)
142: (sfilewrite (concat '\" (ascii 10)))
143: (setq remsiz (difference remsiz thissiz)))
144: (if (eq '#.ch-newline (car curform))
145: then (sfilewrite '\\012)
146: else (if (or (eq '\\ (car curform))
147: (eq '\" (car curform)))
148: then (sfilewrite '\\))
149: (sfilewrite (car curform)))
150: (setq curform (cdr curform))))))
151:
152: ;--- d-autorunhead
153: ;
154: ; Here is the C program to generate the assembly language:
155: ; (after some cleaning up)
156: ;
157: ;main(argc,argv,arge)
158: ;register char *argv[];
159: ;register char **arge;
160: ;{
161: ; *--argv = "-f";
162: ; *--argv = "/usr/ucb/lisp";
163: ; execve("/usr/ucb/lisp",argv,arge);
164: ; exit(0);
165: ;}
166: ;
167: (defun d-printautorun nil
168: (let ((readtable (makereadtable t)) ; in raw readtable
169: tport ar-file)
170: (setsyntax #/; 'vsplicing-macro 'zapline)
171: (setq ar-file (concat lisp-library-directory
172: #+for-vax "/autorun/vax"
173: #+for-68k "/autorun/68k"))
174: (if (null (errset (setq tport (infile ar-file))))
175: then (comp-err "Can't open autorun header file " ar-file))
176: (do ((x (read tport '<eof>) (read tport '<eof>)))
177: ((eq '<eof> x) (close tport))
178: (sfilewrite x))))
179:
180: (defun e-cvt (arg)
181: (if (eq 'reg arg) then #+for-vax 'r0 #+for-68k 'd0
182: elseif (eq 'areg arg) then #+for-vax 'r0 #+for-68k 'a0
183: elseif (eq 'Nil arg) then #+for-vax '($ 0) #+for-68k '#.nil-reg
184: elseif (eq 'T arg)
185: then (if g-trueloc
186: thenret
187: else (setq g-trueloc (e-cvt (d-loclit t nil))))
188: elseif (eq 'stack arg) then '(+ #.np-reg)
189: elseif (eq 'unstack arg) then '(- #.np-reg)
190: elseif (or (atom arg) (symbolp arg)) then arg
191: elseif (dtpr arg)
192: then (caseq (car arg)
193: (stack `(,(* 4 (1- (cadr arg))) #.olbot-reg))
194: (vstack `(* ,(* 4 (1- (cadr arg))) #.olbot-reg))
195: (bind `(* ,(* 4 (1- (cadr arg))) #.bind-reg))
196: (lbind `(,(* 4 (1- (cadr arg))) #.bind-reg))
197: (fixnum `(\# ,(cadr arg)))
198: (immed `($ ,(cadr arg)))
199: (racc (cdr arg))
200: (t (comp-err " bad arg to e-cvt : "
201: (or arg))))
202: else (comp-warn "bad arg to e-cvt : " (or arg))))
203:
204: ;--- e-uncvt :: inverse of e-cvt, used for making comments pretty
205: ;
206: (defun e-uncvt (arg)
207: (if (atom arg)
208: then (if (eq 'Nil arg)
209: then nil
210: else arg)
211: elseif (eq 'stack (car arg))
212: then (do ((i g-loccnt)
213: (ll g-locs))
214: ((and (equal i (cadr arg)) (atom (car ll))) (car ll))
215: (if (atom (car ll))
216: then (setq ll (cdr ll)
217: i (1- i))
218: else (setq ll (cdr ll))))
219: elseif (or (eq 'bind (car arg)) (eq 'lbind (car arg)))
220: then (do ((i g-litcnt (1- i))
221: (ll g-lits (cdr ll)))
222: ((equal i (cadr arg))
223: (cond ((eq 'lbind (car arg))
224: (list 'quote (car ll)))
225: (t (car ll)))))
226: else arg))
227:
228: ;--- e-cvtas :: convert an EIADR to vax unix assembler fmt and print it
229: ; - form : an EIADR form
230: ;
231: #+for-vax
232: (defun e-cvtas (form)
233: (if (atom form)
234: then (sfilewrite form)
235: else (if (eq '* (car form))
236: then (if (eq '\# (cadr form))
237: then (setq form `($ ,(caddr form)))
238: else (sfilewrite "*")
239: (setq form (cdr form))))
240: (if (numberp (car form))
241: then (sfilewrite (car form))
242: (sfilewrite "(")
243: (sfilewrite (cadr form))
244: (sfilewrite ")")
245: (if (caddr form)
246: then (sfilewrite "[")
247: (sfilewrite (caddr form))
248: (sfilewrite "]"))
249: elseif (eq '+ (car form))
250: then (sfilewrite '"(")
251: (sfilewrite (cadr form))
252: (sfilewrite '")+")
253: elseif (eq '- (car form))
254: then (sfilewrite '"-(")
255: (sfilewrite (cadr form))
256: (sfilewrite '")")
257: elseif (eq '\# (car form)) ; 5120 is base of small fixnums
258: then (sfilewrite (concat "$" (+ (* (cadr form) 4) 5120)))
259: elseif (eq '$ (car form))
260: then (sfilewrite '"$")
261: (sfilewrite (cadr form)))))
262:
263: #+for-68k
264: (defun e-cvtas (form)
265: (if (atom form)
266: then (sfilewrite form)
267: else (if (eq '* (car form))
268: then (if (eq '\# (cadr form))
269: then (setq form `($ ,(caddr form)))))
270: (if (numberp (car form))
271: then (sfilewrite (cadr form))
272: (sfilewrite "@")
273: (if (not (zerop (car form)))
274: then (sfilewrite "(")
275: (sfilewrite (car form))
276: (sfilewrite ")"))
277: elseif (eq '% (car form))
278: then (setq form (cdr form))
279: (sfilewrite (cadr form))
280: (sfilewrite "@(")
281: (sfilewrite (car form))
282: (sfilewrite ",")
283: (sfilewrite (caddr form))
284: (sfilewrite ":L)")
285: elseif (eq '+ (car form))
286: then (sfilewrite (cadr form))
287: (sfilewrite '"@+")
288: elseif (eq '- (car form))
289: then (sfilewrite (cadr form))
290: (sfilewrite '"@-")
291: elseif (eq '\# (car form))
292: then (sfilewrite (concat '#.Nilatom "+0x1400"
293: (if (null (signp l (cadr form)))
294: then "+" else "")
295: (* (cadr form) 4)))
296: elseif (eq '$ (car form))
297: then (sfilewrite '"#")
298: (sfilewrite (cadr form))
299: else (comp-err " bad arg to e-cvtas : " (or form)))))
300:
301: ;--- e-docomment :: print any comment lines
302: ;
303: (defun e-docomment nil
304: (if g-comments
305: then (do ((ll (nreverse g-comments) (cdr ll)))
306: ((null ll))
307: (sfilewrite " ")
308: (sfilewrite #.comment-char)
309: (do ((ll (exploden (car ll)) (cdr ll)))
310: ((null ll))
311: (tyo (car ll) vp-sfile)
312: (cond ((eq #\newline (car ll))
313: (sfilewrite #.comment-char))))
314: (terpr vp-sfile))
315: (setq g-comments nil)
316: else (terpr vp-sfile)))
317:
318: ;--- e-goto :: emit code to jump to the location given
319: ;
320: (defun e-goto (lbl)
321: (e-jump lbl))
322:
323: ;--- e-gotonil :: emit code to jump if nil was last computed
324: ;
325: (defun e-gotonil (lbl)
326: (e-write2 g-falseop lbl))
327:
328: ;--- e-gotot :: emit code to jump if t was last computed
329: (defun e-gotot (lbl)
330: (e-write2 g-trueop lbl))
331:
332: ;--- e-label :: emit a label
333: (defun e-label (lbl)
334: (setq g-skipcode nil)
335: (e-writel lbl))
336:
337: ;--- e-pop :: pop the given number of args from the stack
338: ; g-locs is not! fixed
339: ;
340: (defun e-pop (nargs)
341: (if (greaterp nargs 0)
342: then (e-dropnp nargs)))
343:
344: ;--- e-pushnil :: push a given number of nils on the stack
345: ;
346: #+for-vax
347: (defun e-pushnil (nargs)
348: (do ((i nargs))
349: ((zerop i))
350: (if (>& i 1)
351: then (e-write2 'clrq '#.np-plus)
352: (setq i (- i 2))
353: elseif (equal i 1)
354: then (e-write2 'clrl '#.np-plus)
355: (setq i (1- i)))))
356:
357: #+for-68k
358: (defun e-pushnil (nargs)
359: (do ((i nargs))
360: ((zerop i))
361: (L-push '#.nil-reg)
362: (setq i (1- i))))
363:
364: ;--- e-setupbind :: setup for shallow binding
365: ;
366: (defun e-setupbind nil
367: (e-move '#.bnp-sym '#.bnp-reg))
368:
369: ;--- e-unsetupbind :: restore temp value of bnp to real loc
370: ;
371: (defun e-unsetupbind nil
372: (e-move '#.bnp-reg '#.bnp-sym))
373:
374: ;--- e-shallowbind :: shallow bind value of variable and initialize it
375: ; - name : variable name
376: ; - val : IADR value for variable
377: ;
378: (defun e-shallowbind (name val)
379: (let ((vloc (d-loclit name t)))
380: (e-move (e-cvt vloc) '(+ #.bnp-reg)) ; store old val
381: (e-move (e-cvt `(lbind ,@(cdr vloc)))
382: '(+ #.bnp-reg)) ; now name
383: (d-move val vloc)))
384:
385: ;--- e-unshallowbind :: un shallow bind n variable from top of stack
386: ;
387: #+for-vax
388: (defun e-unshallowbind (n)
389: (e-setupbind) ; set up binding register
390: (do ((i 1 (1+ i)))
391: ((greaterp i n))
392: (e-move `(,(* -8 i) #.bnp-reg) `(* ,(+ 4 (* -8 i)) #.bnp-reg)))
393: (e-sub3 `($ ,(* 8 n)) '#.bnp-reg '#.bnp-sym))
394:
395: #+for-68k
396: (defun e-unshallowbind (n)
397: (makecomment "e-unshallowbind begin...")
398: (e-setupbind) ; set up binding register
399: (do ((i 1 (1+ i)))
400: ((greaterp i n))
401: (e-move `(,(* -8 i) #.bnp-reg) `(* ,(+ 4 (* -8 i)) #.bnp-reg)))
402: (e-move '#.bnp-reg '#.bnp-sym)
403: (e-sub `($ ,(* 8 n)) '#.bnp-sym)
404: (makecomment "...end e-unshallowbind"))
405:
406: ;----------- very low level routines
407: ; all output to the assembler file goes through these routines.
408: ; They filter out obviously extraneous instructions as well as
409: ; combine sequential drops of np.
410:
411: ;--- e-dropnp :: unstack n values from np.
412: ; rather than output the instruction now, we just remember that it
413: ; must be done before any other instructions are done. This will
414: ; enable us to catch sequential e-dropnp's
415: ;
416: (defun e-dropnp (n)
417: (if (not g-skipcode)
418: then (setq g-dropnpcnt (+ n (if g-dropnpcnt thenret else 0)))))
419:
420: ;--- em-checknpdrop :: check if we have a pending npdrop
421: ; and do it if so.
422: ;
423: (defmacro em-checknpdrop nil
424: `(if g-dropnpcnt
425: then (let ((dr g-dropnpcnt))
426: (setq g-dropnpcnt nil)
427: (e-sub `($ ,(* dr 4)) '#.np-reg))))
428:
429: ;--- em-checkskip :: check if we are skipping this code due to jump
430: ;
431: (defmacro em-checkskip nil
432: '(if g-skipcode then (sfilewrite #.comment-char)))
433:
434:
435: ;--- e-jump :: jump to given label
436: ; and set g-skipcode so that all code following until the next label
437: ; will be skipped.
438: ;
439: (defun e-jump (l)
440: (em-checknpdrop)
441: (e-write2 #+for-vax 'jbr #+for-68k 'jra l)
442: (setq g-skipcode t))
443:
444: ;--- e-return :: do return, and dont check for np drop
445: ;
446: (defun e-return nil
447: (setq g-dropnpcnt nil) ; we dont need to worry about nps
448: #+for-vax (e-write1 'ret)
449: #+for-68k (progn (e-write1 'rts)
450: (sfilewrite
451: (concat g-masklab " = " (d-makemask) '#.ch-newline))
452: (sfilewrite
453: (concat g-stackspace " = "
454: (Cstackspace) '#.ch-newline))))
455:
456: ;--- e-writel :: write out a label
457: ;
458: (defun e-writel (label)
459: (setq g-skipcode nil)
460: (em-checknpdrop)
461: (sfilewrite label)
462: (sfilewrite ":")
463: (e-docomment))
464:
465: ;--- e-write1 :: write out one litteral
466: ;
467: (defun e-write1 (lit)
468: (em-checkskip)
469: (em-checknpdrop)
470: (sfilewrite " ")
471: (sfilewrite lit)
472: (e-docomment))
473:
474: ;--- e-write2 :: write one one litteral, and one operand
475: ;
476: #+for-vax
477: (defun e-write2 (lit frm)
478: (em-checkskip)
479: (em-checknpdrop)
480: (sfilewrite " ")
481: (sfilewrite lit)
482: (sfilewrite " ")
483: (e-cvtas frm)
484: (e-docomment))
485:
486: #+for-68k
487: (defun e-write2 (lit frm)
488: (em-checkskip)
489: (em-checknpdrop)
490: (if (and (dtpr frm) (eq (car frm) '*))
491: then (e-move (cdr frm) 'a5)
492: (sfilewrite " ")
493: (sfilewrite lit)
494: (sfilewrite '" ")
495: (e-cvtas '(0 a5))
496: else (sfilewrite " ")
497: (sfilewrite lit)
498: (sfilewrite '" ")
499: (e-cvtas frm))
500: (e-docomment))
501:
502: ;--- e-write3 :: write one one litteral, and two operands
503: ;
504: #+for-vax
505: (defun e-write3 (lit frm1 frm2)
506: (em-checkskip)
507: (em-checknpdrop)
508: (sfilewrite " ")
509: (sfilewrite lit)
510: (sfilewrite " ")
511: (e-cvtas frm1)
512: (sfilewrite ",")
513: (e-cvtas frm2)
514: (e-docomment))
515:
516: #+for-68k
517: (defun e-write3 (lit frm1 frm2)
518: (em-checkskip)
519: (em-checknpdrop)
520: (if (and (dtpr frm1) (eq (car frm1) '*)
521: (not (and (dtpr frm2) (eq (car frm2) '*))))
522: then (e-move (cdr frm1) 'a5)
523: (sfilewrite " ")
524: (sfilewrite lit)
525: (sfilewrite '" ")
526: (e-cvtas '(0 a5))
527: (sfilewrite '",")
528: (e-cvtas frm2)
529: (e-docomment)
530: elseif (and (not (and (dtpr frm1) (eq (car frm1) '*)))
531: (dtpr frm2) (eq (car frm2) '*))
532: then (e-move (cdr frm2) 'a5)
533: (sfilewrite " ")
534: (sfilewrite lit)
535: (sfilewrite '" ")
536: (e-cvtas frm1)
537: (sfilewrite '",")
538: (e-cvtas '(0 a5))
539: (e-docomment)
540: elseif (and (dtpr frm1) (eq (car frm1) '*)
541: (dtpr frm2) (eq (car frm2) '*))
542: then (d-regused 'd6)
543: (e-move (cdr frm1) 'a5)
544: (e-move '(0 a5) 'd6)
545: (e-move (cdr frm2) 'a5)
546: (sfilewrite " ")
547: (sfilewrite lit)
548: (sfilewrite '" ")
549: (e-cvtas 'd6)
550: (sfilewrite '",")
551: (e-cvtas '(0 a5))
552: (e-docomment)
553: else (sfilewrite " ")
554: (sfilewrite lit)
555: (sfilewrite '" ")
556: (e-cvtas frm1)
557: (sfilewrite '",")
558: (e-cvtas frm2)
559: (e-docomment)))
560:
561: ;--- e-write4 :: write one one litteral, and three operands
562: ;
563: #+for-vax
564: (defun e-write4 (lit frm1 frm2 frm3)
565: (em-checkskip)
566: (em-checknpdrop)
567: (sfilewrite " ")
568: (sfilewrite lit)
569: (sfilewrite " ")
570: (e-cvtas frm1)
571: (sfilewrite ",")
572: (e-cvtas frm2)
573: (sfilewrite ",")
574: (e-cvtas frm3)
575: (e-docomment))
576:
577:
578: ;--- e-write5 :: write one one litteral, and four operands
579: ;
580: #+for-vax
581: (defun e-write5 (lit frm1 frm2 frm3 frm4)
582: (em-checkskip)
583: (em-checknpdrop)
584: (sfilewrite " ")
585: (sfilewrite lit)
586: (sfilewrite " ")
587: (e-cvtas frm1)
588: (sfilewrite ",")
589: (e-cvtas frm2)
590: (sfilewrite ",")
591: (e-cvtas frm3)
592: (sfilewrite ",")
593: (e-cvtas frm4)
594: (e-docomment))
595:
596: ;--- d-printdocstuff
597: ;
598: ; describe this version
599: ;
600: (defun d-printdocstuff nil
601: (sfilewrite (concat ".data "
602: #.comment-char
603: " this is just for documentation "))
604: (terpr vp-sfile)
605: (sfilewrite (concat ".asciz \"@(#)Compiled by " compiler-name
606: " on " (status ctime) '\"))
607: (terpr vp-sfile)
608: (do ((xx Liszt-file-names (cdr xx)))
609: ((null xx))
610: (sfilewrite (concat ".asciz \"" (car xx) '\"))
611: (terpr vp-sfile)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.