![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to machacks.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib|
Return to machacks.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib |
1.1 root 1: ; this file will be loaded whenever the -m switch is set for compilation.
2: ; NOTE this file is loaded after the maclisp syntax has been set up!!
3: (sstatus dumpcore t)
4: (sstatus feature unix)
5: (setsyntax '/ 2)
6:
7: (def macsyma-env ; put at the beginning of each macsyma file
8: (macro (l) `(include |//usr//staff//jkf//mac//libmax//prelud.l|)))
9:
10: (def franzify
11: (macro (l) `(eval-when (compile eval)
12: (sstatus feature franz)
13: (sstatus feature unix)
14: (sstatus nofeature maclisp)
15: (sstatus nofeature its))))
16: (def error
17: (lexpr (a)
18: (terpr)
19: (patom '|Error: |)
20: (do ((ll a (sub1 ll)))
21: ((zerop ll)(terpr))
22: (patom (arg ll)))))
23:
24: (def fasload
25: (nlambda (argl)
26: (fasl (concat '|//usr//staff//jkf//mac//|
27: (cadddr argl) ; fourth arg
28: '|//|
29: (car argl) ; first arg
30: '|.|
31: (cadr argl))))) ; second arg
32:
33: (def coutput
34: (lambda (msg)
35: (print msg) ; should go to unfasl port
36: (terpr)))
37:
38: (opval 'pagelimit 5000.)
39:
40: (defmacro let (binding-forms &rest body)
41: `((lambda ,(mapcar '(lambda (x) (cond ((atom x) x) (t (car x))))
42: binding-forms)
43: ,@body)
44: ,@(mapcar '(lambda (x) (cond ((atom x) nil)
45: ((null (cdr x)) nil)
46: (t (cadr x))))
47: binding-forms)))
48:
49: (defmacro let* (binding-forms &rest body)
50: (construct-let* (reverse binding-forms) body))
51:
52: (defun construct-let* (binding-forms body)
53: (cond ((null binding-forms)
54: (cond ((= (length body) 1) (car body))
55: (t `(progn . ,body))))
56: (t (construct-let*
57: (cdr binding-forms)
58: (cond
59: ;;(let* (a b) x) --> ((lambda (a) ((lambda (b) x) nil)) nil)
60: ((atom (car binding-forms))
61: `(((lambda (,(car binding-forms)) . ,body) nil)))
62: ;;(let* (((a . b) v) x)) -->
63: ;; ((lambda (let*val)
64: ;; ((lambda (a) (setq let*val (cdr let*val))
65: ;; ((lambda (b) x)
66: ;; let*val))
67: ;; (car let*val)))
68: ;; v)
69: ((null (atom (caar binding-forms)))
70: `(((lambda (let*val) ,(constr-let*-hack (caar binding-forms)
71: body))
72: ,(cadar binding-forms))))
73:
74: ;;(let* ((a) (b)) x) --> ((lambda (a) ((lambda (b) x) nil)) nil)
75: ((null (cdar binding-forms))
76: `(((lambda (,(caar binding-forms)) . ,body) nil)))
77: ;;(let* ((a 3) (b 4)) x) --> ((lambda (a) ((lambda (b) x) 4)) 3)
78: (t `(((lambda (,(caar binding-forms)) . ,body)
79: ,(cadar binding-forms)))))))))
80:
81: (defun constr-let*-hack (lst body)
82: (cond ((atom lst) `((lambda (,lst) ,@body) let*val))
83: ((null (cdr lst))
84: `((lambda (,(car lst)) ,@body) (car let*val)))
85: (t `((lambda (,(car lst)) (setq let*val (cdr let*val))
86: ,(constr-let*-hack (cdr lst)
87: body))
88: (car let*val)))))
89:
90: (defmacro list* (&rest forms)
91: (cond ((null forms) nil)
92: ((null (cdr forms)) (car forms))
93: (t (construct-list* forms))))
94:
95: (defun construct-list* (forms)
96: (setq forms (reverse forms))
97: (do ((forms (cddr forms) (cdr forms))
98: (return-form `(cons ,(cadr forms) ,(car forms))
99: `(cons ,(car forms) ,return-form)))
100: ((null forms) return-form)))
101:
102: (defun displace (old-form new-form)
103: (cond ((atom old-form)
104: (error '|Not able to displace this form| old-form))
105: ((atom new-form)
106: (rplaca old-form 'progn)
107: (rplacd old-form (list new-form)))
108: (t (rplaca old-form (car new-form))
109: (rplacd old-form (cdr new-form)))))
110:
111: (def caseq
112: (macro (form)
113: ((lambda (x)
114: `((lambda (,x)
115: (cond
116: ,@(mapcar '(lambda (ff)
117: (cond ((eq (car ff) 't)
118: `(t ,(cadr ff)))
119: (t `((eq ,x ',(car ff))
120: ,(cadr ff)))))
121: (cddr form))))
122: ,(cadr form)))
123: (gensym 'Z))))
124:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.