Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/boot.init
There are no other files named boot.init in the archive.
(DEFUN CAAR (A) (CAR (CAR A)))
(DEFUN CADR (A) (CAR (CDR A)))
(DEFUN CDAR (A) (CDR (CAR A)))
(DEFUN CDDR (A) (CDR (CDR A)))
(DEFUN CAAAR (A) (CAR (CAR (CAR A))))
(DEFUN CAADR (A) (CAR (CAR (CDR A))))
(DEFUN CADAR (A) (CAR (CDR (CAR A))))
(DEFUN CADDR (A) (CAR (CDR (CDR A))))
(DEFUN CDAAR (A) (CDR (CAR (CAR A))))
(DEFUN CDADR (A) (CDR (CAR (CDR A))))
(DEFUN CDDAR (A) (CDR (CDR (CAR A))))
(DEFUN CDDDR (A) (CDR (CDR (CDR A))))
(DEFUN CAAAAR (A) (CAR (CAR (CAR (CAR A)))))
(DEFUN CAAADR (A) (CAR (CAR (CAR (CDR A)))))
(DEFUN CAADAR (A) (CAR (CAR (CDR (CAR A)))))
(DEFUN CAADDR (A) (CAR (CAR (CDR (CDR A)))))
(DEFUN CADAAR (A) (CAR (CDR (CAR (CAR A)))))
(DEFUN CADADR (A) (CAR (CDR (CAR (CDR A)))))
(DEFUN CADDAR (A) (CAR (CDR (CDR (CAR A)))))
(DEFUN CADDDR (A) (CAR (CDR (CDR (CDR A)))))
(DEFUN CDAAAR (A) (CDR (CAR (CAR (CAR A)))))
(DEFUN CDAADR (A) (CDR (CAR (CAR (CDR A)))))
(DEFUN CDADAR (A) (CDR (CAR (CDR (CAR A)))))
(DEFUN CDADDR (A) (CDR (CAR (CDR (CDR A)))))
(DEFUN CDDAAR (A) (CDR (CDR (CAR (CAR A)))))
(DEFUN CDDADR (A) (CDR (CDR (CAR (CDR A)))))
(DEFUN CDDDAR (A) (CDR (CDR (CDR (CAR A)))))
(DEFUN CDDDDR (A) (CDR (CDR (CDR (CDR A)))))
(defun in-package (name) nil)
(setq boot-exports nil)
(defun export (exp-list) (setq boot-exports (append exp-list boot-exports)))
(defun boot (&optional (filename "clisp.exe"))
(save filename "Common Lisp. (c) 1985, Charles L. Hedrick"))
(defun list (&rest l) l)
(defun list* (&rest l)
(cond ((null l) l)
((null (cdr l)) (car l))
(t (%list* l)
l)))
(defun %list* (l) (cond ((null (cddr l)) (rplacd l (cadr l)))
(t (%list* (cdr l)))))
(macro defvar (l)
(list 'progn
(list '%put (list 'quote (cadr l)) (list 'quote 'globally-special) t)
(list 'setq (cadr l) (caddr l))
(if (cadddr l)
(list '%put (list 'quote (cadr l))
(list 'quote '%var-documentation)
(cadddr l)))))
(defun nreverse (a) (%reverse a nil))
(defun %reverse (old new) (cond ((atom old) new)
(t (%reverse (cdr old)
(cons (car old) new)))))
(defun reverse (a) (%reverse a nil))
(macro push (l) (list 'setq (caddr l) (list 'cons (cadr l) (caddr l))))
(defun length (l) (cond ((atom l) 0)
(t (1+ (length (cdr l))))))
(defun memq (item l) (cond ((atom l) nil)
((eq item (car l)) l)
(t (memq item (cdr l)))))
(defun append (&rest l) (cond ((null l) nil)
(t (%append l))))
(defun %append (l) (cond ((null (cdr l))
(car l))
(t (%%append (car l) (%append (cdr l))))))
(defun %%append (new old) (cond ((atom new) old)
(t (cons (car new)
(%%append (cdr new) old)))))
(defun nconc (&rest l) (%nconc l))
(defun %nconc (l) (cond ((null l) nil)
((atom (car l)) (%nconc (cdr l)))
(t (%%nconc (car l) (%nconc (cdr l)))
(car l))))
(defun %%nconc (new old) (cond ((atom (cdr new)) (rplacd new old))
(t (%%nconc (cdr new) old))))
(defun load (file &optional (*package* *package*))
(do ((eof (cons nil nil))
(channel (%sp-open file :input :default :error 'string-char))
(item nil (read channel nil eof)))
((eq item eof)
(%sp-close channel 0)
(princ " ")
(prin1 file)
(terpri))
(eval item)))
(macro prog (l) (list 'block nil (list 'let (cadr l)
(cons 'tagbody (cddr l)))))
(macro unless (l)
(list 'cond (cons (list 'not (cadr l)) (cddr l))))
(%sp-set-definition 'char= (%sp-get-definition 'eq))
;;; I am willing to do almost anything to avoid adding something
;;; to the kernel. The following contains two implementations of #
;;; The first makes it a simple character quote. This is used
;;; because the final version of # has to have characters in it.
;;; So for the next few lines #x has the meaning that #\x will
;;; eventually have. Note also that #\ssssss will be treated as
;;; #\s, since I do not bother to do complete tests. Since this
;;; definition is for booting only, this does not seem to be
;;; a problem.
(defun %boot-char-quote (stream ignore)
(read-char stream t nil t))
(set-macro-character 35 (function %boot-char-quote))
(defvar %char-abbrevs '((newline . #
)(space . # )(rubout . #)
(page . #
) (tab . # )(backspace . #)
(linefee(return . #
) (form . #
)
(formfeed . #
)))
(defvar %char-abbrev-beginnings '(#n #N #s #S #r #R #p #P #t #T #b #B #l #L #f #F))
(defvar *read-base* 10)
(defun %sharp-handler (stream ignore)
(let ((char (read-char stream t nil t)) atom)
(cond ((char= char #\)
(setq char (read-char stream t nil t))
(cond ((memq char %char-abbrev-beginnings)
(unread-char char stream)
(setq atom (read stream t nil t))
(cond ((assq atom %char-abbrevs)
(cdr (assq atom %char-abbrevs)))
(t char)))
(t char)))
((char= char #')
(list 'function (read stream t nil t)))
((char= char #()
(unread-char char stream)
(list-to-vector* (read stream t nil t) 'vector))
((or (char= char #B) (char= char #b))
(let ((*read-base* 2)) (read stream t nil t)))
((or (char= char #O) (char= char #o))
(let ((*read-base* 8)) (read stream t nil t)))
((or (char= char #X) (char= char #x))
(let ((*read-base* 16)) (read stream t nil t)))
((char= char #,)
(eval (read stream t nil t)))
((char= char #.)
(eval (read stream t nil t)))
((char= char #|)
(do ((level 1)
(prev (read-char stream t nil t) char)
(char (read-char stream t nil t)
(read-char stream t nil t)))
(())
(cond ((and (char= prev #|) (char= char ##))
(setq level (1- level))
(cond ((zerop level) (return (values))))
(setq char (read-char stream t nil t)))
((and (char= prev ##) (char= char #|))
(setq char (read-char stream t nil t))
(setq level (1+ level))))))
(t (error "Unimplemented sharp abbreviation" char)))))
(set-macro-character 35 (function %sharp-handler))
;;; OK, # is now defined normally.
(defun proclaim (proclamation)
(if (and (listp proclamation) (eq (car proclamation) 'special))
(do ((vars (cdr proclamation) (cdr vars)))
((atom vars))
(and (symbolp (car vars))
(%put (car vars) 'globally-special t)))))
(defun %rplaca (x val) (rplaca x val) val)
(defun %rplacd (x val) (rplacd x val) val)
(defun %setnth (n list newval)
(declare (fixnum n))
(if (< n 0)
(error "~S is an illegal N for SETF of NTH." n)
(do ((count n (1- count)))
((zerop count) (rplaca list newval) newval)
(declare (fixnum count))
(if (atom (cdr list))
(error "~S is too large an index for SETF of NTH." n)
(setq list (cdr list))))))
(defun deposit-field (newbyte bytespec integer)
(dpb (ldb bytespec newbyte) bytespec integer))
(defun logior (a b) (boole 7 a b))
(defun logand (a b) (boole 1 a b))
(defun lognot (a) (boole 10 a 0))
(defun expt (x n) (let ((result 1))
(cond ((zerop n) 1)
((plusp n)
(dotimes (i n)
(setq result (* result x)))
result)
(t
(dotimes (i (- n))
(setq result (/ result x)))
result))))
(defun error-loop nil
(tagbody loop (princ "
!>") (print (eval (read))) (go loop)))
(defun error (&rest args) (print args) (error-loop))
(defun cerror (&rest args) (print args) (error-loop))
(defun cerror-body (&rest args) (print args) (error-loop))
(defvar ?
"You must type a valid Lisp form. Lisp EVAL's it and prints the result.
File names are Tops-20 file names in quotes.
'form - quotes the form, like (QUOTE form).
(DEFUN name (args) forms...) - define a function
(EDIT function) - edit function in EMACS
(LOAD filename) - load a file of your functions.
(STEP form) - single step
(TRACE function) - step up tracing
(UNTRACE function) - remove tracing
(DESCRIBE 'thing) - print information about function, var, etc.
(APROPOS string) - find all symbols whose name contains string
")
(defun help nil ?)
(load "backq.clisp")
(backq-init)
(load "defmacro.clisp")
(load "macromemo.clisp")
(load "macros.clisp")
(load "list.clisp")
(load "dec20init.clisp")
(load "char.clisp")
(load "array.clisp")
(load "keyword.clisp")
(defun length (l) (cond ((slisp-array-p l)
(header-ref l %array-fill-pointer-slot))
((arrayp l) (%sp-get-vector-length l))
(t (list-length l))))
(load "string.clisp")
;;files from here on are "current", i.e. FTP'ed just before being
;;put into the system
(load "pred.clisp")
(load "subtypep.clisp")
(subtypep-init)
(defmacro %sp-set-vector-subtype (v st) `(%sp-svset ,v -2 ,st))
(defmacro %sp-get-vector-subtype (v) `(%sp-svref ,v -2))
(load "defstruct.clisp")
(load "eval.clisp")
(load "seq.clisp")
(load "arith.clisp")
(load "symbol.clisp")
;until real I/O is defined, this is about all we can do
(defun format (chan control-string &rest args)
(do ((i 0 (1+ i))
(l (length control-string))
(c))
((= i l))
(setq c (aref control-string i))
(if (eq c #\~)
(progn
(setq i (1+ i))
(setq c (aref control-string i))
(if (eq c #\%) (terpri chan)))
(write-char c chan)))
(dolist (arg args) (princ " " chan) (prin1 arg chan)))
(defun write-string (string &optional (stream *standard-output*)
(start 0) (end (length (the vector string))))
"Outputs the String to the given Stream."
(princ (subseq string start end) stream))
(proclaim '(special *features*))
(defun featurep (x)
"If X is an atom, see if it is present in *FEATURES*. Also
handle arbitrary combinations of atoms using NOT, AND, OR."
(cond ((atom x) (memq x *features*))
((eq (car x) 'not) (not (featurep (cadr x))))
((eq (car x) 'and)
(every #'featurep (cdr x)))
((eq (car x) 'or)
(some #'featurep (cdr x)))
(t nil)))
(defun open (filename &key (direction :input) (element-type 'string-char)
(if-exists :new-version)
(if-does-not-exist
(cond ((eq direction :probe) nil)
((or (eq direction :input)
(memq if-exists
'(:overwrite :append)))
:error)
(t :create))))
(%sp-open filename direction (if (memq direction '(:input :probe))
:default
if-exists)
if-does-not-exist element-type))
(defun close (stream &key abort)
(%sp-close stream (if abort #o4000 0)))
(defvar *standard-input* (make-synonym-stream '*terminal-io*)
"Default input stream.")
(defvar *standard-output* (make-synonym-stream '*terminal-io*)
"Default output stream.")
(defvar *error-output* (make-synonym-stream '*terminal-io*)
"Error output stream.")
(defvar *query-io* (make-synonym-stream '*terminal-io*)
"Query I/O stream.")
(defvar *debug-io* (make-synonym-stream '*terminal-io*)
"Interactive debugging stream.")
(defvar *trace-output* (make-synonym-stream '*terminal-io*)
"Trace output stream.")
(load "reader.clisp")
(load "query.clisp")
(load "rand.clisp")
(random-init)
(load "print.clisp")
(load "sort.clisp")
(load "format.clisp")
(format-init)
(load "hash.clisp")
(load "filesys.clisp")
(load "load.clisp")
(load "misc.clisp" :verbose t)
(load "pprint.clisp" :verbose t)
(pprint-init)
(load "stream.clisp" :verbose t)
;load sharpm fairly late, as it is likely to be slower than our
; simple one
(load "sharpm.clisp" :verbose t)
(sharp-init)
(load "spirrat.clisp" :verbose t)
(load "trace.clisp" :verbose t)
(load "step.clisp" :verbose t)
(load "package.clisp" :verbose t)
(export lisp::boot-exports) ;handle exports done before real EXPORT defined
(setq lisp::boot-exports nil) ;don't need this anymore...so get rid of it
(load "errorm.clisp" :verbose t)
(load "error.clisp" :verbose t)
(error-init)
(load "provide.clisp" :verbose t)
(load "kernel.clisp" :verbose t)
(package-init) ;after this we are in the user package
;; make the editor functions external to the system package.
(import '(lisp::editor-buffer-size lisp::editor-call-fork
lisp::editor-clear-buffer lisp::editor-clip-buffer
lisp::editor-create-fork lisp::editor-get-fork
lisp::editor-kill-fork lisp::editor-modified-p
lisp::editor-read-channel lisp::editor-run-fork
lisp::editor-set-jcl lisp::editor-set-modified
lisp::editor-write-channel)
(find-package "SYSTEM"))
(export '(sys::editor-buffer-size sys::editor-call-fork
sys::editor-clear-buffer sys::editor-clip-buffer
sys::editor-create-fork sys::editor-get-fork
sys::editor-kill-fork sys::editor-modified-p
sys::editor-read-channel sys::editor-run-fork
sys::editor-set-jcl sys::editor-set-modified
sys::editor-write-channel)
(find-package "SYSTEM"))