projects / unix-history / blob
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
BSD 4_1_snap release
[unix-history] / usr / src / cmd / lisp / lib / cmulisp / cmu2.l
; LWE 1/18/81 Hack hack hack.
(declare (special $cur$ dc-switch piport %indent dc-switch
vars body form var init label part incr limit
getdeftable $outport$ tlmacros f tmp))
(declare (nlambda msg))
(dv cmu2fns
((declare
(special %changes
def-comment
filelst
found
getdefchan
getdefprops
history
historylength
args
i
l
lasthelp
prop
special
special
tlbuffer
z))
%indent
*digits
*letters
changes
changes1
dc
dc-define
dc-dskin
dc-help
dskin
dskout
dskouts
evl-trace
file
get-comment
getdef
getdefact
getdefprops
getdeftable
help
helpfilter
historylength
matchq
matchq1
pp-comment
showevents
tleval
tlgetevent
tlmacros
tlprint
tlquote
tlread
top-level
transprint
valueof
zap
dc-switch))
(declare
(special %changes
def-comment
filelst
found
getdefchan
getdefprops
history
historylength
args
i
l
lasthelp
prop
special
special
tlbuffer
z))
(dv dc-switch dc-define)
(dv %indent 0)
(dv *digits ("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
(dv *letters (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))
(def changes
(lambda nil
(changes1)
(for-each f
filelst
(cond
((get f 'changes)
(terpri)
(princ f)
(tab 15)
(princ (get f 'changes)))))
(cond
(%changes (terpri) (princ '<no-file>) (tab 15) (princ %changes)))
nil))
(def changes1
(lambda nil
(cond ((null %changes) nil)
(t
(prog (found prop)
(for-each f
filelst
(setq found
(cons (set-of fn
(cons (concat f 'fns)
(eval
(concat f
'fns)))
(memq fn %changes))
found))
(setq prop (get f 'changes))
(for-each fn
(car found)
(setq prop (insert fn prop nil t)))
(putprop f prop 'changes))
(setq found (apply 'append found))
(setq %changes (set-of fn %changes (not (memq fn found)))))))))
(def dc
(nlambda (args)
(eval (cons dc-switch args]
(def dc-define
(nlambda (args)
(msg "Enter comment followed by <esc>" (N 1))
(drain piport)
(eval (cons 'dc-dskin args]
(def dc-help
(nlambda (args)
(cond
((eval (cons 'helpfilter (cons (car args) (caddr args))))
(transprint getdefchan)))))
(def dskin
(nlambda (files)
(mapc (function
(lambda (f)
(prog nil
(setq dc-switch 'dc-dskin)
(file f)
(load f)
(changes1)
(putprop f nil 'changes)
(setq dc-switch 'dc-define)
)))
files]
(***
The new version of dskout (7/26/80) tries to keep backup versions It returns
the setof its arguments that were successfully written If it can not write
a file (typically because of protection restrictions) it offers to (try to)
write a copy to /tmp A file written to /tmp is not considered to have been
successfully written (and changes will not consider it to be up-to-date) )
(def dskout
(nlambda (files)
(changes1)
(set-of f
files
(prog (ffns p tmp)
(cond ((atom (errset (setq p (infile f)) nil))
(msg "creating " (eval 'f) (N 1)))
(t (close p)
(cond ((zerop
(eval
(list 'exec
'mv
f
(setq tmp
(concat f '|.back|)))))
(msg "old version moved to "
(eval 'tmp) (N 1)))
(t (msg
"Unable to back up "
(eval 'f)
" - continue? (y/n) ")
(cond ((not (ttyesno)) (return nil)))))))
(cond
((atom
(errset (apply (function pp)
(cons (list 'F f)
(cons (setq ffns
(concat f
'fns))
(eval ffns))))
nil))
(msg
"Unable to write "
(eval 'f)
" - try to put it on /tmp? (y/n) ")
(cond
((ttyesno)
(setq f (explode f))
(while (memq '/ f)
(setq f (cdr (memq '/ f))))
(setq f
(apply (function concat)
(cons '/tmp/ f)))
(cond ((atom
(errset
(apply (function pp)
(cons (list 'F f)
(cons ffns (eval ffns))))))
(msg
"Unable to create "
(eval 'f)
" - I give up! " (N 1) ))
(t (msg (eval 'f) " written " (N 1) )))))
(return nil)))
(putprop f nil 'changes)
(return t)))))
(def dskouts
(lambda nil
(changes1)
(apply (function dskout) (set-of f filelst (get f 'changes)))))
(def evl-trace
(nlambda (exp)
(prog (val)
(tab %indent)
(prinlev (car exp) 2)
((lambda (%indent) (setq val (eval (car exp)))) (+ 2 %indent))
(tab %indent)
(prinlev val 2)
(return val))))
(def file
(lambda (name)
(setq filelst (insert name filelst nil t))
(cond
((not (boundp (concat name 'fns)))
(set (concat name 'fns) nil)))
name))
(def getdef
(nlambda (%%l)
(prog (x u getdefchan found)
(setq getdefchan (infile (car %%l)))
l (cond ((atom
(setq u
(errset
(prog (x y z)
(cond
((eq (tyipeek getdefchan) -1)
(err 'EOF)))
(cond
((memq (tyipeek getdefchan)
'(12 13))
(tyi getdefchan)))
(return
(cond
((memq (tyipeek getdefchan)
'(40 91))
(tyi getdefchan)
(cond
((and (symbolp
(setq y (ratom getdefchan)))
(cond (t (comment - what about
intern?)
(setq x y)
t)
((neq y
(setq x
(intern y)))
t)
(t (remob1 x) nil))
(assoc x getdeftable)
(or (setq z (ratom getdefchan))
t)
(some (cdr %%l)
(function
(lambda (x)
(matchq x z)))
nil)
(cond ((symbolp z)
(setq y z)
t)
(t (setq y z) t))
(cond ((memq y found))
((setq found
(cons y found))))
(not
(cond
((memq (tyipeek
getdefchan)
'(40 91))
(print x)
(terpri)
(princ y)
(tyo 32)
(princ
'" -- bad format")
t))))
(cons x
(cons y
(cond ((memq (tyipeek
getdefchan)
'(41
93))
(tyi
getdefchan)
nil)
(t (untyi 40
getdefchan)
(read
getdefchan))))))))))))))
(close getdefchan)
(return found))
(t (setq x (car u))
(*** free u)
(setq u nil)
(cond
((not (atom x))
(apply (cdr (assoc (car x) getdeftable)) (ncons x))))))
(cond ((not (eq (tyi getdefchan) 10)) (zap getdefchan)))
(go l))))
(def getdefact
(lambda (i p exp)
(prog nil
(cond ((or (null getdefprops) (memq p getdefprops))
(terpri)
(print (eval exp))
(princ '" ")
(prin1 p))
(t (terpri)
(print i)
(princ '" ")
(prin1 p)
(princ '" ")
(princ 'bypassed))))))
(dv getdefprops (function value expr fexpr macro))
(dv getdeftable
((defprop lambda (x) (getdefact (cadr x) (cadddr x) x))
(dc lambda
(x)
(cond
((or (null getdefprops) (memq 'comment getdefprops))
(eval x))))
(de lambda (x) (getdefact (cadr x) 'expr x))
(df lambda (x) (getdefact (cadr x) 'fexpr x))
(dm lambda (x) (getdefact (cadr x) 'macro x))
(setq lambda (x) (getdefact (cadr x) 'value x))
(dv lambda (x) (getdefact (cadr x) 'value x))
(def lambda (x) (getdefact (cadr x) 'function x))))
; LWE 1/11/81 I am flushing this in favor of a help system everybody
; can use -- the manual printer. From now on, additions to the system
; everybody uses should be made at a sufficiently sedate pace that they
; can be documented by additions to the manual. This is necessary for
; a system to be used by large numbers of people.
;
; (def help
; (nlambda (l)
; ((lambda (getdefprops dc-switch)
; (prog (lets files)
; (cond ((null l) (setq l (ncons 'overview))))
; (setq lasthelp '(@ . 84))
; (setq lets
; (for-each mapcan
; name
; l
; (prog (x char)
; (setq x 1)
; loop (cond ((null
; (setq char
; (nthchar name x)))
; (return
; (cond ((eq '@
; (nthchar name
; (sub1
; x)))
; (cons nil
; *letters))
; (t (list nil)))))
; ((memq char *letters)
; (return (ncons char)))
; (t (setq x (add1 x))
; (go loop))))))
; (for-each i lets (setq files (insert i files nil t)))
; (for-each i
; files
; (prog (def-comment)
; (setq def-comment 'dc-help)
; (eval
; (quote! getdef
; !
; (concat '/usr/lisp/help/
; i)
; !!
; l))))))
; (ncons 'comment)
; 'dc-help)))
;
;(def helpfilter
; (nlambda (l)
; (cond
; ((not (boundp 'lasthelp)) (setq lasthelp (cons '@ 65))))
; (cond ((or (memq 'see l) (memq 'under l))
; (terpri)
; (princ
; (cond ((memq 'under l) '"for explanation of ")
; ((memq 'see l) '"for information related to ")))
; (princ (car l))
; (princ '" see")
; (cond
; ((neq (car l) (car lasthelp)) (setq lasthelp (cons (car l) 84))))
; t)
; ((memq 'obsolete l)
; (terpri)
; (princ (car l))
; (princ '" is obsolete. for replacement see ")
; (cond
; ((neq (car l) (car lasthelp)) (setq lasthelp (cons (car l) 84))))
; t)
; ((memq 'xref l)
; (prog (ans)
; (setq ans (apply (function append) (read getdefchan)))
; (cond ((null ans) (return nil)))
; (cond
; ((neq lasthelp (car l)) (print (car l)) (princ '": ")))
; (terpri)
; (princ '" pointed to by these other helps: ")
; (princ ans))
; (cond
; ((neq (car l) (car lasthelp)) (setq lasthelp (cons (car l) 84))))
; nil)
; ((and (eq (car l) (car lasthelp))
; (memq (cdr lasthelp) '(65 97)))
; (terpri)
; (princ '" - - - - - ")
; (princ l)
; (princ '" - - - - - ")
; t)
; ((and (eq (car l) (car lasthelp))
; (memq (cdr lasthelp) '(70 102)))
; nil)
; ((or (memq 'standard l)
; (memq 'top-level-command l)
; (memq 'break-command l)
; (memq 'edit-command l)
; (memq 'long l)
; (eq (car lasthelp) (car l)))
; (prog (char)
; (*** ddtin t)
; l: (*** talk)
; (drain piport)
; (terpri)
; (princ l)
; (princ '"display? (all, type, skip, flush) ")
; (cond
; ((dtpr (setq char (errset (tyi)))) (setq char (car char))))
; (cond
; ((not (memq char '(65 97 84 116 83 115 70 102)))
; (terpri)
; (princ
; '"type a to see the rest of the help for this word,
; t to see this message and decide again for the next one,
; s to skip this message and decide again for the next one or
; f to skip the rest of the messages for this word.")
; (go l:)))
; (*** ddtin nil)
; (setq lasthelp (cons (car l) char))
; (return (memq char '(65 97 84 116))))
; (memq (cdr lasthelp) '(65 97 84 116)))
; (t (terpri)
; (princ '" - - - - - ")
; (princ l)
; (princ '" - - - - - ")
; (setq lasthelp (cons (car l) 84))
; t))))
(dv historylength 25)
(def matchq
(lambda (x y)
(prog (xx yy)
(return
(cond
((and (atom x) (atom y))
(cond ((matchq1 (setq xx (explode x)) (setq yy (explode y)))
(*** freelist xx)
(*** freelist yy)
t)
(t (*** freelist xx) (*** freelist yy)))))))))
(def matchq1
(lambda (x y)
(prog nil
l1 (cond ((eq x y) (return t))
((or (equal y '(@)) (equal x '(@))) (return t))
((or (null x) (null y)) (return nil))
((eq (car x) (car y))
(setq x (cdr x))
(setq y (cdr y))
(go l1))
(t (return nil))))))
(def showevents
(lambda (evs)
(for-each ev
evs
(terpri)
(princ (car ev))
(princ '".")
(tlprint (cadr ev))
(cond ((cddr ev) (terpri) (tlprint (caddr ev)))))))
(def tleval
(lambda (exp)
(prog (val)
(setq val (eval exp))
(rplacd (cdar history) (ncons val))
(return val))))
(def tlgetevent
(lambda (x)
(cond ((null x) (car history))
((and (fixp x) (plusp x)) (assoc x history))
((and (fixp x) (minusp x)) (car (Cnth history (minus x)))))))
(dv tlmacros
((ed lambda
(x)
(prog (exp)
(cond ((setq exp (copy (cadr (tlgetevent (cadr x)))))
(edite exp nil nil)
(return (ncons exp)))
(t (princ '"No such event")))))
(redo lambda
(x)
(prog (exp)
(cond ((setq exp (tlgetevent (cadr x)))
(return (ncons (cadr exp))))
(t (princ '"No such event")))))
(?? lambda
(x)
(prog (e1 e2 rest)
(cond ((null (cdr x)) (showevents (reverse history)))
((null (setq e1 (tlgetevent (cadr x))))
(princ '"No such event as ")
(princ (cadr x)))
((null (cddr x)) (showevents (ncons e1)))
((null (setq e2 (tlgetevent (caddr x))))
(princ '"No such event as ")
(princ (caddr x)))
(t (setq e1 (memq e1 history))
(cond ((setq rest (memq e2 e1))
(showevents
(cons e2 (reverse (ldiff e1 rest)))))
(t
(showevents
(cons (car e1)
(reverse
(ldiff (memq e2 history) e1))))))))))))
(def tlprint
(lambda (x)
(prinlev x 4)))
(def tlquote
(lambda (x)
(prog (ans)
l (cond ((null x) (return (reverse ans)))
((eq (car x) '!)
(setq ans (cons (cadr x) ans))
(setq x (cddr x)))
(t (setq ans (cons (kwote (car x)) ans)) (setq x (cdr x))))
(go l))))
(def tlread
(lambda nil
(prog (cmd tmp)
top (cond ((not (boundp 'history)) (setq history nil)))
(cond
((null tlbuffer)
(terpri)
(princ (add1 (cond (history (caar history)) (t 0))))
(princ '".")
(cond
((null (setq tlbuffer (lineread)))
(princ 'Bye)
(terpri)
(exit)))))
(cond ((not (atom (setq cmd (car tlbuffer))))
(setq tlbuffer (cdr tlbuffer))
(go record))
((setq cmd (assoc cmd tlmacros))
(setq tmp tlbuffer)
(setq tlbuffer nil)
(setq cmd (apply (cdr cmd) (ncons tmp)))
(cond ((atom cmd) (go top))
(t (setq cmd (car cmd)) (go record))))
((and (null (cdr tlbuffer))
(or (numberp (car tlbuffer))
(stringp (car tlbuffer))
(hunkp (car tlbuffer))
(boundp (car tlbuffer))))
(setq cmd (car tlbuffer))
(setq tlbuffer nil)
(go record))
((or (and (dtpr (getd (car tlbuffer)))
(memq (car (getd (car tlbuffer)))
'(lexpr lambda)))
(and (bcdp (getd (car tlbuffer)))
(eq (getdisc (getd (car tlbuffer)))
'lambda)))
(setq cmd (cons (car tlbuffer) (tlquote (cdr tlbuffer))))
(setq tlbuffer nil)
(go record)))
(setq cmd tlbuffer)
(setq tlbuffer nil)
record
(setq history
(cons (list (add1 (cond (history (caar history)) (t 0))) cmd)
history))
(cond
((dtpr (cdr (setq tmp (Cnth history historylength))))
(rplacd tmp nil)))
(return cmd)))]
(def cmu-top-level
(lambda nil
(prog (tlbuffer)
l (tlprint (tleval (tlread)))
(go l)))]
; LWE 1/11/81 The following might make this sucker work after resets:
(setq user-top-level 'cmu-top-level)
(putd 'user-top-level (getd 'cmu-top-level))
(setq top-level 'cmu-top-level)
(putd 'top-level (getd 'cmu-top-level))
(def transprint
(lambda (prt)
(prog nil
l (cond ((memq (tyipeek prt) '(27 -1)) (return nil))
(t (tyo (tyi prt)) (go l))))))
(def valueof
(lambda (x)
(caddr (tlgetevent x))))
(def zap
(lambda (prt)
(prog nil
l (cond ((memq (tyi prt) '(10 -1)) (return nil)) (t (go l))))))
(dv dc-switch dc-define)
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.