;;;;;;;;;;;;;;;;;;;;;;;;;;;;; toplevel.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Franz and UCI Lisp top level functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 , The Regents of the University of California.
; Authors: Joseph Faletti and Michael Deering and John Foderaro.
;-------------------------------------------------------------------------
; Top level functions for PEARL Joe Faletti, December 1981
; Top level function for franz jkf, march 1980
; The following function contains the top-level read, eval, print
; loop. With the help of the usual error handling functions,
; pearl-break-err-handler and debug-err-handler, pearl-top-level provides
; a reasonable environment for working with PEARL.
; (setq pearl-title (concat " plus PEARL " (status ctime)))
; (setq pearl-title (concat " plus PEARL " (time-string)))
(de read-in-initprl-file ()
(setq break-level-count 0 ; do this in case break
debug-level-count 0) ; occurs during readin
(*catch '(break-catch top-level-catch)
(do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
; prevent warnings (from setdbsize in particular).
(\$ldprint nil \$ldprint)) ; prevent messages
(cond ((do ((name '(".init.prl" "init.prl") (cdr name)))
(cond ((do ((ext '(".o" ".l" "") (cdr ext))
(setq file (concat (car dirs)
(cond ((atom (errset (load file)))
"Error loading init.prl file ")
(de read-in-startprl-file ()
(setq break-level-count 0 ; do this in case break
debug-level-count 0) ; occurs during readin
(*catch '(break-catch top-level-catch)
(do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
(\$ldprint nil \$ldprint)) ; prevent messages
(cond ((do ((name '(".start.prl" "start.prl") (cdr name)))
(cond ((do ((ext '(".o" ".l" "") (cdr ext))
(setq file (concat (car dirs)
(cond ((atom (errset (load file)))
"Error loading start.prl file ")
; For the implementor who wishes to dump a PEARL.
(sstatus ignoreeof nil) ; to undo ~/.lisprc
(setq franz-not-virgin nil)
(aliasdef 'top-level 'pearl-top-level-init)
(gc) ; garbage collect before dumping lisp
(cond (name (eval (list 'dumplisp (car name))))
; For the user who wishes to dump a PEARL that starts with .init.prl.
(setq franz-not-virgin nil)
(aliasdef 'top-level 'pearl-top-level-init)
(gc) ; garbage collect before dumping lisp
(cond ((\=& n 1) (setq name (arg 1)))
((\=& n 2) (setq name (concat (arg 1) '|/| (arg 2))))
(eval (list 'dumplisp name))
; For the user who wishes to dump a PEARL that continues with the
; (INITFN 'PEARL-REP-LOOP)
(aliasdef 'top-level 'pearl-top-level)
(gc) ; garbage collect before dumping lisp
(cond ((\=& n 1) (setq name (arg 1)))
((\=& n 2) (setq name (concat (arg 1) '|/| (arg 2))))
(eval (list 'dumplisp name))
(and *printhistorynumber*
(patom (1+ *historynumber*)))
(setq *readlinechanged* nil)
(car (errset (eval (addhistory (read)))))))
(rplacx (\\ *historynumber* *historysize*)
( t (rplacx (\\ *historynumber* *historysize*)
(cond ((not (boundp '*db1size*))
(cond ((not (boundp '*db*))
(cond ((not (boundp '*pearlprompt*))
(setq *pearlprompt* '|pearl> |))
(setq *pearlprompt* '|-> |)))
(cond ((not (boundp '*historysize*))
(setq *historysize* 64.)))
(setq *historynumber* -1.)
(setq *history* (makhunk *historysize*))
(setq *histval* (makhunk *historysize*))
(cond ((not (boundp '*db1size*))
(cond ((not (boundp '*db*))
(de pearl-top-level-init ()
(aliasdef 'reset 'franz-reset)
(aliasdef 'top-level 'pearl-top-level)
(signal 2 'pearl:int-serv)
(*catch '(top-level-catch break-catch)
(cond ((or (not (boundp 'franz-not-virgin))
; This is changed because fixit is included now.
; (setq ER%tpl 'pearl-break-err-handler)
; The rest of the code should be within this
; cond if autorunlisp existed
; (cond ((not (autorunlisp))))
(cond ((boundp 'franz-minor-version-number)
(patom franz-minor-version-number)))
(cond (*firststartup* (setq *firststartup* nil)
(setq *pearlprompt* '|-> |))
(and (not (\=& 64 *historysize*))
(setq *history* (makhunk *historysize*))
(setq *histval* (makhunk *historysize*)))
(read-in-startprl-file))))
'(top-level-catch break-catch)
; begin or return to top level
(setq debug-level-count 0 break-level-count 0
evalhook nil funcallhook nil)
(cond (tpl-errlist (mapc 'eval tpl-errlist)))
(cond (user-top-level (funcall user-top-level))
(and *printhistorynumber*
(patom (1+ *historynumber*)))
(setq *readlinechanged* nil)
; read and add to history.
(cond ((not (status isatty))
(cond ((null (status ignoreeof))
; Eval and story result in history.
(rplacx (\\ *historynumber* *historysize*)
; update list of old forms
; update list of old values
; Don't print *invisible*.
(and (neq '*invisible* +*)
(patom "[Return to top level]")
(cond ((eq 'reset retval) (old-reset-function))))))))
; this is the break handler, it should be tied to
; it is entered if there is an error which no one wants to handle.
; We loop forever, printing out our error level until someone
; types a ^D which goes to the next break level above us (or the
; top-level if there are no break levels above us.)
; a (return n) will return that value to the error message
; which called us, if that is possible (that is if the error is
(def pearl-break-err-handler
(message break-level-count retval rettype ^w piport)
(mapc '(lambda (a) (patom " ") (patom a) )
(cond ((caddr (arg 1)) (setq rettype 'contuab))
( t (setq rettype nil))))
( t (setq rettype 'localcall)))
(patom break-level-count)
(setq form (read nil top-level-eof)))
(cond ((null (status isatty))
(eval 1) ; force interrupt check
(return (1- break-level-count)))
(cond ((or (eq rettype 'contuab)
(return (ncons (eval (cadr form)))))
"Can't continue from this error")
((and (dtpr form) (eq 'retbrk (car form)))
(cond ((numberp (setq form
( t (return (1- break-level-count)))))
( t (pearlbreakprintfn (eval form))
(return (cond ((eq rettype 'localcall)
((<& retval break-level-count)
(setq tpl-errlist errlist)
(*throw 'break-catch retval))
(aliasdef 'break-err-handler 'pearl-break-err-handler)