![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to complra.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / liszt|
Return to complra.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / liszt |
1.1 root 1: ;--- file: complra.l
2: (include "compmacs.l")
3:
4: (def put
5: (macro (x)
6: ((lambda (atm prp arg)
7: `(progn (putprop ,atm ,arg ,prp) ,atm))
8: (cadr x) (caddr x) (cadddr x))))
9:
10:
11:
12: ; register allocation and important addresses for compiled code
13: ;
14: (setq np-reg 'r6 ;points one beyond top stack value
15: lbot-reg 'r7 ;current value of lbot
16: ln-reg 'r8 ;address of linker
17: olbot-reg 'r10 ;base of args to this fcn
18: bnp-reg 'r11 ;bind np
19: bnp-val '"*-32(r8)" ;value of global var bnp
20: i-mov 'movl ;stacking instruction for namestack
21: i-clr 'clrl ;clear namestack
22: qfuncl '"*-28(r8)" ;addr of qfuncl
23: )
24:
25: ; these are the short cut places to call when you want to call
26: ; a non system function with 4 or less arguments
27:
28: (setplist 'qfs '(0 "*-8(r8)" 1 "*-12(r8)" 2 "*-16(r8)"
29: 3 "*-20(r8)" 4 "*-24(r8)"))
30:
31: (setq faslflag nil)
32:
33: (declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt))
34:
35:
36:
37:
38: (cond ((lessp (opval 'pagelimit) 2000) (opval 'pagelimit 2000)))
39:
40:
41:
42: (def Gensym (lambda (x)
43: (prog (e)
44: (setq e (gensym (cond (x) (t 'L))))
45: (setq twa-list (cons e twa-list))
46: (return e))))
47:
48: (def cvt (lambda (a)
49: (prog (l)
50: (setq l (quotient a 2704))
51: (setq a (difference a (times l 2704)))
52: (setq l (list l (quotient a 52) (mod a 52)))
53: (return (mapcar '(lambda (x) (nthelem
54: (add1 x)
55: '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
56: a b c d e f g h i j k l m n o p q r s t u v w x y z))) l)))))
57:
58: (def nth
59: (lambda (x n)
60: (cond ((equal n 0) x)
61: ((lessp n 0)
62: (prog (m lst)
63: (setq m (difference 0 n))
64: (setq x (reverse x))
65: lp (cond ((zerop m) (return lst)))
66: (setq lst (cons (car x) lst))
67: (setq x (cdr x))
68: (setq m (sub1 m))
69: (go lp)))
70: (t (nth (cdr x) (sub1 n))))))
71:
72: (def cleanup (lambda nil
73: (mapc 'rematom twa-list)
74: (setq twa-list nil)))
75:
76: (def mylogor (lambda (x y)
77: (boole 7 x y)))
78:
79: (def leftshift
80: (lambda (x cnt)
81: (prog ()
82: loop (cond ((zerop cnt) (return x))
83: ((lessp cnt 0)
84: (setq x (quotient x 2))
85: (setq cnt (add1 cnt)))
86: (t (setq x (times x 2)) (setq cnt (sub1 cnt))))
87: (go loop))))
88:
89: (def flag
90: (lambda (atm flg)
91: (cond ((put atm flg t) atm))))
92:
93: (def ifflag
94: (lambda (atm flg)
95: (cond ((and (and (atom atm) (not (numberp atm)))
96: (get atm flg))
97: t))))
98:
99: (def unflag
100: (lambda (atm flg)
101: (put atm flg nil)))
102:
103:
104:
105: ;--- chain - a : an atom
106: ; returns a if a has the form cxr where x is an elt of {a d}
107: ; else returns nil.
108: ;
109: (def chain
110: (lambda (a)
111: (prog (expl)
112: (cond ((lessp (flatsize a) 3) (return nil)))
113: (setq expl (explode a))
114: (cond ((not (eq (car expl) 'c)) (return nil)))
115: loop (setq expl (cdr expl))
116: (cond ((eq (car expl) 'a) (go loop))
117: ((eq (car expl) 'd) (go loop))
118: ((and (eq (car expl) 'r) (null (cdr expl))) (return a))
119: (t (return nil))))))
120:
121: ;--- ismacro - a : atom name found in the functional position
122: ; returns the body of the macro if a is the name of a macro, else
123: ; return nil.
124: ;
125: (def ismacro
126: (lambda (a)
127: (prog (x)
128: (cond ((not (symbolp a)) (return nil))
129: ((setq x (assoc a k-macros)) (return (cadr x))))
130: (setq x (getd a))
131: (cond ((and (bcdp x) (eq (getdisc x) 'macro)) (return x))
132: ((and (dtpr x) (eq (car x) 'macro)) (return x))))))
133:
134: ;--- isnlam - a : atom found in the functional position
135: ; return the body of the nlambda if a names an nlambda,
136: ; else return nil
137: ;
138: (def isnlam
139: (lambda (a)
140: (prog (x)
141: (cond ((not (symbolp a)) (return nil)))
142: (cond ((setq x (assoc a k-nlams)) (return (cadr x))))
143: (setq x (getd a))
144: (cond ((and (dtpr x) (eq (car x) 'nlambda)) (return x))
145: ((and (bcdp x) (eq (getdisc x) 'nlambda)) (return x))))))
146:
147: (def ucar
148: (lambda (arg)
149: (cond ((dtpr arg) (car arg))
150: ((numberp arg) arg)
151: ((getd arg) arg)
152: (t (get arg '*car)))))
153:
154: ;--- defsysf - funname : lisp function name
155: ; - inname : internal system name
156: ; We declare that funname is a system type function with
157: ; the address of the c-code for it at inname. Thus we
158: ; can call this function directly without going through
159: ; the oblist. This type of optimization can be turned off
160: ; by disabling this routine (if debuggin is desired)
161: ;
162: (def defsysf
163: (lambda (funname inname)
164: (putprop funname inname 'x-sysf))) ; indicate of prop list
165:
166: (def $pr$
167: (macro (x)
168: (list 'patom (cadr x) 'vp-sfile)))
169:
170: (def emit1
171: (lambda (a)
172: (aprint a)
173: ($terpri)))
174:
175: (def emit2
176: (lambda (a b)
177: (aprint a)
178: ($pr$ '" ")
179: (aprint b)
180: ($terpri)))
181:
182: (def emit3
183: (lambda (a b c)
184: (aprint a)
185: ($pr$ '" ")
186: (aprint b)
187: ($pr$ '\,)
188: (aprint c)
189: ($terpri)))
190:
191: (def emit4
192: (lambda (a b c d)
193: (aprint a)
194: ($pr$ '" ")
195: (aprint b)
196: ($pr$ '\,)
197: (aprint c)
198: ($pr$ '\,)
199: (aprint d)
200: ($terpri)))
201:
202: (def aprint
203: (lambda (foo)
204: (prog nil
205: loop (cond ((null foo) (return))
206: ((atom foo) ($pr$ foo) (return))
207: (t ($pr$ (car foo))
208: (setq foo (cdr foo))))
209: (go loop))))
210:
211: (def $terpri (lambda () (terpr vp-sfile)))
212:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.