clcs cleanup, centralize lisp errors in gcl_serror, move restart to cltl1 - gcl.git - GNU Common Lisp

diff --git a/gcl/clcs/gcl_clcs_condition_definitions.lisp b/gcl/clcs/gcl_clcs_condition_definitions.lisp
index db0760b3b..83670165d 100755
--- a/gcl/clcs/gcl_clcs_condition_definitions.lisp
+++ b/gcl/clcs/gcl_clcs_condition_definitions.lisp

@@ -1,27 +1,12 @@

;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-(IN-PACKAGE "CONDITIONS")

+(IN-PACKAGE :CONDITIONS)

-(eval-when (compile load eval)

- (pushnew :clos-conditions *features*))

+(define-condition warning (condition) nil)

+(define-condition style-warning (warning) nil)

-(eval-when (compile load eval)

- (when (and (member :clos-conditions *features*)

- (member :defstruct-conditions *features*))

- (dolist (sym '(simple-condition-format-control simple-condition-format-arguments

- type-error-datum type-error-expected-type

- case-failure-name case-failure-possibilities

- stream-error-stream file-error-pathname package-error-package

- cell-error-name arithmetic-error-operation

- internal-error-function-name))

- (when (fboundp sym) (fmakunbound sym)))

- (setq *features* (remove :defstruct-conditions *features*))))

-

-(define-condition warning (condition) ())

-(define-condition style-warning (warning) ())

-

-(define-condition serious-condition (condition) ())

-(define-condition error (serious-condition) ())

+(define-condition serious-condition (condition) nil)

+(define-condition error (serious-condition) nil)

(define-condition simple-condition (condition)

((format-control :type string

@@ -37,84 +22,101 @@

(simple-condition-format-control c)

(simple-condition-format-arguments c)))))

-(define-condition simple-warning (simple-condition warning) ())

-(define-condition simple-error (simple-condition error) ())

+(define-condition simple-warning (simple-condition warning) nil)

+(define-condition simple-error (simple-condition error) nil)

-(define-condition storage-condition (serious-condition) ())

-(define-condition stack-overflow (storage-condition) ())

-(define-condition storage-exhausted (storage-condition) ())

+(define-condition storage-condition (serious-condition) nil)

+(define-condition stack-overflow (storage-condition) nil)

+(define-condition storage-exhausted (storage-condition) nil)

(define-condition type-error (error)

- ((datum :initarg :datum :reader type-error-datum)

- (expected-type :initarg :expected-type :reader type-error-expected-type))

- (:report ("~%~s is not of type ~s." datum expected-type)))

+ ((datum :initarg :datum

+ :reader type-error-datum)

+ (expected-type :initarg :expected-type

+ :reader type-error-expected-type))

+ (:report ("~s is not of type ~s: " datum expected-type)))

+(define-condition simple-type-error (simple-error type-error) nil)

-(define-condition simple-type-error (simple-condition type-error) ())

-

-(define-condition case-failure (type-error)

- ((name :initarg :name :reader case-failure-name)

- (possibilities :initarg :possibilities

- :reader case-failure-possibilities))

- (:report ("~%~s fell through ~s expression.~%wanted one of ~:s." datum name possibilities)))

-

-(define-condition PROGRAM-ERROR (ERROR) ())

-(define-condition control-error (error) ())

-(define-condition parse-error (error) ())

+(define-condition program-error (error) nil)

+(define-condition control-error (error) nil)

+(define-condition parse-error (error) nil)

(define-condition print-not-readable (error)

- ((object :initarg :object :reader print-not-readable-object))

- (:report ("~%Object ~s is unreadable: " object)))

+ ((object :initarg :object

+ :reader print-not-readable-object))

+ (:report ("Object ~s is unreadable: " object)))

(define-condition stream-error (error)

- ((stream :initarg :stream :reader stream-error-stream))

- (:report ("~%Stream error on stream ~s: " stream)))

+ ((stream :initarg :stream

+ :reader stream-error-stream))

+ (:report ("Stream error on stream ~s: " stream)))

-(define-condition reader-error (parse-error stream-error) ())

+(define-condition reader-error (parse-error stream-error) nil)

(define-condition end-of-file (stream-error)

- ()

- (:report ("~%Unexpected end of file:")))

+ nil

+ (:report ("Unexpected end of file: ")))

(define-condition file-error (error)

- ((pathname :initarg :pathname :reader file-error-pathname))

- (:report ("~%File error on ~s:" pathname)))

-(define-condition pathname-error (file-error) ())

+ ((pathname :initarg :pathname

+ :reader file-error-pathname))

+ (:report ("File error on ~s: " pathname)))

+

+(define-condition pathname-error (file-error) nil)

(define-condition package-error (error)

- ((package :initarg :package :reader package-error-package))

- (:report ("~%Package error on ~s: " package)))

+ ((package :initarg :package

+ :reader package-error-package))

+ (:report ("Package error on ~s: " package)))

-

(define-condition cell-error (error)

- ((name :initarg :name :reader cell-error-name))

- (:report ("~%Cell error on ~s: " name)))

+ ((name :initarg :name

+ :reader cell-error-name))

+ (:report ("Cell error on ~s: " name)))

(define-condition unbound-variable (cell-error)

- ()

- (:report ("~%Unbound variable.")))

-

-(define-condition unbound-slot (cell-error)

- ((instance :initarg :instance :reader unbound-slot-instance))

- (:report ("~%Slot is unbound in ~s: " instance)))

-

-(define-condition undefined-function (cell-error) nil

- (:report ("~%Undefined function.")))

+ nil

+ (:report ("Unbound variable: ")))

-(define-condition arithmetic-error (error)

- ((operation :initarg :operation :reader arithmetic-error-operation)

- (operands :initarg :operands :reader arithmetic-error-operands))

+(define-condition unbound-slot (cell-error)

+ ((instance :initarg :instance

+ :reader unbound-slot-instance))

+ (:report ("Slot is unbound in ~s: " instance)))

+

+(define-condition undefined-function (cell-error)

+ nil

+ (:report ("Undefined function: ")))

+

+(define-condition arithmetic-error (ERROR)

+ ((operation :initarg :operation

+ :reader arithmetic-error-operation)

+ (operands :initarg :operands

+ :reader arithmetic-error-operands))

(:report ("~%Arithmetic error when performing ~s on ~s: " operation operands)))

-(define-condition division-by-zero (arithmetic-error) ())

-(define-condition floating-point-overflow (arithmetic-error) ())

-(define-condition floating-point-invalid-operation (arithmetic-error) ())

-(define-condition floating-point-inexact (arithmetic-error) ())

-(define-condition floating-point-underflow (arithmetic-error) ())

+(define-condition division-by-zero (arithmetic-error) nil)

+(define-condition floating-point-overflow (arithmetic-error) nil)

+(define-condition floating-point-invalid-operation (arithmetic-error) nil)

+(define-condition floating-point-inexact (arithmetic-error) nil)

+(define-condition floating-point-underflow (arithmetic-error) nil)

+

+(define-condition case-failure (type-error)

+ ((name :initarg :name

+ :reader case-failure-name)

+ (possibilities :initarg :possibilities

+ :reader case-failure-possibilities))

+ (:report

+ (lambda (condition stream)

+ (format stream "~s fell through ~s expression.~%wanted one of ~:s."

+ (type-error-datum condition)

+ (case-failure-name condition)

+ (case-failure-possibilities condition)))))

-(define-condition abort-failure (control-error) () (:report "~%Abort failed."))

+(define-condition abort-failure (control-error) nil (:report "abort failed."))

(define-condition internal-condition (condition)

- ((function-name :initarg :function-name :reader internal-condition-function-name

+ ((function-name :initarg :function-name

+ :reader internal-condition-function-name

:initform nil))

(:report (lambda (condition stream)

(when (internal-condition-function-name condition)

@@ -122,56 +124,22 @@

(internal-condition-function-name condition)))

(call-next-method))))

-(define-condition internal-warning (internal-condition warning)

- ()

- (:report (lambda (condition stream)

- (when (internal-condition-function-name condition)

- (format stream "Warning in ~S [or a callee]: "

- (internal-condition-function-name condition)))

- (call-next-method))))

-

-(define-condition internal-error (internal-condition error)

- ()

- (:report (lambda (condition stream)

- (when (internal-condition-function-name condition)

- (format stream "Error in ~S [or a callee]: "

- (internal-condition-function-name condition)))

- (call-next-method))))

+(define-condition internal-simple-condition (internal-condition simple-condition) nil)

-(define-condition internal-simple-condition (internal-condition simple-condition) ())

-(define-condition internal-simple-error (internal-error simple-error) ())

-(define-condition internal-simple-warning (internal-warning simple-warning) ())

+(define-condition internal-simple-error (internal-condition simple-error) nil)

+(define-condition internal-simple-type-error (internal-condition simple-type-error) nil)

+(define-condition internal-simple-warning (internal-condition simple-warning) nil)

-(defun symcat (x y) (values (intern (concatenate 'string (string x) (string y)) 'conditions)))

-

-#.`(progn

+#.`(progn

,@(mapcar (lambda (x)

- `(define-condition ,(symcat "INTERNAL-SIMPLE-" x) (internal-simple-condition ,x) ()))

- `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning type-error

+ `(define-condition

+ ,(intern (concatenate 'string "INTERNAL-SIMPLE-" (string x)))

+ (internal-condition simple-condition ,x) nil))

+ `(stack-overflow storage-exhausted print-not-readable end-of-file style-warning

unbound-variable unbound-slot undefined-function division-by-zero

case-failure abort-failure

- ,@(mapcar (lambda (x) (symcat "FLOATING-POINT-" x))

+ ,@(mapcar (lambda (x) (intern (concatenate 'string "FLOATING-POINT-" (string x))))

'(overflow underflow invalid-operation inexact))

- ,@(mapcar (lambda (x) (symcat x "-ERROR"))

+ ,@(mapcar (lambda (x) (intern (concatenate 'string (string x) "-ERROR")))

'(program control parse stream reader file

package cell arithmetic pathname)))))

-

-

-

-(defvar *simple-condition-class* (find-class 'simple-condition))

-(defvar *internal-simple-condition-class* (find-class 'internal-simple-condition))

-

-(defun simple-condition-class-p (type)

- (let ((type (if (symbolp type) (find-class type nil) type)))

- (when (typep type 'standard-class)

- (member *simple-condition-class*

- (pcl::class-precedence-list type)))))

-

-(defun internal-simple-condition-class-p (type)

- (when (symbolp type)

- (setq type (find-class type)))

- (and (typep type 'standard-class)

- (member *internal-simple-condition-class*

- (pcl::class-precedence-list type))))

-

-

diff --git a/gcl/clcs/gcl_clcs_conditions.lisp b/gcl/clcs/gcl_clcs_conditions.lisp
index b3b144cf3..c4730604e 100755
--- a/gcl/clcs/gcl_clcs_conditions.lisp
+++ b/gcl/clcs/gcl_clcs_conditions.lisp

@@ -1,13 +1,8 @@

;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-(in-package "CONDITIONS" :USE '("LISP" "PCL"))

+;(in-package "CONDITIONS" :USE '(:cl #+(and clos (not pcl)) "CLOS" #+pcl "PCL"))

-(eval-when (compile load eval)

- (when (fboundp 'remove-clcs-symbols)

- (remove-clcs-symbols)))

-

-(eval-when (compile load eval)

- (defvar *condition-class-list* nil))

+(in-package :conditions)

(defun slot-sym (base slot)

(values (intern (concatenate 'string (string base) "-" (string slot)))))

@@ -23,21 +18,24 @@

(call-next-method)

(format s ,(car x) ,@(mapcar (lambda (st) `(if (slot-boundp c ',st) (,(slot-sym y st) c) 'unbound)) (cdr x)))))))

-(DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS)

+(defun default-report (x)

+ `(lambda (c s) (call-next-method) (format s "~s " ',x)))

+

+(defmacro define-condition (name parent-list slot-specs &rest options)

(unless (or parent-list (eq name 'condition))

(setq parent-list (list 'condition)))

- (let* ((REPORT-FUNCTION nil)

- (DEFAULT-INITARGS nil)

- (DOCUMENTATION nil))

- (DO ((O OPTIONS (CDR O)))

- ((NULL O))

- (LET ((OPTION (CAR O)))

- (CASE (CAR OPTION)

- (:REPORT (SETQ REPORT-FUNCTION (coerce-to-fn (cadr option) name)))

- (:DEFAULT-INITARGS (SETQ DEFAULT-INITARGS OPTION))

- (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION)))

- (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option."

- "Invalid DEFINE-CONDITION option: ~S" OPTION)))))

+ (let* ((report-function nil)

+ (default-initargs nil)

+ (documentation nil))

+ (do ((o options (cdr o)))

+ ((null o))

+ (let ((option (car o)))

+ (case (car option)

+ (:report (setq report-function (coerce-to-fn (cadr option) name)))

+ (:default-initargs (setq default-initargs option))

+ (:documentation (setq documentation (cadr option)))

+ (otherwise (cerror "ignore this define-condition option."

+ "invalid define-condition option: ~s" option)))))

`(progn

(eval-when (compile)

(setq pcl::*defclass-times* '(compile load eval)))

@@ -45,60 +43,43 @@

`(defclass ,name ,parent-list ,slot-specs ,default-initargs)

`(defclass ,name ,parent-list ,slot-specs))

(eval-when (compile load eval)

- (pushnew '(,name ,parent-list

- ,@(mapcan #'(lambda (slot-spec)

- (let* ((ia (getf (cdr slot-spec) ':initarg)))

- (when ia

- (list

- (cons ia

- (or (getf (cdr slot-spec) ':type)

- t))))))

- SLOT-SPECS))

- *condition-class-list*)

- (setf (get ',name 'si::s-data) nil)

; (setf (get ',name 'documentation) ',documentation)

- )

- ,@(when REPORT-FUNCTION

- `((DEFMETHOD PRINT-OBJECT ((X ,NAME) STREAM)

- (IF *PRINT-ESCAPE*

- (CALL-NEXT-METHOD)

- (,REPORT-FUNCTION X STREAM)))))

- ',NAME)))

+ (setf (get ',name 'si::s-data) nil))

+ ,@(when report-function

+ `((defmethod print-object ((x ,name) stream)

+ (if *print-escape*

+ (call-next-method)

+ (,report-function x stream)))))

+ ',name)))

(eval-when (compile load eval)

- (define-condition condition () ())

-

-(when (fboundp 'pcl::proclaim-incompatible-superclasses)

- (mapc

- 'pcl::proclaim-incompatible-superclasses

- '((condition pcl::metaobject)))))

+ (define-condition condition nil nil))

-(defun conditionp (object)

- (typep object 'condition))

+(defmethod pcl::make-load-form ((object condition) &optional env)

+ (declare (ignore env))

+ (error "~@<default ~s method for ~s called.~@>" 'pcl::make-load-form object))

-(DEFMETHOD PRINT-OBJECT ((X condition) STREAM)

- (IF *PRINT-ESCAPE*

- (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x))

- (FORMAT STREAM "~A: " (class-name (class-of x)))));(TYPE-OF x)

+(mapc 'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject)))

-(defvar *condition-class* (find-class 'condition))

+(defun conditionp (object) (typep object 'condition))

-(defun condition-class-p (TYPE)

- (when (symbolp TYPE)

- (setq TYPE (find-class TYPE)))

- (and (typep TYPE 'standard-class)

- (member *condition-class*

- (#+pcl pcl::class-precedence-list

- #-pcl clos::class-precedence-list

- type))))

+(defun is-condition (x) (conditionp x))

+(defun is-warning (x) (typep x 'warning))

-(DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS)

- (unless (condition-class-p TYPE)

- (ERROR 'SIMPLE-TYPE-ERROR

- :DATUM TYPE

- :EXPECTED-TYPE '(SATISFIES condition-class-p)

- :FORMAT-CONTROL "Not a condition type: ~S"

- :FORMAT-ARGUMENTS (LIST TYPE)))

- (apply #'make-instance TYPE SLOT-INITIALIZATIONS))

+(defmethod print-object ((x condition) stream)

+ (let ((y (class-name (class-of x))))

+ (if *print-escape*

+ (format stream "#<~s.~d>" y (unique-id x))

+ (format stream "~a: " y))));(type-of x)

+(defun make-condition (type &rest slot-initializations)

+ (when (and (consp type) (eq (car type) 'or))

+ (return-from make-condition (apply 'make-condition (cadr type) slot-initializations)));FIXME

+ (unless (condition-class-p type)

+ (error 'simple-type-error

+ :datum type

+ :expected-type '(satisfies condition-class-p)

+ :format-control "not a condition type: ~s"

+ :format-arguments (list type)))

+ (apply 'make-instance type slot-initializations))

diff --git a/gcl/clcs/gcl_clcs_debugger.lisp b/gcl/clcs/gcl_clcs_debugger.lisp
deleted file mode 100755
index 7706dd142..000000000
--- a/gcl/clcs/gcl_clcs_debugger.lisp
+++ /dev/null

@@ -1,143 +0,0 @@

-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-

-(in-package "CONDITIONS")

-

-(DEFVAR *DEBUG-LEVEL* 0)

-(DEFVAR *DEBUG-ABORT* NIL)

-(DEFVAR *DEBUG-CONTINUE* NIL)

-(DEFVAR *DEBUG-CONDITION* NIL)

-(DEFVAR *DEBUG-RESTARTS* NIL)

-(DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0)

-(DEFVAR *DEBUG-EVAL* 'EVAL)

-(DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES)))

-

-(DEFMACRO DEBUG-COMMAND (X) `(GET ,X 'DEBUG-COMMAND))

-(DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT))

-

-(DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY)

- `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY))

- (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL))

- ',NAME))

-

-(DEFUN READ-DEBUG-COMMAND ()

- (FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*)

- (COND ((CHAR= (PEEK-CHAR T) #\:)

- (READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number.

- (WITH-INPUT-FROM-STRING (STREAM (READ-LINE))

- (LET ((EOF (LIST NIL)))

- (DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD")))

- (READ STREAM NIL EOF))

- (READ STREAM NIL EOF))

- (L '() (CONS FORM L)))

- ((EQ FORM EOF) (NREVERSE L))))))

- (T

- (LIST :EVAL (READ)))))

-

-(DEFINE-DEBUG-COMMAND :EVAL (FORM)

- (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM))))

-

-(DEFINE-DEBUG-COMMAND :ABORT ()

- (IF *DEBUG-ABORT*

- (INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*)

- (FORMAT T "~&There is no way to abort.~%")))

-

-(DEFINE-DEBUG-COMMAND :CONTINUE ()

- (IF *DEBUG-CONTINUE*

- (INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*)

- (FORMAT T "~&There is no way to continue.~%")))

-

-(DEFINE-DEBUG-COMMAND :ERROR ()

- (FORMAT T "~&~A~%" *DEBUG-CONDITION*))

-

-(DEFINE-DEBUG-COMMAND :HELP ()

- (FORMAT T "~&You are in a portable debugger.~

- ~%Type a debugger command or a form to evaluate.~

- ~%Commands are:~%")

- (SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16)

- (FORMAT T "~& :EVAL form Evaluate a form.~

- ~% :HELP Show this text.~%")

- (IF *DEBUG-ABORT* (FORMAT T "~& :ABORT Exit by ABORT.~%"))

- (IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE Exit by CONTINUE.~%"))

- (FORMAT T "~& :ERROR Reprint error message.~%"))

-

-

-

-(defvar *debug-command-prefix* ":")

-

-(DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*)

- (MAX *NUMBER-OF-DEBUG-RESTARTS*)

- TARGET-COLUMN)

- (UNLESS MAX (SETQ MAX (LENGTH RESTARTS)))

- (WHEN RESTARTS

- (DO ((W (IF TARGET-COLUMN

- (- TARGET-COLUMN 3)

- (CEILING (LOG MAX 10))))

- (P RESTARTS (CDR P))

- (I 0 (1+ I)))

- ((OR (NOT P) (= I MAX)))

- (FORMAT T "~& ~A~A "

- *debug-command-prefix*

- (LET ((S (FORMAT NIL "~D" (+ I 1))))

- (WITH-OUTPUT-TO-STRING (STR)

- (FORMAT STR "~A" S)

- (DOTIMES (I (- W (LENGTH S)))

- (WRITE-CHAR #\Space STR)))))

- (IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) "))

- (IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) "))

- (FORMAT T "~A" (CAR P))

- (FORMAT T "~%"))))

-

-(defvar *DEBUGGER-HOOK* nil)

-(defvar *debugger-function* 'STANDARD-DEBUGGER)

-

-(DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS)

- (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG)))

- (WHEN *DEBUGGER-HOOK*

- (LET ((HOOK *DEBUGGER-HOOK*)

- (*DEBUGGER-HOOK* NIL))

- (FUNCALL HOOK CONDITION HOOK)))

- (funcall *debugger-function* CONDITION)))

-

-(DEFUN STANDARD-DEBUGGER (CONDITION)

- (LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))

- (*DEBUG-RESTARTS* (COMPUTE-RESTARTS))

- (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*))

- (*DEBUG-ABORT* (FIND-RESTART 'ABORT))

- (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE)))

- (IF (OR (NOT *DEBUG-CONTINUE*)

- (NOT (EQ *DEBUG-CONTINUE* C)))

- C NIL))

- (LET ((C (IF *DEBUG-RESTARTS*

- (FIRST *DEBUG-RESTARTS*) NIL)))

- (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL))))

- (*DEBUG-CONDITION* CONDITION))

- (FORMAT T "~&~A~%" CONDITION)

- (SHOW-RESTARTS)

- (DO ((COMMAND (READ-DEBUG-COMMAND)

- (READ-DEBUG-COMMAND)))

- (NIL)

- (EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*))))

-

-(DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL)

- (WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL)

- (COND ((NOT CMD))

- ((INTEGERP CMD)

- (COND ((AND (PLUSP CMD)

- (< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1)))

- (LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*)))

- (IF ARGS

- (APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS))

- (INVOKE-RESTART-INTERACTIVELY RESTART))))

- (T

- (FORMAT T "~&No such restart."))))

- (T

- (LET ((FN (DEBUG-COMMAND CMD)))

- (IF FN

- (COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)))

- (FORMAT T "~&Too ~:[few~;many~] arguments to ~A."

- (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))

- CMD))

- (T

- (APPLY FN ARGS)))

- (FORMAT T "~&~S is not a debugger command.~%" CMD)))))))

-

diff --git a/gcl/clcs/gcl_clcs_handler.lisp b/gcl/clcs/gcl_clcs_handler.lisp
index c585a03af..9a5513fc2 100755
--- a/gcl/clcs/gcl_clcs_handler.lisp
+++ b/gcl/clcs/gcl_clcs_handler.lisp

@@ -1,141 +1,39 @@

;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-(IN-PACKAGE "CONDITIONS")

-

-(DEFVAR *HANDLER-CLUSTERS* NIL)

-

-(DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS)

- (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS)

- (ERROR "Ill-formed handler bindings."))

- `(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X)))

- BINDINGS))

- *HANDLER-CLUSTERS*)))

- ,@FORMS))

-

-(DEFVAR *BREAK-ON-SIGNALS* NIL)

-

-(DEFUN SIGNAL (DATUM &REST ARGUMENTS)

- (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL))

- (*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*))

- (IF (TYPEP CONDITION *BREAK-ON-SIGNALS*)

- (BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*."

- CONDITION))

- (LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN))

- (LET ((CLUSTER (POP *HANDLER-CLUSTERS*)))

- (DOLIST (HANDLER CLUSTER)

- (WHEN (TYPEP CONDITION (CAR HANDLER))

- (FUNCALL (CDR HANDLER) CONDITION)

- (RETURN NIL) ;?

- ))))

- NIL))

-

-;;; COERCE-TO-CONDITION

-;;; Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the

-;;; hairy argument conventions into a single argument that's directly usable

-;;; by all the other routines.

-

-(DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME)

- (COND ((CONDITIONP DATUM)

- (IF ARGUMENTS

- (CERROR "Ignore the additional arguments."

- 'SIMPLE-TYPE-ERROR

- :DATUM ARGUMENTS

- :EXPECTED-TYPE 'NULL

- :FORMAT-CONTROL "You may not supply additional arguments ~

- when giving ~S to ~S."

- :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME)))

- DATUM)

- ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM))

- (let* ((n (if (symbolp datum) datum (class-name datum)))

- (c (find-class (symcat (if (simple-condition-class-p n) "INTERNAL-" "INTERNAL-SIMPLE-") n) nil)))

- (if c

- (apply 'make-condition (class-name c) (append arguments (list :function-name (si::ihs-fname si::*ihs-top*))));FIXME

- (apply #'make-condition datum arguments))))

- ((STRINGP DATUM)

- (MAKE-CONDITION DEFAULT-TYPE

- :FORMAT-CONTROL DATUM

- :FORMAT-ARGUMENTS ARGUMENTS))

- (T

- (ERROR 'SIMPLE-TYPE-ERROR

- :DATUM DATUM

- :EXPECTED-TYPE '(OR SYMBOL STRING)

- :FORMAT-CONTROL "Bad argument to ~S: ~S"

- :FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM)))))

-

-(DEFUN ERROR (DATUM &REST ARGUMENTS)

- (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR)))

- (SIGNAL CONDITION)

- (INVOKE-DEBUGGER CONDITION)))

-

-(DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS)

- (WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS))

- (APPLY #'ERROR DATUM ARGUMENTS))

- NIL)

-

-(DEFUN BREAK (&OPTIONAL (FORMAT-CONTROL "Break") &REST FORMAT-ARGUMENTS)

- (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.")

- (INVOKE-DEBUGGER

- (MAKE-CONDITION 'SIMPLE-CONDITION

- :FORMAT-CONTROL FORMAT-CONTROL

- :FORMAT-ARGUMENTS FORMAT-ARGUMENTS)))

- NIL)

-

-(DEFUN WARN (DATUM &REST ARGUMENTS)

- (LET ((CONDITION

- (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN)))

- (CHECK-TYPE CONDITION WARNING "a warning condition")

- (IF *BREAK-ON-WARNINGS*

- (BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*."

- CONDITION))

- (RESTART-CASE (SIGNAL CONDITION)

- (MUFFLE-WARNING ()

- :REPORT "Skip warning."

- (RETURN-FROM WARN NIL)))

- (FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION)

- NIL))

-

-(DEFMACRO HANDLER-CASE (FORM &REST CASES)

- (LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES)))

- (IF NO-ERROR-CLAUSE

- (LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN"))

- (ERROR-RETURN (MAKE-SYMBOL "ERROR-RETURN")))

- `(BLOCK ,ERROR-RETURN

- (MULTIPLE-VALUE-CALL #'(LAMBDA ,@(CDR NO-ERROR-CLAUSE))

- (BLOCK ,NORMAL-RETURN

- (RETURN-FROM ,ERROR-RETURN

- (HANDLER-CASE (RETURN-FROM ,NORMAL-RETURN ,FORM)

- ,@(REMOVE NO-ERROR-CLAUSE CASES)))))))

- (LET ((TAG (GENSYM))

- (VAR (GENSYM))

- (ANNOTATED-CASES (MAPCAR #'(LAMBDA (CASE) (CONS (GENSYM) CASE))

- CASES)))

- `(BLOCK ,TAG

- (LET ((,VAR NIL))

- ,VAR ;ignorable

- (TAGBODY

- (HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE)

- (LIST (CADR ANNOTATED-CASE)

- `#'(LAMBDA (TEMP)

- ,@(IF (CADDR ANNOTATED-CASE)

- `((SETQ ,VAR TEMP)))

- (GO ,(CAR ANNOTATED-CASE)))))

- ANNOTATED-CASES)

- (RETURN-FROM ,TAG ,FORM))

- ,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE)

- (LIST (CAR ANNOTATED-CASE)

- (LET ((BODY (CDDDR ANNOTATED-CASE)))

- `(RETURN-FROM ,TAG

- ,(COND ((CADDR ANNOTATED-CASE)

- `(LET ((,(CAADDR ANNOTATED-CASE)

- ,VAR))

- ,@BODY))

- ((NOT (CDR BODY))

- (CAR BODY))

- (T

- `(PROGN ,@BODY)))))))

- ANNOTATED-CASES))))))))

-

-(DEFMACRO IGNORE-ERRORS (&REST FORMS)

- `(HANDLER-CASE (PROGN ,@FORMS)

- (ERROR (CONDITION) (VALUES NIL CONDITION))))

+(in-package :conditions)

+

+(defmacro handler-bind (bindings &body forms)

+ (declare (optimize (safety 2)))

+ `(let ((*handler-clusters* (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) bindings))

+ *handler-clusters*)))

+ ,@forms))

+

+

+(defmacro handler-case (form &rest cases)

+ (declare (optimize (safety 2)))

+ (let ((no-error-clause (assoc ':no-error cases)))

+ (if no-error-clause

+ (let ((normal-return (gensym)) (error-return (gensym)))

+ `(block ,error-return

+ (multiple-value-call (lambda ,@(cdr no-error-clause))

+ (block ,normal-return

+ (return-from ,error-return

+ (handler-case (return-from ,normal-return ,form)

+ ,@(remove no-error-clause cases)))))))

+ (let ((block (gensym))(var (gensym))(tcases (mapcar (lambda (x) (cons (gensym) x)) cases)))

+ `(block ,block

+ (let (,var)

+ (declare (ignorable ,var))

+ (tagbody

+ (handler-bind ,(mapcar (lambda (x &aux (tag (pop x))(type (pop x))(ll (car x)))

+ (list type `(lambda (x) ,(if ll `(setq ,var x) `(declare (ignore x))) (go ,tag))))

+ tcases)

+ (return-from ,block ,form))

+ ,@(mapcan (lambda (x &aux (tag (pop x))(type (pop x))(ll (pop x))(body x))

+ (list tag `(return-from ,block (let ,(when ll `((,(car ll) ,var))) ,@body))))

+ tcases))))))))

+

+(defmacro ignore-errors (&rest forms)

+ `(handler-case (progn ,@forms)

+ (error (condition) (values nil condition))))

diff --git a/gcl/clcs/gcl_clcs_install.lisp b/gcl/clcs/gcl_clcs_install.lisp
deleted file mode 100755
index b93e377b3..000000000
--- a/gcl/clcs/gcl_clcs_install.lisp
+++ /dev/null

@@ -1,104 +0,0 @@

-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-

-(in-package "CONDITIONS")

-

-(defvar *shadowed-symbols*

- '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE))

-

-(defun install-symbol (real clcs)

- (unless (get real 'definition-before-clcs)

- (setf (get real 'definition-before-clcs)

- (symbol-function real)))

- (unless (eq (symbol-function real)

- (symbol-function clcs))

- (setf (symbol-function real)

- (symbol-function clcs))))

-

-(defun revert-symbol (real)

- (when (and (get real 'definition-before-clcs)

- (not (eq (symbol-function real)

- (get real 'definition-before-clcs))))

- (setf (symbol-function real)

- (get real 'definition-before-clcs))))

-

-(defvar *clcs-redefinitions*

- (nconc (mapcar #'(lambda (symbol)

- (list (intern (symbol-name symbol) "LISP") symbol))

- *shadowed-symbols*)

- '((compile-file clcs-compile-file)

- (compile clcs-compile)

- (load clcs-load)

- (open clcs-open)

- #+kcl (si::break-level si::clcs-break-level)

- #+kcl (si::terminal-interrupt si::clcs-terminal-interrupt)

- #+kcl (si::break-quit si::clcs-break-quit)

-; #+kcl (si::error-set clcs-error-set)

- #+kcl (si::universal-error-handler clcs-universal-error-handler))))

-

-(defun install-clcs-symbols ()

- (dolist (r *clcs-redefinitions*)

- (install-symbol (first r) (second r)))

- nil)

-

-(defun revert-clcs-symbols ()

- (dolist (r (reverse *clcs-redefinitions*))

- (revert-symbol (first r)))

- nil)

-

-(defun clcs-compile-file (file &rest args)

- (loop (with-simple-restart (retry "Retry compiling file ~S." file)

- (let ((values (multiple-value-list

- (apply (or (get 'compile-file 'definition-before-clcs)

- #'compile-file)

- file args))))

- (unless #+kcl compiler::*error-p* #-kcl nil

- (return-from clcs-compile-file

- (values-list values)))

- (error "~S failed." 'compile-file)))))

-

-(defun clcs-compile (&rest args)

- (loop (with-simple-restart (retry "Retry compiling ~S." (car args))

- (let ((values (multiple-value-list

- (apply (or (get 'compile 'definition-before-clcs)

- #'compile-file)

- args))))

- (unless #+kcl compiler::*error-p* #-kcl nil

- (return-from clcs-compile

- (values-list values)))

- (error "~S failed." 'compile)))))

-

-(defun clcs-load (file &rest args)

- (loop (with-simple-restart (retry "Retry loading file ~S." file)

- (return-from clcs-load

- (apply (or (get 'load 'definition-before-clcs) #'load)

- file args)))))

-

-(defun clcs-open (file &rest args)

- (loop (with-simple-restart (retry "Retry opening file ~S." file)

- (return-from clcs-open

- (apply (or (get 'open 'definition-before-clcs) #'open)

- file args)))))

-

-#+(or kcl lucid cmu)

-(install-clcs-symbols)

-

-#+dsys

-(defun dsys::retry-operation (function retry-string)

- (loop (with-simple-restart (retry retry-string)

- (return-from dsys::retry-operation

- (funcall function)))))

-

-#+dsys

-(defun dsys::operate-on-module (module initial-state system-operation)

- (if (null dsys::*retry-operation-list*)

- (dsys::operate-on-module1 module initial-state system-operation)

- (let ((retry-operation (car (last dsys::*retry-operation-list*)))

- (dsys::*retry-operation-list* (butlast dsys::*retry-operation-list*)))

- (restart-bind ((retry

- #'(lambda (&rest ignore)

- (declare (ignore ignore))

- (funcall (car retry-operation)))

- :report-function

- #'(lambda (stream)

- (write-string (cdr retry-operation) stream))))

- (dsys::operate-on-module module initial-state system-operation)))))

diff --git a/gcl/clcs/gcl_clcs_kcl_cond.lisp b/gcl/clcs/gcl_clcs_kcl_cond.lisp
deleted file mode 100755
index 5de69f86c..000000000
--- a/gcl/clcs/gcl_clcs_kcl_cond.lisp
+++ /dev/null

@@ -1,213 +0,0 @@

-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-

-(in-package "CONDITIONS")

-

-(defvar *internal-error-table* (make-hash-table :test 'equal))

-

-;(defmacro find-internal-error-data (error-name error-format-string)

-; `(gethash (list ,error-name ,error-format-string) *internal-error-table*))

-(defmacro find-internal-error-data (error-name)

- `(gethash (list ,error-name) *internal-error-table*))

-

-;(defun clcs-universal-error-handler (error-name correctable function-name

-; continue-format-string error-format-string

-; &rest args)

-; (if correctable

-; (with-simple-restart

-; (continue "~a" (apply #'format nil continue-format-string args))

-; (error 'internal-simple-error

-; :function-name function-name

-; :format-string error-format-string

-; :format-arguments args))

-; (let ((e-d (find-internal-error-data error-name error-format-string)))

-; (if e-d

-; (let ((condition-name (car e-d)))

-; (apply #'error condition-name

-; :function-name function-name

-; (let ((k-a (mapcan #'list (cdr e-d) args)))

-; (if (simple-condition-class-p condition-name)

-; (list* :format-string error-format-string

-; :format-arguments args

-; k-a)

-; k-a))))

-; (error 'internal-simple-error :function-name function-name

-; :format-string error-format-string :format-arguments args)))))

-

-(defvar *internal-error-parms* nil)

-

-(defun clcs-universal-error-handler (error-name correctable function-name

- continue-format-control error-format-string

- &rest args

- &aux (internal-error-parms

- (list error-name correctable function-name

- continue-format-control error-format-string)))

- ;; (when (equal internal-error-parms *internal-error-parms*)

- ;; (format t "Universal error handler called recursively ~S~%"

- ;; internal-error-parms)

- ;; (return-from clcs-universal-error-handler))

- (let* ((*internal-error-parms* (list error-name correctable function-name

- continue-format-control error-format-string))

- (e-d (find-internal-error-data error-name)))

- (if e-d

- (let ((condition-name (car e-d)))

- (if correctable

- (with-simple-restart

- (continue "~a" (apply #'format nil continue-format-control args))

- (apply #'error condition-name

- :function-name function-name

- (let ((k-a (mapcan #'list (cdr e-d) args)))

- (if (simple-condition-class-p condition-name)

- (list* :format-control error-format-string

- :format-arguments args

- k-a)

- k-a))))

- (apply #'error condition-name

- :function-name function-name

- (let ((k-a (mapcan #'list (cdr e-d) args)))

- (if (simple-condition-class-p condition-name)

- (list* :format-control error-format-string

- :format-arguments args

- k-a)

- k-a)))))

- (error 'internal-simple-error :function-name function-name

- :format-control error-format-string :format-arguments args))))

-

-(defun set-internal-error (error-keyword error-format condition-name

- &rest keyword-list)

- (declare (ignore error-format))

-; (setf (find-internal-error-data error-keyword error-format)

- (setf (find-internal-error-data error-keyword)

- (cons condition-name keyword-list)))

-

-(defun initialize-internal-error-table ()

- (declare (special *internal-error-list*))

- (clrhash *internal-error-table*)

- (dolist (error-data *internal-error-list*)

- (apply #'set-internal-error (cdr error-data))))

-

-(defparameter *internal-error-list*

- '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S."

- internal-simple-type-error :datum :expected-type)

- ("FEpackage_error" :package-error "A package error occurred on ~S: ~S."

- internal-simple-package-error :package :message) ; |<function>| |top - base|

- ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p."

- internal-simple-program-error) ; |<function>| |top - base|

-; ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments."

-; internal-simple-control-error) ; |<function>| |args|

- ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p."

- internal-simple-program-error) ; |<function>| |top - base|

-; ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments."

-; internal-simple-control-error) ; |<function>| |args|

- ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S."

- internal-simple-program-error) ; |<function>|

- ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S."

- internal-simple-program-error) ; |<function>| |key|

- ("FEunbound_variable" :unbound-variable "The variable ~S is unbound."

- internal-simple-unbound-variable :name) ; |sym|

- ("FEundefined_function" :undefined-function "The function ~S is undefined."

- internal-simple-undefined-function :name)

- ("FEinvalid_function" :invalid-function "~S is invalid as a function."

- internal-simple-undefined-function :name) ; |obj|

- ("FEinvalid_variable" :invalid-variable "~S is an invalid variable."

- internal-simple-program-error) ; |obj|

- ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\

-but only ~R ~:*~[were~;was~:;were~] supplied."

- internal-simple-program-error) ; |<function>| |n| |top - base|

-; ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\

-;but ~R ~:*~[were~;was~:;were~] supplied."

-; internal-simple-program-error) ; |<function>| |n| |top - base|

- ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA."

- internal-simple-control-error)

- ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA."

- internal-simple-control-error)

- ("keyword_value_mismatch" :error "Keywords and values do not match."

- internal-simple-program-error) ;??

- ("not_a_keyword" :error "~S is not a keyword."

- internal-simple-program-error) ;??

- ("illegal_declare" :invalid-form "~S is an illegal declaration form."

- internal-simple-program-error)

-; ("not_a_symbol" :invalid-variable "~S is not a symbol."

-; internal-simple-error) ;??

-; ("not_a_variable" :invalid-variable "~S is not a variable."

-; internal-simple-program-error)

- ("illegal_index" :error "~S is an illegal index to ~S."

- internal-simple-error)

- ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args"

- internal-simple-control-error)

- ("end_of_stream" :error "Unexpected end of ~S."

- internal-simple-end-of-file :stream)

- ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option."

- internal-simple-control-error)

- ("open_stream" :error "The file ~A already exists."

- internal-simple-file-error :pathname)

- ("open_stream" :error "Cannot append to the file ~A."

- internal-simple-file-error :pathname)

- ("open_stream" :error "~S is an illegal IF-EXISTS option."

- internal-simple-control-error)

- ("close_stream" :error "Cannot close the standard output."

- internal-simple-stream-error) ; no stream here!!

- ("close_stream" :error "Cannot close the standard input."

- internal-simple-stream-error) ; no stream here!!

- ("too_long_file_name" :error "~S is a too long file name."

- internal-simple-file-error :pathname)

- ("cannot_open" :error "Cannot open the file ~A."

- internal-simple-file-error :pathname)

- ("cannot_create" :error "Cannot create the file ~A."

- internal-simple-file-error :pathname)

- ("cannot_read" :error "Cannot read the stream ~S."

- internal-simple-stream-error :stream)

- ("cannot_write" :error "Cannot write to the stream ~S."

- internal-simple-stream-error :stream)

- ))

-

-(initialize-internal-error-table)

-

-(defun condition-backtrace (condition)

- (let* ((*debug-io* *error-output*)

- (si::*ihs-base* (1+ si::*ihs-top*))

- (si::*ihs-top* (1- (si::ihs-top)))

- (si::*current-ihs* si::*ihs-top*)

- (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*)

- (1+ (si::frs-top))))

- (si::*frs-top* (si::frs-top))

- (si::*break-env* nil))

- (format *error-output* "~%~A~%" condition)

- (si::simple-backtrace)))

-

-(defvar *error-set-break-p* nil)

-

-(defun clcs-error-set (form)

- (let ((cond nil))

- (restart-case (handler-bind ((error #'(lambda (condition)

- (unless (or si::*break-enable*

- *error-set-break-p*)

- (condition-backtrace condition)

- (return-from clcs-error-set condition))

- (setq cond condition)

- nil)))

- (values-list (cons nil (multiple-value-list (eval form)))))

- (si::error-set ()

- :report (lambda (stream)

- (format stream "~S" `(si::error-set ',form)))

- cond))))

-

-(eval-when (compile load eval)

-

-(defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties

- (setf (symbol-function symbol) (symbol-function symbol)))

-

-(reset-function 'si::error-set)

-(reset-function 'load)

-(reset-function 'open)

-)

-

-(setq compiler::*compiler-break-enable* t)

-

-(defun compiler::cmp-toplevel-eval (form)

- (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack

- (si::*ihs-top* (1- (si::ihs-top)))

- (*break-enable* compiler::*compiler-break-enable*)

- (si::*break-hidden-packages*

- (cons (find-package 'compiler)

- si::*break-hidden-packages*)))

- (si:error-set form)))

diff --git a/gcl/clcs/gcl_clcs_macros.lisp b/gcl/clcs/gcl_clcs_macros.lisp
deleted file mode 100755
index 0bcfa0304..000000000
--- a/gcl/clcs/gcl_clcs_macros.lisp
+++ /dev/null

@@ -1,178 +0,0 @@

-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-

-(IN-PACKAGE "CONDITIONS")

-

-(EVAL-WHEN (EVAL COMPILE LOAD)

-

-(DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P)

- (DO ((L '())

- (C CASES (CDR C)))

- ((NULL C) (NREVERSE L))

- (LET ((KEYS (CAAR C)))

- (COND ((ATOM KEYS)

- (COND ((NULL KEYS))

- ((MEMBER KEYS '(OTHERWISE T))

- (IF (NOT (MEMBER MACRO-NAME '( ECASE CCASE ETYPECASE CTYPECASE)))

- (ERROR "OTHERWISE is not allowed in ~S expressions." MACRO-NAME))

- (PUSH (LIST KEYS) L))

- (T (PUSH KEYS L))))

- (LIST-IS-ATOM-P

- (PUSH KEYS L))

- (T (DOLIST (KEY KEYS) (PUSH KEY L)))))))

-);NEHW-LAVE

-

-;(DEFUN ESCAPE-SPECIAL-CASES (CASES)

-; (DO ((L '())

-; (C CASES (CDR C)))

-; ((NULL C) (NREVERSE L))

-; (LET ((KEYS (CAAR C)))

-; (COND ((ATOM KEYS)

-; (COND ((NULL KEYS))

-; ((MEMBER KEYS '(OTHERWISE T))

-; (PUSH (CONS (LIST KEYS) (CDR (CAR C))) L))

-; (T (PUSH (CONS KEYS (CDR (CAR C))) L))))

-; (T

-; (PUSH (CONS KEYS (CDR (CAR C))) L))))))

-

-(DEFUN ESCAPE-SPECIAL-CASES-REPLACE (CASES)

- (DO ((C CASES (CDR C)))

- ((NULL C) CASES)

- (LET ((KEYS (CAAR C)))

- (IF (MEMBER KEYS '(OTHERWISE T))

- (RPLACA (CAR C) (LIST KEYS))))))

-

-(DEFMACRO ECASE (KEYFORM &REST CASES)

- (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL))

- (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES))

- (VAR (GENSYM)))

- `(LET ((,VAR ,KEYFORM))

- (CASE ,VAR

- ,@NCASES

- (OTHERWISE

- (ERROR 'CASE-FAILURE :NAME 'ECASE

- :DATUM ,VAR

- :EXPECTED-TYPE '(MEMBER ,@KEYS)

- :POSSIBILITIES ',KEYS))))))

-

-(DEFMACRO CCASE (KEYPLACE &REST CASES)

- (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL))

- (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES))

- (TAG1 (GENSYM))

- (TAG2 (GENSYM)))

- `(BLOCK ,TAG1

- (TAGBODY ,TAG2

- (RETURN-FROM ,TAG1

- (CASE ,KEYPLACE

- ,@NCASES

- (OTHERWISE

- (RESTART-CASE (ERROR 'CASE-FAILURE

- :NAME 'CCASE

- :DATUM ,KEYPLACE

- :EXPECTED-TYPE '(MEMBER ,@KEYS)

- :POSSIBILITIES ',KEYS)

- (STORE-VALUE (VALUE)

- :REPORT (LAMBDA (STREAM)

- (FORMAT STREAM "Supply a new value of ~S."

- ',KEYPLACE))

- :INTERACTIVE READ-EVALUATED-FORM

- (SETF ,KEYPLACE VALUE)

- (GO ,TAG2))))))))))

-

-(DEFMACRO ETYPECASE (KEYFORM &REST CASES)

- (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T))

- (VAR (GENSYM)))

- `(LET ((,VAR ,KEYFORM))

- (TYPECASE ,VAR

- ,@CASES

- (OTHERWISE

- (ERROR 'CASE-FAILURE :NAME 'ETYPECASE

- :DATUM ,VAR

- :EXPECTED-TYPE '(OR ,@TYPES)

- :POSSIBILITIES ',TYPES))))))

-

-(DEFMACRO CTYPECASE (KEYPLACE &REST CASES)

- (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T))

- (TAG1 (GENSYM))

- (TAG2 (GENSYM)))

- `(BLOCK ,TAG1

- (TAGBODY ,TAG2

- (RETURN-FROM ,TAG1

- (TYPECASE ,KEYPLACE

- ,@CASES

- (OTHERWISE

- (RESTART-CASE (ERROR 'CASE-FAILURE

- :NAME 'CTYPECASE

- :DATUM ,KEYPLACE

- :EXPECTED-TYPE '(OR ,@TYPES)

- :POSSIBILITIES ',TYPES)

- (STORE-VALUE (VALUE)

- :REPORT (LAMBDA (STREAM)

- (FORMAT STREAM "Supply a new value of ~S."

- ',KEYPLACE))

- :INTERACTIVE READ-EVALUATED-FORM

- (SETF ,KEYPLACE VALUE)

- (GO ,TAG2))))))))))

-

-(DEFUN ASSERT-REPORT (NAMES STREAM)

- (FORMAT STREAM "Retry assertion")

- (IF NAMES

- (FORMAT STREAM " with new value~P for ~{~S~^, ~}."

- (LENGTH NAMES) NAMES)

- (FORMAT STREAM ".")))

-

-(DEFUN ASSERT-PROMPT (NAME VALUE)

- (COND ((Y-OR-N-P "The old value of ~S is ~S.~

- ~%Do you want to supply a new value? "

- NAME VALUE)

- (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")

- (FLET ((READ-IT () (EVAL (READ *QUERY-IO*))))

- (IF (SYMBOLP NAME) ;Help user debug lexical variables

- (PROGV (LIST NAME) (LIST VALUE) (READ-IT))

- (READ-IT))))

- (T VALUE)))

-

-(DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION)

- (ERROR 'SIMPLE-TYPE-ERROR

- :DATUM ASSERTION

- :EXPECTED-TYPE '(NOT NULL)

- :FORMAT-CONTROL "~%The assertion ~S failed."

- :FORMAT-ARGUMENTS (LIST ASSERTION)))

-

-(DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS)

- (LET ((TAG (GENSYM)))

- `(TAGBODY ,TAG

- (UNLESS ,TEST-FORM

- (RESTART-CASE ,(IF DATUM

- `(ERROR ,DATUM ,@ARGUMENTS)

- `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM))

- (CONTINUE ()

- :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM))

- ,@(MAPCAR #'(LAMBDA (PLACE)

- `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE)))

- PLACES)

- (GO ,TAG)))))))

-

-(DEFUN READ-EVALUATED-FORM ()

- (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")

- (LIST (EVAL (READ *QUERY-IO*))))

-

-(DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING)

- (LET ((TAG1 (GENSYM))

- (TAG2 (GENSYM)))

- `(BLOCK ,TAG1

- (TAGBODY ,TAG2

- (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL))

- (RESTART-CASE ,(IF TYPE-STRING

- `(ERROR "The value of ~S is ~S, ~

- which is not ~A."

- ',PLACE ,PLACE ,TYPE-STRING)

- `(ERROR "The value of ~S is ~S, ~

- which is not of type ~S."

- ',PLACE ,PLACE ',TYPE))

- (STORE-VALUE (VALUE)

- :REPORT (LAMBDA (STREAM)

- (FORMAT STREAM "Supply a new value of ~S."

- ',PLACE))

- :INTERACTIVE READ-EVALUATED-FORM

- (SETF ,PLACE VALUE)

- (GO ,TAG2)))))))

diff --git a/gcl/clcs/gcl_clcs_restart.lisp b/gcl/clcs/gcl_clcs_restart.lisp
deleted file mode 100755
index 1ff3d6e17..000000000
--- a/gcl/clcs/gcl_clcs_restart.lisp
+++ /dev/null

@@ -1,213 +0,0 @@

-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

-

-(IN-PACKAGE "CONDITIONS")

-

-;;; Unique Ids

-

-(DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE))

-(DEFVAR *UNIQUE-ID-COUNT* -1)

-

-(DEFUN UNIQUE-ID (OBJ)

- "Generates a unique integer ID for its argument."

- (OR (GETHASH OBJ *UNIQUE-ID-TABLE*)

- (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*))))

-

-;;; Miscellaneous Utilities

-

-(EVAL-WHEN (EVAL COMPILE LOAD)

-

-(DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS)

- (DO ((L LIST (CDDR L))

- (K '() (LIST* (CADR L) (CAR L) K)))

- ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS)))

- (VALUES (NREVERSE K) L))))

-

-(DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS)

- (LET ((TEMP (MEMBER '&REST NAMES)))

- (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is ~:[missing~;misplaced~]." TEMP))

- (LET ((KEY-VARS (LDIFF NAMES TEMP))

- (KEY-VAR (OR KEYWORDS-VAR (GENSYM)))

- (REST-VAR (CADR TEMP)))

- (LET ((KEYWORDS (MAPCAR #'(LAMBDA (X) (INTERN (STRING X) (FIND-PACKAGE "KEYWORD")))

- KEY-VARS)))

- `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR)

- (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS)

- (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD)))

- KEY-VARS KEYWORDS)

- ,@FORMS))))))

-

-);NEHW-LAVE

-

-;;; Restarts

-

-(DEFVAR *RESTART-CLUSTERS* '())

-

-; FIXME add condition support

-(DEFUN COMPUTE-RESTARTS (&optional condition)

- #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts))

- #-kcl (mapcan #'copy-list *RESTART-CLUSTERS*))

-

-(DEFUN RESTART-PRINT (RESTART STREAM DEPTH)

- (DECLARE (IGNORE DEPTH))

- (IF *PRINT-ESCAPE*

- (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART))

- (RESTART-REPORT RESTART STREAM)))

-

-(DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT))

- NAME

- FUNCTION

- REPORT-FUNCTION

- INTERACTIVE-FUNCTION)

-

-#+kcl

-(progn

-(defvar *kcl-top-restarts* nil)

-

-(defun make-kcl-top-restart (quit-tag)

- (make-restart :name 'gcl-top-restart

- :function #'(lambda () (throw (car (list quit-tag)) quit-tag))

- :report-function

- #'(lambda (stream)

- (let ((b-l (if (eq quit-tag si::*quit-tag*)

- si::*break-level*

- (car (or (find quit-tag si::*quit-tags*

- :key #'cdr)

- '(:not-found))))))

- (cond ((eq b-l :not-found)

- (format stream "Return to ? level."))

- ((null b-l)

- (format stream "Return to top level."))

- (t

- (format stream "Return to break level ~D."

- (length b-l))))))

- :interactive-function nil))

-

-(defun find-kcl-top-restart (quit-tag)

- (cdr (or (assoc quit-tag *kcl-top-restarts*)

- (car (push (cons quit-tag (make-kcl-top-restart quit-tag))

- *kcl-top-restarts*)))))

-

-(defun kcl-top-restarts ()

- (let* (;(old-tags (ldiff si::*quit-tags* (member nil si::*quit-tags* :key 'cdr)))

- (old-tags si::*quit-tags*)

- (old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e)))) old-tags))

- (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags))

- (restarts (mapcar #'find-kcl-top-restart tags)))

- (setq *kcl-top-restarts* (mapcar #'cons tags restarts))

- restarts))

-)

-

-(DEFUN RESTART-REPORT (RESTART STREAM)

- (FUNCALL (OR (RESTART-REPORT-FUNCTION RESTART)

- (LET ((NAME (RESTART-NAME RESTART)))

- #'(LAMBDA (STREAM)

- (IF NAME (FORMAT STREAM "~S" NAME)

- (FORMAT STREAM "~S" RESTART)))))

- STREAM))

-

-(DEFMACRO RESTART-BIND (BINDINGS &BODY FORMS)

- `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING)

- `(MAKE-RESTART

- :NAME ',(CAR BINDING)

- :FUNCTION ,(CADR BINDING)

- ,@(CDDR BINDING)))

- BINDINGS))

- *RESTART-CLUSTERS*)))

- ,@FORMS))

-

-(DEFUN FIND-RESTART (NAME &optional condition)

-;FIXME add condition support

- (declare (ignore condition))

- (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*)

- (DOLIST (RESTART RESTART-CLUSTER)

- (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))

- (RETURN-FROM FIND-RESTART RESTART))))

- #+kcl

- (let ((RESTART-CLUSTER (kcl-top-restarts)))

- (DOLIST (RESTART RESTART-CLUSTER)

- (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))

- (RETURN-FROM FIND-RESTART RESTART)))))

-

-(DEFUN INVOKE-RESTART (RESTART &REST VALUES)

- (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)

- (ERROR "Restart ~S is not active." RESTART))))

- (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES)))

-

-(DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART)

- (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)

- (ERROR "Restart ~S is not active." RESTART))))

- (APPLY (RESTART-FUNCTION REAL-RESTART)

- (LET ((INTERACTIVE-FUNCTION

- (RESTART-INTERACTIVE-FUNCTION REAL-RESTART)))

- (IF INTERACTIVE-FUNCTION

- (FUNCALL INTERACTIVE-FUNCTION)

- '())))))

-

-(DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES)

- (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE)

- (LET ((RESULT '()))

- (WHEN REPORT

- (SETQ RESULT (LIST* (IF (STRINGP REPORT)

- `#'(LAMBDA (STREAM)

- (WRITE-STRING ,REPORT STREAM))

- `#',REPORT)

- :REPORT-FUNCTION

- RESULT)))

- (WHEN INTERACTIVE

- (SETQ RESULT (LIST* `#',INTERACTIVE

- :INTERACTIVE-FUNCTION

- RESULT)))

- (NREVERSE RESULT))))

- (LET ((BLOCK-TAG (GENSYM))

- (TEMP-VAR (GENSYM))

- (DATA

- (MAPCAR #'(LAMBDA (CLAUSE)

- (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS)

- (CDDR CLAUSE))

- (LIST (CAR CLAUSE) ;Name=0

- (GENSYM) ;Tag=1

- (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2

- :INTERACTIVE INTERACTIVE)

- (CADR CLAUSE) ;BVL=3

- FORMS))) ;Body=4

- CLAUSES)))

- `(BLOCK ,BLOCK-TAG

- (LET ((,TEMP-VAR NIL))

- (TAGBODY

- (RESTART-BIND

- ,(MAPCAR #'(LAMBDA (DATUM)

- (LET ((NAME (NTH 0 DATUM))

- (TAG (NTH 1 DATUM))

- (KEYS (NTH 2 DATUM)))

- `(,NAME #'(LAMBDA (&REST TEMP)

- #+LISPM (SETQ TEMP (COPY-LIST TEMP))

- (SETQ ,TEMP-VAR TEMP)

- (GO ,TAG))

- ,@KEYS)))

- DATA)

- (RETURN-FROM ,BLOCK-TAG ,EXPRESSION))

- ,@(MAPCAN #'(LAMBDA (DATUM)

- (LET ((TAG (NTH 1 DATUM))

- (BVL (NTH 3 DATUM))

- (BODY (NTH 4 DATUM)))

- (LIST TAG

- `(RETURN-FROM ,BLOCK-TAG

- (APPLY #'(LAMBDA ,BVL ,@BODY)

- ,TEMP-VAR)))))

- DATA)))))))

-

-(DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-CONTROL

- &REST FORMAT-ARGUMENTS)

- &BODY FORMS)

- `(RESTART-CASE (PROGN ,@FORMS)

- (,RESTART-NAME ()

- :REPORT (LAMBDA (STREAM)

- (FORMAT STREAM ,FORMAT-CONTROL ,@FORMAT-ARGUMENTS))

- (VALUES NIL T))))

-

-(DEFUN ABORT () (INVOKE-RESTART 'ABORT)

- (ERROR 'ABORT-FAILURE))

-(DEFUN CONTINUE () (INVOKE-RESTART 'CONTINUE))

-(DEFUN MUFFLE-WARNING () (INVOKE-RESTART 'MUFFLE-WARNING))

-(DEFUN STORE-VALUE (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE))

-(DEFUN USE-VALUE (VALUE) (INVOKE-RESTART 'USE-VALUE VALUE))

diff --git a/gcl/clcs/gcl_clcs_top_patches.lisp b/gcl/clcs/gcl_clcs_top_patches.lisp
deleted file mode 100755
index d31ec1642..000000000
--- a/gcl/clcs/gcl_clcs_top_patches.lisp
+++ /dev/null

@@ -1,201 +0,0 @@

-

-(in-package "CONDITIONS")

-

-(import '(with-simple-restart abort continue compute-restarts

- *debug-level* *debug-restarts* *number-of-debug-restarts*

- *debug-abort* *debug-continue* *debug-condition* *debug-eval*

- find-restart invoke-restart invoke-restart-interactively

- restart-name ignore-errors show-restarts conditionp)

- "SYSTEM")

-

-(in-package "SYSTEM")

-

-(defvar *abort-restarts* nil)

-

-(defmacro with-clcs-break-level-bindings (&body forms)

- `(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))

- (debug-level *DEBUG-LEVEL*)

- (*DEBUG-RESTARTS* (COMPUTE-RESTARTS))

- (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*))

- (*DEBUG-ABORT* (FIND-RESTART 'ABORT))

- (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE)))

- (IF (OR (NOT *DEBUG-CONTINUE*)

- (NOT (EQ *DEBUG-CONTINUE* C)))

- C NIL))

- (LET ((C (IF *DEBUG-RESTARTS*

- (FIRST *DEBUG-RESTARTS*) NIL)))

- (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL))))

- (*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*))

- (*abort-restarts* (let ((abort-list nil))

- (dolist (restart *DEBUG-RESTARTS*)

- (when (eq 'abort (restart-name restart))

- (push restart abort-list)))

- (nreverse abort-list))))

- ,@forms))

-

-(defun clcs-break-level-invoke-restart (-)

- (COND ((AND (PLUSP -)

- (< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1)))

- (LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*)))

- (INVOKE-RESTART-INTERACTIVELY RESTART)))

- (T

- (FORMAT T "~&No such restart."))))

-

-;; From akcl-1-530, changes marked with ;***

-(defun clcs-break-level (at &optional env)

- (let* ((*break-message* (if (or (stringp at) (conditionp at)) ;***

- at *break-message*)) ;***

- (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;***

- *quit-tag*;(cons nil nil)) ;***

- (*break-level* (if (conditionp at) (cons t *break-level*) *break-level*))

- (*ihs-base* (1+ *ihs-top*))

- (*ihs-top* (1- (ihs-top)))

- (*current-ihs* *ihs-top*)

- (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))

- (*frs-top* (frs-top))

- *break-env*

- ;;(be *break-enable*) ;***

- ;;(*break-enable* ;***

- ;;(progn ;***

- ;;(if (stringp at) nil be))) ;***

- ;;(*standard-input* *terminal-io*)

- (*readtable* (or *break-readtable* *readtable*))

- *read-suppress*

- (+ +) (++ ++) (+++ +++)

- (- -)

- (* *) (** **) (*** ***)

- (/ /) (// //) (/// ///) (first t))

- ;;(terpri *error-output*)

- (with-clcs-break-level-bindings ;***

-

- (loop

-

- (setq +++ ++ ++ + + -)

-

- (unless ;***

- (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;***

- (not

- (catch 'step-continue

-

- (when first

- (if (consp at)

- (set-back at env)

- (progn

- (format *debug-io* "~&~A~2%" *break-message*) ;***

- (when (> (length *link-array*) 0)

- (format *debug-io* "Fast links are on: do (use-fast-links nil) for debugging~%"))

- (set-current) ;***

- (setq *no-prompt* nil)

- (show-restarts))) ;***

- (catch-fatal 1)

- (setq *interrupt-enable* t first nil))

-

- (if *no-prompt*

- (setq *no-prompt* nil)

- (format *debug-io* "~&~a~a>~{~*>~}"

- (if (stringp at) "" "dbl:")

- (if (eq *package* (find-package 'user)) ""

- (package-name *package*))

- *break-level*))

-

- (setq - (locally (declare (notinline read))

- (dbl-read *debug-io* nil *top-eof*)))

- (when (eq - *top-eof*) (bye))

- (let* (break-command

- (values

- (multiple-value-list

- (LOCALLY (declare (notinline break-call evalhook))

- (if (or (keywordp -) (integerp -)) ;***

- (setq - (cons - nil)))

- (cond ((and (consp -) (keywordp (car -)))

- (setq break-command t)

- (break-call (car -) (cdr -)))

- ((and (consp -) (integerp (car -))) ;***

- (setq break-command t) ;***

- (clcs-break-level-invoke-restart (car -))) ;***

- (t (evalhook - nil nil *break-env*))))))) ;***

- (setq /// // // / / values *** ** ** * * (car /))

- (fresh-line *debug-io*)

- (dolist (val /)

- (locally (declare (notinline prin1)) (prin1 val *debug-io*))

- (terpri *debug-io*)))

- nil))) ;***

- (terpri *debug-io*)

- (break-current))))))

-

-(defun clcs-terminal-interrupt (correctablep)

- (if correctablep

- (cerror "Continues execution." "Console interrupt.")

- (error "Console interrupt -- cannot continue.")))

-

-(defun clcs-break-quit (&optional (level 0))

- (let* ((ar (reverse *abort-restarts*))

- (tr (find-restart 'conditions::gcl-top-restart))

- (ar (if tr (cons tr ar) ar))

- (abort (nth level ar)))

- (if abort

- (invoke-restart-interactively abort)

- (let ((y (member nil *quit-tags* :key 'cdr)))

- (format *debug-io* "No abort restart is active")

- (when y

- (format *debug-io* ", perhaps because interrupts are disabled at break level ~s" (length y)))

- (format *debug-io* ".~%Consider using :r to continue, as :q is disabled.~%"))))

- (break-current))

-

-(setq conditions::*debugger-function* 'break-level)

-(setq conditions::*debug-command-prefix* "")

-

-(defun break-resume ()

- (and *debug-continue* (invoke-restart *debug-continue*)))

-

-(putprop :r 'break-resume 'break-command)

-(putprop :s 'show-restarts 'break-command)

-

-(defun break-help ()

- (format *debug-io* "

-Break-loop Command Summary ([] indicates optional arg)

---------------------------

-

-:bl [j] show local variables and their values, or segment of vs if compiled

- in j stack frames starting at the current one.

-:bt [n] BACKTRACE [n steps]

-:down [i] DOWN i frames (one if no i)

-:env describe ENVIRONMENT of this stack frame (for interpreted).

-:fr [n] show frame n

-:loc [i] return i'th local of this frame if its function is compiled (si::loc i)

-:r RESUME (return from the current break loop).

-:up [i] UP i frames (one if no i)

-

-Example: print a bactrace of the last 4 frames

-

->>:bt 4

-

-Note: (use-fast-links nil) makes all non system function calls

-be recorded in the stack. (use-fast-links t) is the default

-

-

-Low level commands:

-------------------

-:p [i] make current the i'th PREVIOUS frame (in list show by :b)

-:n [i] make current the i'th NEXT frame (in list show by :b)

-:go [ihs-index] make current the frame corresponding ihs-index

-:m print the last break message.

-:s show restarts.

-:c show function of the current ihs frame.

-:q [i] quit to top level

-:r resume from this break loop.

-:b full backtrace of all functions and special forms.

-:bs [name] backward search for frame named 'name'

-:fs [name] search for frame named 'name'

-:vs [from] [to] Show value stack between FROM and TO

-:ihs [from] [to] Show Invocation History Stack

-:bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1

-

-")

- (values)

- )

-

-(defmacro without-interrupts (&rest forms)

- `(let* (*quit-tag* *quit-tags* conditions::*restart-clusters*)

- ,@forms))

-

diff --git a/gcl/clcs/myload.lisp b/gcl/clcs/myload.lisp
index df276a891..b7692a450 100644
--- a/gcl/clcs/myload.lisp
+++ b/gcl/clcs/myload.lisp

@@ -1,10 +1,4 @@

(load "gcl_clcs_precom.lisp")

-(load "gcl_clcs_macros.lisp")

-(load "gcl_clcs_restart.lisp")

(load "gcl_clcs_handler.lisp")

-(load "gcl_clcs_debugger.lisp")

(load "gcl_clcs_conditions.lisp")

(load "gcl_clcs_condition_definitions.lisp")

-(load "gcl_clcs_kcl_cond.lisp")

-(load "gcl_clcs_top_patches.lisp")

-(load "gcl_clcs_install.lisp")

diff --git a/gcl/clcs/package.lisp b/gcl/clcs/package.lisp
index f1207f464..fbee2490a 100755
--- a/gcl/clcs/package.lisp
+++ b/gcl/clcs/package.lisp

@@ -12,36 +12,23 @@

;;; file will define a bunch of functions which work like a condition system. Redefining

;;; existing condition systems is beyond the goal of this implementation attempt.

-(MAKE-PACKAGE "CONDITIONS" :USE '("LISP" #+lucid "LUCID-COMMON-LISP"))

-(IN-PACKAGE "CONDITIONS" :USE '("LISP" #+lucid "LUCID-COMMON-LISP"))

+(make-package :conditions :use '(:lisp))

+(in-package :conditions :use '(:lisp))

-#-(or lucid excl genera cmu )

-(SHADOW '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE

- CTYPECASE ECASE CCASE))

-#+gcl

-(EXPORT '(;; Shadowed symbols

- BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE

- CTYPECASE ECASE CCASE))

+(import '(si::*handler-clusters* si::unique-id si::condition-class-p si::make-condition))

-(EXPORT '(;; New symbols

- *BREAK-ON-SIGNALS* *DEBUGGER-HOOK* SIGNAL

- HANDLER-CASE HANDLER-BIND IGNORE-ERRORS DEFINE-CONDITION MAKE-CONDITION

- WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND RESTART-NAME

- RESTART-NAME FIND-RESTART COMPUTE-RESTARTS INVOKE-RESTART

- INVOKE-RESTART-INTERACTIVELY ABORT CONTINUE MUFFLE-WARNING

- STORE-VALUE USE-VALUE INVOKE-DEBUGGER RESTART CONDITION

- WARNING SERIOUS-CONDITION SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-ERROR

- SIMPLE-CONDITION-FORMAT-CONTROL SIMPLE-CONDITION-FORMAT-ARGUMENTS

- STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED TYPE-ERROR

- TYPE-ERROR-DATUM TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR

- PROGRAM-ERROR CONTROL-ERROR STREAM-ERROR STREAM-ERROR-STREAM

- END-OF-FILE FILE-ERROR FILE-ERROR-PATHNAME CELL-ERROR

- UNBOUND-VARIABLE UNDEFINED-FUNCTION ARITHMETIC-ERROR

- ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS

- PACKAGE-ERROR PACKAGE-ERROR-PACKAGE

- DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW))

+(export '(handler-case handler-bind ignore-errors define-condition make-condition

+ condition warning serious-condition simple-condition-format-control simple-condition-format-arguments

+ storage-condition stack-overflow storage-exhausted type-error

+ type-error-datum type-error-expected-type simple-type-error

+ program-error control-error stream-error stream-error-stream

+ end-of-file file-error file-error-pathname cell-error

+ unbound-variable undefined-function arithmetic-error

+ arithmetic-error-operation arithmetic-error-operands

+ package-error package-error-package

+ division-by-zero floating-point-overflow floating-point-underflow))

-(DEFVAR *THIS-PACKAGE* (FIND-PACKAGE "CONDITIONS"))

+(defvar *this-package* (find-package :conditions))

diff --git a/gcl/lsp/gcl_export.lsp b/gcl/lsp/gcl_export.lsp
index 5846cca23..2063de0d3 100755
--- a/gcl/lsp/gcl_export.lsp
+++ b/gcl/lsp/gcl_export.lsp

@@ -307,4 +307,8 @@ with-standard-io-syntax

dynamic-extent

+restart-case

+store-value

+loop

+check-type assert typecase etypecase ctypecase case ecase ccase

))

diff --git a/gcl/lsp/gcl_iolib.lsp b/gcl/lsp/gcl_iolib.lsp
index 0c1e816a0..b2be57fc6 100755
--- a/gcl/lsp/gcl_iolib.lsp
+++ b/gcl/lsp/gcl_iolib.lsp

@@ -317,3 +317,9 @@

(if f

(w-f f)

(reduce (lambda (z x) (or z (w-f x))) ',g :initial-value nil)))))

+

+(defun maybe-clear-input (&optional (x *standard-input*))

+ (cond ((not (typep x 'stream)) nil)

+ ((typep x 'synonym-stream) (maybe-clear-input (symbol-value (synonym-stream-symbol x))))

+ ((typep x 'two-way-stream) (maybe-clear-input (two-way-stream-input-stream x)))

+ ((terminal-input-stream-p x) (clear-input t))))

diff --git a/gcl/lsp/gcl_restart.lsp b/gcl/lsp/gcl_restart.lsp
new file mode 100644
index 000000000..6969fb953
--- /dev/null
+++ b/gcl/lsp/gcl_restart.lsp

@@ -0,0 +1,205 @@

+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

+

+(in-package :lisp)

+

+(export '(restart-bind restart-case with-condition-restarts muffle-warning continue abort

+ store-value use-value

+ restart restart-name restart-function restart-report-function

+ restart-interactive-function restart-test-function

+ compute-restarts find-restart invoke-restart invoke-restart-interactively

+ with-simple-restart signal))

+

+(in-package :si)

+

+(defvar *restarts* nil)

+(defvar *restart-condition* nil)

+

+(defmacro restart-bind (bindings &body forms)

+ (declare (optimize (safety 2)))

+ `(let ((*restarts*

+ (list* ,@(mapcar (lambda (x) `(cons (make-restart :name ',(pop x) :function ,(pop x) ,@x) *restart-condition*)) bindings)

+ *restarts*)))

+ ,@forms))

+

+

+(defmacro with-condition-restarts (condition-form restarts-form &body body)

+ (declare (optimize (safety 1)))

+ (let ((n-cond (gensym)))

+ `(let* ((,n-cond ,condition-form)

+ (*restarts* (nconc (mapcar (lambda (x) (cons x ,n-cond)) ,restarts-form) *restarts*)))

+ ,@body)))

+

+(defun condition-pass (condition restart &aux b (f (restart-test-function restart)))

+ (when (if f (funcall f condition) t)

+ (mapc (lambda (x)

+ (when (eq (pop x) restart)

+ (if (if condition (eq x condition) t)

+ (return-from condition-pass t)

+ (setq b (or b x))))) *restarts*)

+ (not b)))

+

+(defvar *kcl-top-restarts* nil)

+

+(defun make-kcl-top-restart (quit-tag)

+ (make-restart :name 'gcl-top-restart

+ :function (lambda () (throw (car (list quit-tag)) quit-tag))

+ :report-function

+ (lambda (stream)

+ (let ((b-l (if (eq quit-tag si::*quit-tag*)

+ si::*break-level*

+ (car (or (find quit-tag si::*quit-tags*

+ :key #'cdr)

+ '(:not-found))))))

+ (cond ((eq b-l :not-found)

+ (format stream "Return to ? level."))

+ ((null b-l)

+ (format stream "Return to top level."))

+ (t

+ (format stream "Return to break level ~D."

+ (length b-l))))))))

+

+(defun find-kcl-top-restart (quit-tag)

+ (cdr (or (assoc quit-tag *kcl-top-restarts*)

+ (car (push (cons quit-tag (make-kcl-top-restart quit-tag))

+ *kcl-top-restarts*)))))

+

+(defun kcl-top-restarts ()

+ (let* (;(old-tags (ldiff si::*quit-tags* (member nil si::*quit-tags* :key 'cdr)))

+ (old-tags si::*quit-tags*)

+ (old-tags (mapcan (lambda (e) (when (cdr e) (list (cdr e)))) old-tags))

+ (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags))

+ (restarts (mapcar 'find-kcl-top-restart tags)))

+ (setq *kcl-top-restarts* (mapcar 'cons tags restarts))

+ restarts))

+

+(defun compute-restarts (&optional condition)

+ (remove-if-not (lambda (x) (condition-pass condition x)) (remove-duplicates (nconc (mapcar 'car *restarts*) (kcl-top-restarts)))))

+

+(defun find-restart (name &optional condition &aux (sn (symbolp name)))

+ (car (member name (compute-restarts condition) :key (lambda (x) (if sn (restart-name x) x)))))

+

+(defun transform-keywords (&key report interactive test

+ &aux rr (report (if (stringp report) `(lambda (s) (write-string ,report s)) report)))

+ (macrolet ((do-setf (x)

+ `(when ,x

+ (setf (getf rr ,(intern (concatenate 'string (symbol-name x) "-FUNCTION") :keyword))

+ (list 'function ,x)))))

+ (do-setf report)

+ (do-setf interactive)

+ (do-setf test)

+ rr))

+

+(defun rewrite-restart-case-clause (r &aux (name (pop r))(ll (pop r)))

+ (labels ((l (r) (if (member (car r) '(:report :interactive :test)) (l (cddr r)) r)))

+ (let ((rd (l r)))

+ (list* name (gensym) (apply 'transform-keywords (ldiff r rd)) ll rd))))

+

+

+(defun restart-case-expression-condition (expression env c &aux (e (macroexpand expression env))(n (when (listp e) (pop e))))

+ (case n

+ (cerror (let ((ca (pop e))) `((process-error ,(pop e) (list ,@e)) (,n ,ca ,c))))

+ (error `((process-error ,(pop e) (list ,@e)) (,n ,c)))

+ (warn `((process-error ,(pop e) (list ,@e) 'simple-warning) (,n ,c)))

+ (signal `((coerce-to-condition ,(pop e) (list ,@e) 'simple-condition ',n) (,n ,c)))))

+

+

+(defmacro restart-case (expression &body clauses &environment env)

+ (declare (optimize (safety 2)))

+ (let* ((block-tag (gensym))(args (gensym))(c (gensym))

+ (data (mapcar 'rewrite-restart-case-clause clauses))

+ (e (restart-case-expression-condition expression env c)))

+ `(block

+ ,block-tag

+ (let* (,args (,c ,(car e)) (*restart-condition* ,c))

+ (tagbody

+ (restart-bind

+ ,(mapcar (lambda (x) `(,(pop x) (lambda (&rest r) (setq ,args r) (go ,(pop x))) ,@(pop x))) data)

+ (return-from ,block-tag ,(or (cadr e) expression)))

+ ,@(mapcan (lambda (x &aux (x (cdr x)))

+ `(,(pop x) (return-from ,block-tag (apply (lambda ,(progn (pop x)(pop x)) ,@x) ,args)))) data))))))

+

+

+(defvar *unique-id-table* (make-hash-table))

+(defvar *unique-id-count* -1)

+

+(defun unique-id (obj)

+ "generates a unique integer id for its argument."

+ (or (gethash obj *unique-id-table*)

+ (setf (gethash obj *unique-id-table*) (incf *unique-id-count*))))

+

+(defun restart-print (restart stream depth)

+ (declare (ignore depth))

+ (if *print-escape*

+ (format stream "#<~s.~d>" (type-of restart) (unique-id restart))

+ (restart-report restart stream)))

+

+(defstruct (restart (:print-function restart-print))

+ name

+ function

+ report-function

+ interactive-function

+ (test-function (lambda (c) (declare (ignore c)) t)))

+

+(defun restart-report (restart stream &aux (f (restart-report-function restart)))

+ (if f (funcall f stream)

+ (format stream "~s" (or (restart-name restart) restart))))

+

+(defun invoke-restart (restart &rest values)

+ (let ((real-restart (or (find-restart restart)

+ (error 'control-error :format-control "restart ~s is not active." :format-arguments (list restart)))))

+ (apply (restart-function real-restart) values)))

+

+(defun invoke-restart-interactively (restart)

+ (let ((real-restart (or (find-restart restart)

+ (error "restart ~s is not active." restart))))

+ (apply (restart-function real-restart)

+ (let ((interactive-function (restart-interactive-function real-restart)))

+ (when interactive-function

+ (funcall interactive-function))))))

+

+

+(defmacro with-simple-restart ((restart-name format-control &rest format-arguments)

+ &body forms)

+ (declare (optimize (safety 1)))

+ `(restart-case (progn ,@forms)

+ (,restart-name nil

+ :report (lambda (stream) (format stream ,format-control ,@format-arguments))

+ (values nil t))))

+

+(defun abort (&optional condition)

+ "Transfers control to a restart named abort, signalling a control-error if

+ none exists."

+ (invoke-restart (find-restart 'abort condition))

+ (error 'abort-failure))

+

+

+(defun muffle-warning (&optional condition)

+ "Transfers control to a restart named muffle-warning, signalling a

+ control-error if none exists."

+ (invoke-restart (find-restart 'muffle-warning condition)))

+

+(macrolet ((define-nil-returning-restart (name args doc)

+ (let ((restart (gensym)))

+ `(defun ,name (,@args &optional condition)

+ ,doc

+ (declare (optimize (safety 1)))

+ (let ((,restart (find-restart ',name condition))) (when ,restart (invoke-restart ,restart ,@args)))))))

+

+ (define-nil-returning-restart continue nil

+ "Transfer control to a restart named continue, returning nil if none exists.")

+

+ (define-nil-returning-restart store-value (value)

+ "Transfer control and value to a restart named store-value, returning nil if

+ none exists.")

+

+ (define-nil-returning-restart use-value (value)

+ "Transfer control and value to a restart named use-value, returning nil if

+ none exists."))

+

+(defun show-restarts (&aux (i 0))

+ (mapc (lambda (x)

+ (format t "~& ~4d ~a ~a ~%"

+ (incf i)

+ (cond ((eq x *debug-abort*) "(abort)") ((eq x *debug-continue*) "(continue)") (""))

+ x)) *debug-restarts*)

+ nil)

diff --git a/gcl/lsp/gcl_serror.lsp b/gcl/lsp/gcl_serror.lsp
index ddeec150a..aa2ae48f2 100755
--- a/gcl/lsp/gcl_serror.lsp
+++ b/gcl/lsp/gcl_serror.lsp

@@ -1,239 +1,285 @@

-;;; -*- Mode:Lisp; Package:SERROR; Base:10; Syntax:COMMON-LISP -*-

-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-;;; ;;;;;

-;;; Copyright (c) 1985,86 by William Schelter,University of Texas ;;;;;

-;;; All rights reserved ;;;;;

-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-;(require "SLOOP")

-(in-package "SERROR" :use '("SLOOP" "LISP"))

-;(export '(def-error-type cond-error cond-any-error condition-case

-; error-name error-string error-continue-string error-format-args

-; ) "SERROR")

-;(provide "SERROR")

-

-(export '(def-error-type cond-error cond-any-error condition-case

- error-name error-string error-continue-string error-format-args

- ) "SERROR")

-

-(eval-when (compile)

- (proclaim '(optimize (safety 2) (speed 2) (space 2))))

-

-;;do (require "SERROR")

-;;(use-package "SERROR")

-

-;;This file contains two error catching facilities. One based on

-;;catch and throw, and the other which may involve a closure. The

-;;latter can be more costly for frequently executed forms, but has

-;;the advantage that errors which match none of the conditions

-;;will go into the regular error handler at the point in the stack where

-;;the error occurred.

-

-;;First we set up an error catching for a common lisp

-;;whose primitive error handler is called si:universal-error-handler (eg kcl).

-;;Namely if *catch-error* is not nil then that means

-;;there is a (catch ':any-error somewhere up the stack.

-;;it is thrown to, along with the condition.

-;;At the that point if the condition matches that of

-;;the catch, it stops there,

-;;otherwise if *catch-error* is still not nil repeat

-;;Sample interface

-

-;(defun te (n m)

-; (cond-error (er) (hairy-arithmetic m n)

-; ((and (= 0 n) (= 0 m))(format t "Hairy arithmetic doesn't like m=0=n") 58)

-; ((eql (error-condition-name er) :wrong-type-args)(format t "Bonus for wrong args") 50)

-; ((symbolp n)(and (numberp (symbol-value n))(format t "Had to eval n") (te m (symbol-value n)))))

-

-

-

-;;if none of the cond clauses hold, then we signal a regular error using

-;;the system error handler , unless there are more *catch-error*'s up

-;;the stack. Major defect: If none of the conditions hold, we will have

-;;to signal our real error up at the topmost *catch-error* so losing the possibility

-;;of proceeding. The alternative is to some how get the tests down to where

-;;we want them, but that seems to mean consing a closure, and keeping a

-;;stack of them. This is getting a little fancy.

-;;don't know how to get back (and anyway we have unwound by throwing).

-;;Major advantages: If there is no error, no closures are consed, and

-;;should be reasonably fast.

-

-

-

-;;****** Very system dependent. Redefine main error handler ******

-(eval-when (load compile eval)

-#-kcl

-(defun si::universal-error-handler (&rest args)

- (format t "Calling orignal error handler ~a" args))

-

-(defvar *error-handler-function* 'si::universal-error-handler)

-(or (get *error-handler-function* :old-definition)

- (setf (get *error-handler-function* :old-definition)

- (symbol-function *error-handler-function*)))

-)

-

-(defstruct (error-condition :named (:conc-name error-))

- name

- string ;the format string given to error.

- function ;occurs inside here

- continue-string

- format-args

- error-handler-args)

-

-(defparameter *catch-error* nil "If t errors will throw to :any-error tag")

-(defparameter *disable-catch-error* nil "If t only regular error handler will be used")

-(defparameter *catch-error-stack* (make-array 30 :fill-pointer 0) "If t only regular error handler will be used")

-(defvar *show-all-debug-info* nil "Set to t if not

- running interactively")

-

-;;principal interfaces

-

-(defmacro cond-error (variables body-form &body clauses)

- "If a condition is signalled during evaluation of body-form, The first

-of VARIABLES is bound to the condition, and the clauses are evaluated

-like cond clauses. Note if the conditions involve lexical variables other than

-VARIABLES, there will be a new lexical closure cons'd each time through this!!

- eg:

- (cond-error (er) (1+ u)

- ((null u) (princ er) (princ \"null arg to u\"))

- ((symbolp u) (princ \"symbol arg\"))

- (t 0))"

-

- (or variables (setf variables '(ignore)))

- (let ((catch-tag (gensym "CATCH-TAG")))

- (let ((bod `((catch ',catch-tag

- (return-from cond-error-continue

- (unwind-protect

- (progn

- (vector-push-extend

- #'(lambda ,variables ,(car variables)

- (if (or ,@ (mapcar 'car clauses)) ',catch-tag))

- *catch-error-stack*)

- ,body-form)

- (incf (the fixnum (fill-pointer *catch-error-stack*))

- -1))))

- (cond ,@ clauses

- (t (format t "should not get here") )))))

- (cond (variables

- (setf bod

- ` (multiple-value-bind

- ,variables ,@ bod)))

- (t (setf bod (cons 'progn bod))))

- `(block cond-error-continue ,bod))))

-

-(defmacro cond-any-error (variables body-form &body clauses)

- "If a condition is signalled during evaluation of body-form, The first

-of VARIABLES is bound to the condition, and the clauses are evaluated

-like cond clauses, If the cond falls off the end, then the error is

-signaled at this point in the stack. For the moment the rest of the VARIABLES are ignored.

- eg:

- (cond-error (er) (1+ u)

- ((null u) (princ er) (princ \"null arg to u\"))

- ((symbolp u) (princ \"symbol arg\"))

- (t 0))"

-

- (let ((bod `(

- (let ((*catch-error* t))

- (catch ':any-error

- (return-from cond-error-continue ,body-form)))

- (cond ,@ clauses

- (t (inf-signal ,@ variables))))))

- (cond (variables

- (setf bod

- ` (multiple-value-bind

- ,variables ,@ bod)))

- (t (setf bod (cons 'progn bod))))

- `(block cond-error-continue ,bod)))

-

-(defvar *error-handler-args* nil)

-

-(defun #. (if (boundp '*error-handler-function*) *error-handler-function* 'joe)

- (&rest error-handler-args)

- ;; (when (equal error-handler-args *error-handler-args*)

- ;; (format t "Error handler called recursively ~S~%"

- ;; error-handler-args)

- ;; ;; FIXME

- ;; (return-from si::universal-error-handler nil))

- (let ((*error-handler-args* error-handler-args))

- (when *show-all-debug-info*

- (si::simple-backtrace)(si::backtrace) (si::break-vs))

- (let ((err (make-error-condition

- :name (car error-handler-args)

- :string (fifth error-handler-args)

- :function (third error-handler-args)

- :continue-string (fourth error-handler-args)

- :format-args

- (copy-list (nthcdr 5 error-handler-args))

- :error-handler-args (copy-list error-handler-args))))

- (cond (*catch-error* (throw :any-error err))

- ((let (flag) (do ((i 0 (the fixnum (1+ i)))

- (end (the fixnum(fill-pointer (the array

- *catch-error-stack*)))))

- ((>= i end))

- (declare (fixnum i end))

- (cond ((setq flag

- (funcall (aref *catch-error-stack* i)

- err))

- (throw flag err))))))

- (t (apply (get *error-handler-function* :old-definition)

- error-handler-args))))))

-

-(defun inf-signal (&rest error-handler-args)

- (apply *error-handler-function*

- (error-error-handler-args (car error-handler-args ))))

-

-#|Sample call

-(defun te (n)

- (cond-error (er) (progn (1+ n))

- ((null n) (print n) (print er) n)

- ((symbolp n) (print n))))

-|#

-

-(defmacro def-error-type (name (er) &body body)

- (let ((fname (intern (format nil "~a-tester" name))))

- `(eval-when (compile eval load)

- (defun ,fname (,er) ,@ body)

- (deftype ,name ()`(and error-condition (satisfies ,',fname))))))

-(def-error-type wta (er) (eql (error-name er) :wrong-type-arg))

-

-#|

-(def-error-type hi-error (er) (eql (error-string er) "hi"))

-;this matches error signaled by (error "hi") or (cerror x "hi" ..)

-;can use the above so that the user can put

-(cond-error (er ) (hairy-stuff)

- ((typep er 'wta) ...)

- ((typep er '(or hi-error joe)) ...)

-(defun te2 (n)

- (sloop for i below n with x = 0 declare (fixnum x)

- do (cond-any-error (er) (setq x i)

- (t (print "hi")))))

-|#

-;;In kcl cond-any-error is over 10 times as fast as cond-error, for the above.

-;;Note since t a clause we could have optimized to cond-any-error!!

-;;cond-error takes 1/1000 of second on sun 2

-;;cond-any-error takes 1/10000 of second. (assuming no error!).

-

-

-(def-error-type subscript-out-of-bounds (er)

- #+ti (member 'si::subscript-out-of-bounds (funcall er :condition-names))

- #+gcl(equal (error-string er) "The first index, ~S, to the array~%~S is too large.")) ;should collect all here

-(def-error-type ERROR (er) (eql (error-name er) :error))

-(def-error-type WRONG-TYPE-ARGUMENT (er) (eql (error-name er) :WRONG-TYPE-ARGUMENT))

-(def-error-type TOO-FEW-ARGUMENTS (er) (eql (error-name er) :TOO-FEW-ARGUMENTS))

-(def-error-type TOO-MANY-ARGUMENTS (er) (eql (error-name er) :TOO-MANY-ARGUMENTS))

-(def-error-type UNEXPECTED-KEYWORD (er) (eql (error-name er) :UNEXPECTED-KEYWORD))

-(def-error-type INVALID-FORM (er) (eql (error-name er) :INVALID-FORM))

-(def-error-type UNBOUND-VARIABLE (er) (eql (error-name er) :UNBOUND-VARIABLE))

-(def-error-type INVALID-VARIABLE (er) (eql (error-name er) :INVALID-VARIABLE))

-(def-error-type UNDEFINED-FUNCTION (er) (eql (error-name er) :UNDEFINED-FUNCTION))

-(def-error-type INVALID-FUNCTION (er) (eql (error-name er) :INVALID-FUNCTION))

-

-(defmacro condition-case (vars body-form &rest cases)

- (let ((er (car vars)))

- `(cond-error (,er) ,body-form

- ,@ (sloop for v in cases

- when (listp (car v))

- collecting `((typep ,er '(or ,@ (car v))),@ (cdr v))

- else

- collecting `((typep ,er ',(car v)),@ (cdr v))))))

-

-

+;; -*-Lisp-*-

+(in-package :lisp)

+

+(export '(simple-condition simple-error simple-warning invoke-debugger *debugger-hook* *break-on-signals*))

+

+(in-package :si)

+

+(macrolet

+ ((make-conditionp (condition &aux (n (intern (concatenate 'string (string condition) "P"))))

+ `(defun ,n (x &aux (z (si-find-class ',condition)))

+ (when z

+ (funcall (setf (symbol-function ',n) (lambda (x) (typep x z))) x))))

+ (make-condition-classp (class &aux (n (intern (concatenate 'string (string class) "-CLASS-P"))))

+ `(defun ,n (x &aux (s (si-find-class 'standard-class)) (z (si-find-class ',class)))

+ (when (and s z)

+ (funcall (setf (symbol-function ',n)

+ (lambda (x &aux (x (if (symbolp x) (si-find-class x) x)))

+ (when (typep x s)

+ (member z (si-class-precedence-list x))))) x)))))

+ (make-conditionp condition)

+ (make-conditionp warning)

+ (make-condition-classp condition)

+ (make-condition-classp simple-condition))

+

+

+(defun coerce-to-condition (datum arguments default-type function-name)

+ (cond ((conditionp datum)

+ (if arguments

+ (cerror "ignore the additional arguments."

+ 'simple-type-error

+ :datum arguments

+ :expected-type 'null

+ :format-control "you may not supply additional arguments ~

+ when giving ~s to ~s."

+ :format-arguments (list datum function-name)))

+ datum)

+ ((condition-class-p datum)

+ (apply #'make-condition datum arguments))

+ ((when (condition-class-p default-type) (or (stringp datum) (functionp datum)))

+ (make-condition default-type :format-control datum :format-arguments arguments))

+ ((coerce-to-string datum arguments))))

+

+(defvar *handler-clusters* nil)

+(defvar *break-on-signals* nil)

+

+(defun signal (datum &rest arguments)

+ (declare (optimize (safety 1)))

+ (let ((*handler-clusters* *handler-clusters*)

+ (condition (coerce-to-condition datum arguments 'simple-condition 'signal)))

+ (if (typep condition *break-on-signals*)

+ (break "~a~%break entered because of *break-on-signals*." condition))

+ (do nil ((not *handler-clusters*))

+ (dolist (handler (pop *handler-clusters*))

+ (when (typep condition (car handler))

+ (funcall (cdr handler) condition))))

+ nil))

+

+(defvar *debugger-hook* nil)

+(defvar *debug-level* 0)

+(defvar *debug-restarts* nil)

+(defvar *debug-abort* nil)

+(defvar *debug-continue* nil)

+(defvar *abort-restarts* nil)

+

+(defun break-level-invoke-restart (n)

+ (cond ((when (plusp n) (< n (+ (length *debug-restarts*) 1)))

+ (invoke-restart-interactively (nth (1- n) *debug-restarts*)))

+ ((format t "~&no such restart."))))

+

+(defun find-ihs (s i &optional (j i))

+ (cond ((eq (ihs-fname i) s) i)

+ ((and (> i 0) (find-ihs s (1- i) j)))

+ (j)))

+

+(defmacro without-interrupts (&rest forms)

+ `(let (*quit-tag* *quit-tags* *restarts*)

+ ,@forms))

+

+(defun process-args (args &optional fc fa others);FIXME do this without consing, could be oom

+ (cond ((not args) (nconc (nreverse others) (when (and fc fa) (list (apply 'format nil fc fa)))))

+ ((eq (car args) :format-control)

+ (process-args (cddr args) (cadr args) fa others))

+ ((eq (car args) :format-arguments)

+ (process-args (cddr args) fc (cadr args) others))

+ ((process-args (cdr args) fc fa (cons (car args) others)))))

+

+(defun coerce-to-string (datum args)

+ (cond ((stringp datum)

+ (if args

+ (let ((*print-pretty* nil)

+ (*print-level* *debug-print-level*)

+ (*print-length* *debug-print-level*)

+ (*print-case* :upcase))

+ (apply 'format nil datum args))

+ datum))

+ ((symbolp datum)

+ (let ((args (process-args args)))

+ (substitute

+ #\^ #\~

+ (coerce-to-string

+ (if args

+ (apply 'string-concatenate (cons datum (make-list (length args) :initial-element " ~s")))

+ (string datum))

+ args))))

+ ("unknown error")))

+

+(defun warn (datum &rest arguments)

+ (declare (optimize (safety 2)))

+ (let ((c (process-error datum arguments 'simple-warning)))

+ (check-type c (or string (satisfies warningp)) "a warning condition")

+ (when *break-on-warnings*

+ (break "~A~%break entered because of *break-on-warnings*." c))

+ (restart-case

+ (signal c)

+ (muffle-warning nil :report "Skip warning." (return-from warn nil)))

+ (format *error-output* "~&Warning: ~a~%" c)

+ nil))

+

+(dolist (l '(break cerror error universal-error-handler ihs-top get-sig-fn-name next-stack-frame check-type-symbol))

+ (setf (get l 'dbl-invisible) t))

+

+(defvar *sig-fn-name* nil)

+

+(defun get-sig-fn-name (&aux (p (ihs-top))(p (next-stack-frame p)))

+ (when p (ihs-fname p)))

+

+(defun process-error (datum args &optional (default-type 'simple-error))

+ (let ((internal (cond ((simple-condition-class-p datum)

+ (find-symbol (concatenate 'string "INTERNAL-" (string datum)) :conditions))

+ ((condition-class-p datum)

+ (find-symbol (concatenate 'string "INTERNAL-SIMPLE-" (string datum)) :conditions)))))

+ (coerce-to-condition (or internal datum) (if internal (list* :function-name *sig-fn-name* args) args) default-type 'process-error)))

+

+(defun universal-error-handler (n cp fn cs es &rest args &aux (*sig-fn-name* fn))

+ (declare (ignore es))

+ (if cp (apply #'cerror cs n args) (apply #'error n args)))

+

+(defun cerror (continue-string datum &rest args &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name))))

+ (values

+ (with-simple-restart

+ (continue continue-string args)

+ (apply #'error datum args))))

+(putprop 'cerror t 'compiler::cmp-notinline)

+

+

+(defun error (datum &rest args &aux (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name))))

+ (let ((c (process-error datum args))(q (or *quit-tag* +top-level-quit-tag+)))

+ (signal c)

+ (invoke-debugger c)

+ (throw q q)))

+(putprop 'error t 'compiler::cmp-notinline)

+

+

+(defun invoke-debugger (condition)

+

+ (when *debugger-hook*

+ (let ((hook *debugger-hook*) *debugger-hook*)

+ (funcall hook condition hook)))

+

+ (maybe-clear-input)

+

+ (let ((correctable (find-restart 'continue))

+ *print-pretty*

+ (*print-level* *debug-print-level*)

+ (*print-length* *debug-print-level*)

+ (*print-case* :upcase))

+ (terpri *error-output*)

+ (format *error-output* (if (and correctable *break-enable*) "~&Correctable error: " "~&Error: "))

+ (let ((*indent-formatted-output* t))

+ (when (stringp condition) (format *error-output* condition)))

+ (terpri *error-output*)

+ (if (> (length *link-array*) 0)

+ (format *error-output* "Fast links are on: do (si::use-fast-links nil) for debugging~%"))

+ (format *error-output* "Signalled by ~:@(~S~).~%" (or *sig-fn-name* "an anonymous function"))

+ (when (and correctable *break-enable*)

+ (format *error-output* "~&If continued: ")

+ (funcall (restart-report-function correctable) *error-output*))

+ (force-output *error-output*)

+ (break-level condition)))

+

+

+(defun dbl-eval (- &aux (break-command t))

+ (let ((val-list (multiple-value-list

+ (cond

+ ((keywordp -) (break-call - nil 'break-command))

+ ((and (consp -) (keywordp (car -))) (break-call (car -) (cdr -) 'break-command))

+ ((integerp -) (break-level-invoke-restart -))

+ (t (setq break-command nil) (evalhook - nil nil *break-env*))))))

+ (cons break-command val-list)))

+

+(defun do-break-level (at env p-e-p debug-level break-level &aux (first t))

+

+ (do nil (nil)

+

+ (unless

+ (with-simple-restart

+ (abort "Return to debug level ~D." debug-level)

+ (not

+ (catch 'step-continue

+ (let* ((*break-level* break-level)

+ (*break-enable* (unless p-e-p *break-enable*))

+ (*readtable* (or *break-readtable* *readtable*))

+ *break-env* *read-suppress*); *error-stack*)

+

+ (setq +++ ++ ++ + + -)

+

+ (when first

+ (catch-fatal 1)

+ (setq *interrupt-enable* t first nil)

+ (cond (p-e-p

+ (format *debug-io* "~&~A~2%" at)

+ (set-current)

+ (setq *no-prompt* nil)

+ (show-restarts))

+ ((set-back at env))))

+

+ (if *no-prompt*

+ (setq *no-prompt* nil)

+ (format *debug-io* "~&~a~a>~{~*>~}"

+ (if p-e-p "" "dbl:")

+ (if (eq *package* (find-package 'user)) "" (package-name *package*))

+ break-level))

+ (force-output *error-output*)

+

+ (setq - (dbl-read *debug-io* nil *top-eof*))

+ (when (eq - *top-eof*) (bye -1))

+ (let* ((ev (dbl-eval -))

+ (break-command (car ev))

+ (values (cdr ev)))

+ (and break-command (eq (car values) :resume)(return))

+ (setq /// // // / / values *** ** ** * * (car /))

+ (fresh-line *debug-io*)

+ (dolist (val /)

+ (prin1 val *debug-io*)

+ (terpri *debug-io*)))

+ nil))))

+ (terpri *debug-io*)

+ (break-current))))

+

+

+(defun break-level (at &optional env)

+ (let* ((p-e-p (unless (listp at) t))

+ (+ +) (++ ++) (+++ +++)

+ (- -)

+ (* *) (** **) (*** ***)

+ (/ /) (// //) (/// ///)

+ (break-level (if p-e-p (cons t *break-level*) *break-level*))

+ (debug-level *debug-level*)

+ (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))

+ *quit-tag*

+ (*ihs-base* (1+ *ihs-top*))

+ (*ihs-top* (ihs-top))

+ (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))

+ (*frs-top* (frs-top))

+ (*current-ihs* *ihs-top*)

+ (*debug-level* (1+ *debug-level*))

+ (*debug-restarts* (compute-restarts))

+ (*debug-abort* (find-restart 'abort))

+ (*debug-continue* (find-restart 'continue))

+ (*abort-restarts* (remove-if-not (lambda (x) (eq 'abort (restart-name x))) *debug-restarts*)))

+

+ (do-break-level at env p-e-p debug-level break-level)))

+

+(putprop 'break-level t 'compiler::cmp-notinline)

+

+(defun break (&optional format-string &rest args &aux message (*sig-fn-name* (or *sig-fn-name* (get-sig-fn-name))))

+

+ (let ((*print-pretty* nil)

+ (*print-level* 4)

+ (*print-length* 4)

+ (*print-case* :upcase))

+ (terpri *error-output*)

+ (cond (format-string

+ (format *error-output* "~&Break: ")

+ (let ((*indent-formatted-output* t))

+ (apply 'format *error-output* format-string args))

+ (terpri *error-output*)

+ (setq message (apply 'format nil format-string args)))

+ (t (format *error-output* "~&Break.~%")

+ (setq message ""))))

+ (with-simple-restart

+ (continue "Return from break.")

+ (let ((*break-enable* t)) (break-level message)))

+ nil)

+(putprop 'break t 'compiler::cmp-notinline)

diff --git a/gcl/lsp/gcl_top.lsp b/gcl/lsp/gcl_top.lsp
index a321674b9..8bf417d4c 100755
--- a/gcl/lsp/gcl_top.lsp
+++ b/gcl/lsp/gcl_top.lsp

@@ -62,7 +62,8 @@

(defvar *load-types* '(".o" ".lsp" ".lisp"))

(defvar *lisp-initialized* nil)

-(defvar *quit-tag* (cons nil nil))

+(defconstant +top-level-quit-tag+ (cons nil nil))

+(defvar *quit-tag* +top-level-quit-tag+)

(defvar *quit-tags* nil)

(defvar *break-level* '())

(defvar *break-env* nil)

@@ -182,146 +183,8 @@

(t (read stream eof-error-p eof-value))))

-(defun break-level (at &optional env)

- (let* ((*break-message* (if (stringp at) at *break-message*))

- (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))

- (*quit-tag* (cons nil nil))

- (*break-level* (if (not at) *break-level* (cons t *break-level*)))

- (*ihs-base* (1+ *ihs-top*))

- (*ihs-top* (1- (ihs-top)))

- (*current-ihs* *ihs-top*)

- (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))

- (*frs-top* (frs-top))

- (*break-env* nil)

- (be *break-enable*)

- (*break-enable*

- (progn

- (if (stringp at) nil be)))

- ;(*standard-input* *terminal-io*)

- (*readtable* (or *break-readtable* *readtable*))

- (*read-suppress* nil)

- (+ +) (++ ++) (+++ +++)

- (- -)

- (* *) (** **) (*** ***)

- (/ /) (// //) (/// ///)

- )

- ; (terpri *error-output*)

- (unless (or be (not (stringp at)))

- (simple-backtrace)

- (break-quit (length (cdr *break-level*))))

- (catch-fatal 1)

- (setq *interrupt-enable* t)

- (cond ((stringp at) (set-current)(terpri *error-output*)

- (setq *no-prompt* nil)

- )

- (t (set-back at env)))

- (loop

- (setq +++ ++ ++ + + -)

- (cond (*no-prompt* (setq *no-prompt* nil))

- (t

- (format *debug-io* "~&~a~a>~{~*>~}"

- (if (stringp at) "" "dbl:")

- (if (eq *package* (find-package 'user)) ""

- (package-name *package*))

- *break-level*)))

- (force-output *error-output*)

- (when

- (catch 'step-continue

- (catch *quit-tag*

- (setq - (locally (declare (notinline read))

- (dbl-read *debug-io* nil *top-eof*)))

- (when (eq - *top-eof*) (bye -1))

- (let* ( break-command

- (values

- (multiple-value-list

- (LOCALLY (declare (notinline break-call evalhook))

- (if (keywordp -)(setq - (cons - nil)))

- (cond ((and (consp -) (keywordp (car -)))

- (setq break-command t)

- (break-call (car -) (cdr -) 'si::break-command))

- (t (evalhook - nil nil *break-env*)))))))

- (and break-command (eq (car values) :resume )(return))

- (setq /// // // / / values *** ** ** * * (car /))

- (fresh-line *debug-io*)

- (dolist (val /)

- (locally (declare (notinline prin1)) (prin1 val *debug-io*))

- (terpri *debug-io*)))

- nil))

- (terpri *debug-io*)

- (break-current))))))

-

(defvar *debug-print-level* 3)

-(defun warn (format-string &rest args)

- (let ((*print-level* 4)

- (*print-length* 4)

- (*print-case* :upcase))

- (cond (*break-on-warnings*

- (apply #'break format-string args))

- (t (format *error-output* "~&Warning: ")

- (let ((*indent-formatted-output* t))

- (apply #'format *error-output* format-string args))

- nil))))

-

-(defun universal-error-handler

- (error-name correctable function-name

- continue-format-string error-format-string

- &rest args &aux message)

- (declare (ignore error-name))

- (let ((*print-pretty* nil)

- (*print-level* *debug-print-level*)

- (*print-length* *debug-print-level*)

- (*print-case* :upcase))

- (terpri *error-output*)

- (cond ((and correctable *break-enable*)

- (format *error-output* "~&Correctable error: ")

- (let ((*indent-formatted-output* t))

- (apply 'format *error-output* error-format-string args))

- (terpri *error-output*)

- (setq message (apply 'format nil error-format-string args))

- (if function-name

- (format *error-output*

- "Signalled by ~:@(~S~).~%" function-name)

- (format *error-output*

- "Signalled by an anonymous function.~%"))

- (format *error-output* "~&If continued: ")

- (let ((*indent-formatted-output* t))

- (format *error-output* "~?~&" continue-format-string args))

- )

- (t

- (format *error-output* "~&Error: ")

- (let ((*indent-formatted-output* t))

- (apply 'format *error-output* error-format-string args))

- (terpri *error-output*)

- (if (> (length *link-array*) 0)

- (format *error-output* "Fast links are on: do (si::use-fast-links nil) for debugging~%"))

- (setq message (apply 'format nil error-format-string args))

- (if function-name

- (format *error-output*

- "Error signalled by ~:@(~S~).~%" function-name)

- (format *error-output*

- "Error signalled by an anonymous function.~%")))))

- (force-output *error-output*)

- (break-level message)

- (unless correctable (throw *quit-tag* *quit-tag*)))

-

-(defun break (&optional format-string &rest args &aux message)

- (let ((*print-pretty* nil)

- (*print-level* 4)

- (*print-length* 4)

- (*print-case* :upcase))

- (terpri *error-output*)

- (cond (format-string

- (format *error-output* "~&Break: ")

- (let ((*indent-formatted-output* t))

- (apply 'format *error-output* format-string args))

- (terpri *error-output*)

- (setq message (apply 'format nil format-string args)))

- (t (format *error-output* "~&Break.~%")

- (setq message ""))))

- (let ((*break-enable* t)) (break-level message))

- nil)

-

(defun terminal-interrupt (correctablep)

(let ((*break-enable* t))

(if correctablep

@@ -784,7 +647,3 @@ First directory is checked for first name and all extensions etc."

(read-file st))

(read-file *standard-input*))))

(bye 1))

-

-(defmacro without-interrupts (&rest forms)

- `(let (*quit-tag*)

- ,@forms))

diff --git a/gcl/lsp/makefile b/gcl/lsp/makefile
index 485bf912d..ad0b804da 100644
--- a/gcl/lsp/makefile
+++ b/gcl/lsp/makefile

@@ -14,7 +14,7 @@ OBJS = gcl_sharp.o gcl_arraylib.o gcl_assert.o gcl_defmacro.o gcl_defstruct.o \

gcl_iolib.o gcl_listlib.o gcl_mislib.o gcl_module.o gcl_numlib.o \

gcl_packlib.o gcl_predlib.o \

gcl_seq.o gcl_seqlib.o gcl_setf.o gcl_top.o gcl_trace.o gcl_sloop.o \

- gcl_debug.o gcl_info.o gcl_serror.o \

+ gcl_debug.o gcl_info.o gcl_serror.o gcl_restart.o \

gcl_destructuring_bind.o gcl_defpackage.o gcl_make_defpackage.o gcl_loop.o $(EXTRA_LOBJS)

# export.o autoload.o auto_new.o

diff --git a/gcl/o/file.d b/gcl/o/file.d
index c3b4fcf58..604988575 100755
--- a/gcl/o/file.d
+++ b/gcl/o/file.d

@@ -1984,6 +1984,10 @@ FFN(siLget_string_input_stream_index)()

vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0]));

}

+DEFUN_NEW("TERMINAL-INPUT-STREAM-P",object,fSterminal_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {

+ RETURN1(type_of(x)==t_stream && x->sm.sm_mode==smm_input && x->sm.sm_fp && isatty(fileno(x->sm.sm_fp)) ? Ct : Cnil);

+}

+

LFD(siLmake_string_output_stream_from_string)()

{

object strng, strm;

diff --git a/gcl/unixport/sys_ansi_gcl.c b/gcl/unixport/sys_ansi_gcl.c
index b32582ea1..49364c2bb 100644
--- a/gcl/unixport/sys_ansi_gcl.c
+++ b/gcl/unixport/sys_ansi_gcl.c

@@ -32,6 +32,7 @@ gcl_init_system(object no_init)

ar_check_init(gcl_arraylib,no_init);

ar_check_init(gcl_assert,no_init);

ar_check_init(gcl_defstruct,no_init);

+ ar_check_init(gcl_restart,no_init);

ar_check_init(gcl_describe,no_init);

#ifdef HAVE_JAPI_H

ar_check_init(gcl_japi,no_init);

@@ -138,15 +139,9 @@ gcl_init_system(object no_init)

ar_check_init(gcl_pcl_precom2,no_init);

ar_check_init(gcl_clcs_precom,no_init);

- ar_check_init(gcl_clcs_macros,no_init);

- ar_check_init(gcl_clcs_restart,no_init);

ar_check_init(gcl_clcs_handler,no_init);

- ar_check_init(gcl_clcs_debugger,no_init);

ar_check_init(gcl_clcs_conditions,no_init);

ar_check_init(gcl_clcs_condition_definitions,no_init);

- ar_check_init(gcl_clcs_kcl_cond,no_init);

- ar_check_init(gcl_clcs_top_patches,no_init);

- ar_check_init(gcl_clcs_install,no_init);

}

diff --git a/gcl/unixport/sys_gcl.c b/gcl/unixport/sys_gcl.c
index ce53a09ab..67c71f9c2 100755
--- a/gcl/unixport/sys_gcl.c
+++ b/gcl/unixport/sys_gcl.c

@@ -29,6 +29,7 @@ gcl_init_system(object no_init) {

ar_check_init(gcl_setf,no_init);

ar_check_init(gcl_assert,no_init);

ar_check_init(gcl_defstruct,no_init);

+ ar_check_init(gcl_restart,no_init);

ar_check_init(gcl_describe,no_init);

#ifdef HAVE_JAPI_H

ar_check_init(gcl_japi,no_init);

diff --git a/gcl/unixport/sys_pcl_gcl.c b/gcl/unixport/sys_pcl_gcl.c
index 0103928b0..3c809f0e1 100644
--- a/gcl/unixport/sys_pcl_gcl.c
+++ b/gcl/unixport/sys_pcl_gcl.c

@@ -32,6 +32,7 @@ gcl_init_system(object no_init)

ar_check_init(gcl_arraylib,no_init);

ar_check_init(gcl_assert,no_init);

ar_check_init(gcl_defstruct,no_init);

+ ar_check_init(gcl_restart,no_init);

ar_check_init(gcl_describe,no_init);

#ifdef HAVE_JAPI_H

ar_check_init(gcl_japi,no_init);

diff --git a/gcl/unixport/sys_pre_gcl.c b/gcl/unixport/sys_pre_gcl.c
index e7eb8919c..cad70b7de 100755
--- a/gcl/unixport/sys_pre_gcl.c
+++ b/gcl/unixport/sys_pre_gcl.c

@@ -30,6 +30,7 @@ gcl_init_system(object no_init)

lsp_init("../lsp/gcl_arraylib.lsp");

lsp_init("../lsp/gcl_assert.lsp");

lsp_init("../lsp/gcl_defstruct.lsp");

+ lsp_init("../lsp/gcl_restart.lsp");

lsp_init("../lsp/gcl_describe.lsp");

#ifdef HAVE_JAPI_H

lsp_init("../lsp/gcl_japi.lsp");