Bug#768469: closed by Jonathan Wiltshire <jmw@debian.org> (Re: Bug#768469: unblock: gcl/2.6.12-1)
Greetings! I humbly ask you to reconsider, especially in light of the
fact that the package tracking webpages and quality assurance webpages
did not post this migration time change, and still reported the 5 days
(and in fact still do). This situation is legitimately confusing, and
letting packages in within a five day window of 11-5 when uploaded with
this understanding will strengthen the release and project.
As a developer with about 20 years of service to the project, and who
has maintained many complicated core scientific libraries and packages
over the years, and who in fact maintains gcl upstream as well, I assure
you that allowing this migration will not introduce any new release
complications, and will improve the quality of the release.
Take care,
owner@bugs.debian.org (Debian Bug Tracking System) writes:
> This is an automatic notification regarding your Bug report
> which was filed against the release.debian.org package:
>
> #768469: unblock: gcl/2.6.12-1
>
> It has been closed by Jonathan Wiltshire <jmw@debian.org>.
>
> Their explanation is attached below along with your original report.
> If this explanation is unsatisfactory and you have not received a
> better one in a separate message then please contact Jonathan Wiltshire <jmw@debian.org> by
> replying to this email.
>
>
> --
> 768469: http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=768469
> Debian Bug Tracking System
> Contact owner@bugs.debian.org with problems
>
> From: Jonathan Wiltshire <jmw@debian.org>
> Subject: Re: Bug#768469: unblock: gcl/2.6.12-1
> To: Camm Maguire <camm@maguirefamily.org>, 768469-done@bugs.debian.org
> Date: Fri, 07 Nov 2014 15:47:21 +0000
>
> Control: tag -1 wontfix
>
> On 2014-11-07 15:34, Camm Maguire wrote:
>> gcl's latest official upstream release was uploaded on 10-28,
>> completed the final autobuild (mips) on 11-2, needed 5 days, yet
>> (mysteriously) did not migrate during the final run on 11-5.
>
> It wasn't really very mysterious:
>
> https://lists.debian.org/debian-devel-announce/2013/12/msg00008.html
> https://lists.debian.org/debian-devel-announce/2014/05/msg00000.html
> https://lists.debian.org/debian-devel-announce/2014/07/msg00002.html
> https://lists.debian.org/debian-devel-announce/2014/09/msg00002.html
> https://lists.debian.org/debian-devel-announce/2014/10/msg00001.html
>
> so no, I'm afraid I'm not very sympathetic to this being "outside your
> control".
>
> --
> Jonathan Wiltshire jmw@debian.org
> Debian Developer http://people.debian.org/~jmw
>
> 4096R: 0xD3524C51 / 0A55 B7C5 1223 3942 86EC 74C3 5394 479D D352 4C51
>
> <directhex> i have six years of solaris sysadmin experience, from
> 8->10. i am well qualified to say it is made from bonghits
> layered on top of bonghits
> ----------
>
> From: Camm Maguire <camm@maguirefamily.org>
> Subject: unblock: gcl/2.6.12-1
> To: submit@bugs.debian.org
> Date: Fri, 07 Nov 2014 10:34:24 -0500
>
> Package: release.debian.org
> User: release.debian.org@packages.debian.org
> Usertags: unblock
> Severity: normal
>
> Please unblock package gcl
>
> Primarily, I write in response to the final sentence of
> https://release.debian.org/jessie/freeze_policy.html:
>
> "For packages which missed the freeze only for reasons outside of the
> control of the maintainers, we might be generous, but you need to
> contact us on your own, and you need to contact us soon."
>
> gcl's latest official upstream release was uploaded on 10-28,
> completed the final autobuild (mips) on 11-2, needed 5 days, yet
> (mysteriously) did not migrate during the final run on 11-5.
>
> This release has undergone massive testing, primarily against acl2
> with the heavy involvement of their upstream development team, and
> includes important new tools used by them for the most computationally
> intensive logic verification jobs. It would be a shame for all that
> work to wait for another two years due to some automigration mishap at
> the very end.
>
> The diffs between the testing version 2.6.11-3 and unstable 2.6.12-1
> are conceptually small, yet in addition to the above new acl2 support
> resolve many unfiled bugs, including segfault trapping, SIGINT
> handling, SIGBUS on personality-resetting execve, and the inclusion of
> aarch and ppc64el reloc support for gcc flag combinations used by
> Fedora, but not currently (though possibly in the future) by Debian.
> The diff is enlarged by the removal of a considerable amount of dead
> code.
>
> Here is the git log corresponding to the diff:
> =============================================================================
> * Version_2_6_12pre5 81243954 compiler::*warn-on-multiple-fn-definitions* to suppress proclaim conflicts
> * sion_2_6_12pre@{1} ae79ba57 fix signed integer comparison error in values error reporting
> * sion_2_6_12pre@{2} a4f5945f get full self path before unrandomize to robustify exec
> * sion_2_6_12pre@{3} 0cfb8135 start debug levels at 1
> * sion_2_6_12pre@{4} ea4cd453 print package prefixes in sys-proclaim.lisp
> * sion_2_6_12pre@{5} 9a75717d break dbl-backtrace loop on nil ihs from next-stack-frame
> * sion_2_6_12pre@{6} 3697c6ea allow multiple segfault catches in segmentation_catcher
> * sion_2_6_12pre@{7} dc2f2cf4 fix process-args for nil format-arguments
> * sion_2_6_12pre@{8} e5ac5548 export ansi error symbols to cltl1, removing segfault in error
> * Version_2_6_12pre4 3808d312 lintian for mac
> * ion_2_6_12pre@{10} 267eb082 break-resume
> * ------------------ 3bbe2bdb unknown reloc diagnostic output for elf
> * ------------------ a9f1cd0a fedora aarch64 relocs
> * ------------------ 6293a1de cast for mingw fileno
> * Version_2_6_12pre3 fa7b99fc move errors used in C code to cltl1
> * ------------------ 65a13a38 remove noise from assert, fix etypecase
> * ------------------ 4f1c2c4b update lsp and cmpnew sys-proclaims
> * ------------------ 4820e304 use building lisp to make sys-proclaim.lisp
> * ------------------ 0057c7c5 export all conditions symbols in gcl_export.lsp
> * ------------------ 10a57756 eliminate serror package from pcl/sys-package.lisp
> * ------------------ d625f9a4 more specific-error removals
> * ------------------ 1c7fc44d eliminate serror package
> * ------------------ c9002162 update sys-proclaims
> * ------------------ 7df1a6d0 compiler lintian fixes
> * ------------------ 1e5300c7 eliminate specific-error
> * ------------------ 93c74942 C code error semantics from master, centralize on Icall_gen_error_handler
> * ------------------ 930da895 one ansi-compat version of case macros in cltl1
> * ------------------ 6c7245ae clcs cleanup, centralize lisp errors in gcl_serror, move restart to cltl1
> * ------------------ d611e413 collect interpreted function statistic in si::*link-list*
> * ------------------ b4ec1143 include limits.h in mingw.h to get PATH_MAX (fixme)
> =============================================================================
>
> And here is the diff itself:
>
> =============================================================================
> diff -ruN t1/gcl-2.6.11/ t2/gcl-2.6.12/|filterdiff --exclude='*/sys-proclaim.lisp' --exclude='*/debian/patches/*' --exclude='*/configure' --exclude='*/sys-package.lisp' --exclude='*/.pc/*'
> diff -ruN t1/gcl-2.6.11/clcs/gcl_clcs_condition_definitions.lisp t2/gcl-2.6.12/clcs/gcl_clcs_condition_definitions.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_condition_definitions.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_condition_definitions.lisp 2014-10-23 17:29:00.000000000 -0400
> @@ -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)))
> -
> -(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) ())
> + ((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 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)))
> + nil
> + (:report ("Unbound variable: ")))
>
> -(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))
> +(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 abort-failure (control-error) () (:report "~%Abort failed."))
> +(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) 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-simple-condition (internal-condition simple-condition) nil)
>
> -(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-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)
>
> -(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) ())
> -
> -(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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_conditions.lisp t2/gcl-2.6.12/clcs/gcl_clcs_conditions.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_conditions.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_conditions.lisp 2014-10-23 17:29:00.000000000 -0400
> @@ -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)))))
> -
> -(defun conditionp (object)
> - (typep object 'condition))
> -
> -(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)
> -
> -(defvar *condition-class* (find-class '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 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))
> + (define-condition condition nil nil))
>
> +(defmethod pcl::make-load-form ((object condition) &optional env)
> + (declare (ignore env))
> + (error "~@<default ~s method for ~s called.~@>" 'pcl::make-load-form object))
> +
> +(mapc 'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject)))
> +
> +(defun conditionp (object) (typep object 'condition))
> +
> +(defun is-condition (x) (conditionp x))
> +(defun is-warning (x) (typep x 'warning))
> +
> +(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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_debugger.lisp t2/gcl-2.6.12/clcs/gcl_clcs_debugger.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_debugger.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_debugger.lisp 1969-12-31 19:00:00.000000000 -0500
> @@ -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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_handler.lisp t2/gcl-2.6.12/clcs/gcl_clcs_handler.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_handler.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_handler.lisp 2014-10-23 17:29:00.000000000 -0400
> @@ -1,141 +1,39 @@
> ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
>
> -(IN-PACKAGE "CONDITIONS")
> +(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))))
> +(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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_install.lisp t2/gcl-2.6.12/clcs/gcl_clcs_install.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_install.lisp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_install.lisp 1969-12-31 19:00:00.000000000 -0500
> @@ -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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_kcl_cond.lisp t2/gcl-2.6.12/clcs/gcl_clcs_kcl_cond.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_kcl_cond.lisp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_kcl_cond.lisp 1969-12-31 19:00:00.000000000 -0500
> @@ -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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_macros.lisp t2/gcl-2.6.12/clcs/gcl_clcs_macros.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_macros.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_macros.lisp 1969-12-31 19:00:00.000000000 -0500
> @@ -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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_restart.lisp t2/gcl-2.6.12/clcs/gcl_clcs_restart.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_restart.lisp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_restart.lisp 1969-12-31 19:00:00.000000000 -0500
> @@ -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 -ruN t1/gcl-2.6.11/clcs/gcl_clcs_top_patches.lisp t2/gcl-2.6.12/clcs/gcl_clcs_top_patches.lisp
> --- t1/gcl-2.6.11/clcs/gcl_clcs_top_patches.lisp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/clcs/gcl_clcs_top_patches.lisp 1969-12-31 19:00:00.000000000 -0500
> @@ -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 -ruN t1/gcl-2.6.11/clcs/myload.lisp t2/gcl-2.6.12/clcs/myload.lisp
> --- t1/gcl-2.6.11/clcs/myload.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/myload.lisp 2014-10-23 17:29:00.000000000 -0400
> @@ -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 -ruN t1/gcl-2.6.11/clcs/package.lisp t2/gcl-2.6.12/clcs/package.lisp
> --- t1/gcl-2.6.11/clcs/package.lisp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/clcs/package.lisp 2014-10-23 17:29:00.000000000 -0400
> @@ -12,36 +12,11 @@
> ;;; 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))
> +(import '(si::*handler-clusters* si::unique-id si::condition-class-p si::make-condition))
>
> -#+gcl
> -(EXPORT '(;; Shadowed symbols
> - BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE
> - CTYPECASE ECASE CCASE))
> -
> -(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))
> -
> -(DEFVAR *THIS-PACKAGE* (FIND-PACKAGE "CONDITIONS"))
> +(defvar *this-package* (find-package :conditions))
>
>
> diff -ruN t1/gcl-2.6.11/clcs/sys-proclaim.lisp t2/gcl-2.6.12/clcs/sys-proclaim.lisp
> diff -ruN t1/gcl-2.6.11/cmpnew/gcl_cmpcall.lsp t2/gcl-2.6.12/cmpnew/gcl_cmpcall.lsp
> --- t1/gcl-2.6.11/cmpnew/gcl_cmpcall.lsp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/cmpnew/gcl_cmpcall.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -164,7 +164,7 @@
> ))
>
>
> -(defun fcalln-inline (&rest args &aux (f (car args)) length)
> +(defun fcalln-inline (&rest args)
> (wt-nl "({object _f=" (car args) ";enum type _t=type_of(_f);")
> (wt-nl "_f = _t==t_symbol && _f->s.s_gfdef!=OBJNULL ? (_t=type_of(_f->s.s_gfdef),_f->s.s_gfdef) : _f;")
> (wt-nl "_t==t_sfun ? _f->sfn.sfn_self : ")
> @@ -384,11 +384,6 @@
> (pushnew link-info *function-links* :test 'equal)
> n))
>
> -(defun declaration-type (type)
> - (cond ((equal type "") "void")
> - ((equal type "long ") "object ")
> - (t type)))
> -
> ;;make a function which will be called hopefully only once,
> ;;and will establish the link.
> (defun wt-function-link (x)
> diff -ruN t1/gcl-2.6.11/cmpnew/gcl_collectfn.lsp t2/gcl-2.6.12/cmpnew/gcl_collectfn.lsp
> --- t1/gcl-2.6.11/cmpnew/gcl_collectfn.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/cmpnew/gcl_collectfn.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -194,6 +194,7 @@
> (defun make-proclaims ( &optional (st *standard-output*)
> &aux (ht (make-hash-table :test 'equal))
> *print-length* *print-level*
> + (si::*print-package* t)
> )
> ; (require "VLFUN"
> ; (concatenate 'string si::*system-directory*
> @@ -237,6 +238,8 @@
>
> (defvar *file-table* (make-hash-table :test 'eq))
>
> +(defvar *warn-on-multiple-fn-definitions* t)
> +
> (defun add-fn-data (lis &aux tem file)
> (let ((file (and (setq file (si::fp-input-stream *standard-input*))
> (truename file))))
> @@ -247,12 +250,12 @@
> (namestring file))))
> (setf (get (fn-name v) 'other-form) t)))
> (setf (gethash (fn-name v) *call-table*) v)
> - (if (setq tem (gethash (fn-name v) *file-table*))
> - (or (equal tem file)
> - (format t "~% Warn ~a redefined in ~a. Originally in ~a."
> - (fn-name v) file tem)))
> - (setf (gethash (fn-name v) *file-table*)
> - file))))
> + (when *warn-on-multiple-fn-definitions*
> + (when (setq tem (gethash (fn-name v) *file-table*))
> + (unless (equal tem file)
> + (warn 'simple-warning :format-control "~% ~a redefined in ~a. Originally in ~a."
> + :format-arguments (list (fn-name v) file tem)))))
> + (setf (gethash (fn-name v) *file-table*) file))))
>
> (defun dump-fn-data (&optional (file "fn-data.lsp")
> &aux (*package* (find-package "COMPILER"))
> diff -ruN t1/gcl-2.6.11/cmpnew/makefile t2/gcl-2.6.12/cmpnew/makefile
> --- t1/gcl-2.6.11/cmpnew/makefile 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/cmpnew/makefile 2014-10-23 17:29:00.000000000 -0400
> @@ -15,7 +15,8 @@
>
> FNS:= $(OBJS:.o=.fn)
>
> -COMPILE_FILE=$(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR) -system-p -c-file -data-file -h-file -compile
> +LISP=$(PORTDIR)/saved_pre_gcl$(EXE)
> +COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile
>
> %.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp
> $(COMPILE_FILE) $*
> @@ -23,7 +24,7 @@
> all: $(OBJS)
>
> .lsp.fn: ../cmpnew/gcl_collectfn.o
> - ../xbin/make-fn $*.lsp
> + ../xbin/make-fn $*.lsp $(LISP)
>
> fns1: $(FNS)
>
> diff -ruN t1/gcl-2.6.11/cmpnew/sys-proclaim.lisp t2/gcl-2.6.12/cmpnew/sys-proclaim.lisp
> diff -ruN t1/gcl-2.6.11/debian/changelog t2/gcl-2.6.12/debian/changelog
> --- t1/gcl-2.6.11/debian/changelog 2014-09-28 20:56:19.000000000 -0400
> +++ t2/gcl-2.6.12/debian/changelog 2014-10-28 09:56:15.000000000 -0400
> @@ -1,6 +1,30 @@
> +gcl (2.6.12-1) unstable; urgency=medium
> +
> + * New upstream release
> +
> + -- Camm Maguire <camm@debian.org> Tue, 28 Oct 2014 09:56:15 -0400
> +
> +gcl (2.6.11-6) unstable; urgency=medium
> +
> + * 2.6.12pre5
> +
> + -- Camm Maguire <camm@debian.org> Thu, 23 Oct 2014 17:33:22 -0400
> +
> +gcl (2.6.11-5) unstable; urgency=medium
> +
> + * 2.6.12pre4
> +
> + -- Camm Maguire <camm@debian.org> Sat, 18 Oct 2014 09:46:34 -0400
> +
> +gcl (2.6.11-4) unstable; urgency=medium
> +
> + * 2.6.12pre3
> +
> + -- Camm Maguire <camm@debian.org> Thu, 16 Oct 2014 11:56:15 -0400
> +
> gcl (2.6.11-3) unstable; urgency=medium
>
> - * 2.6.12pre1
> + * 2.6.12pre2
>
> -- Camm Maguire <camm@debian.org> Sun, 28 Sep 2014 20:56:18 -0400
>
> diff -ruN t1/gcl-2.6.11/debian/patches/2.6.12pre1 t2/gcl-2.6.12/debian/patches/2.6.12pre1
> diff -ruN t1/gcl-2.6.11/debian/patches/2.6.12pre2 t2/gcl-2.6.12/debian/patches/2.6.12pre2
> diff -ruN t1/gcl-2.6.11/debian/patches/series t2/gcl-2.6.12/debian/patches/series
> diff -ruN t1/gcl-2.6.11/h/386-macosx.h t2/gcl-2.6.12/h/386-macosx.h
> --- t1/gcl-2.6.11/h/386-macosx.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/386-macosx.h 2014-10-23 17:29:00.000000000 -0400
> @@ -193,3 +193,7 @@
> #define FPE_INIT ({ucontext_t v;list(3,MMcons(make_simple_string(({const char *s=FPE_RLST;s;})),REG_LIST(21,MC(__ss))), \
> REG_LIST(8,MCF(__fpu_stmm0)),REG_LIST(16,MCF(__fpu_xmm0)));})
>
> +
> +#include <sys/param.h>/*PATH_MAX MAXPATHLEN*/
> +#undef MIN
> +#undef MAX
> diff -ruN t1/gcl-2.6.11/h/att_ext.h t2/gcl-2.6.12/h/att_ext.h
> --- t1/gcl-2.6.11/h/att_ext.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/att_ext.h 2014-10-23 17:29:00.000000000 -0400
> @@ -129,6 +129,11 @@
> EXTER object sKinvalid_variable;
> EXTER object sKundefined_function;
> EXTER object sKinvalid_function;
> +EXTER object sKdatum;
> +EXTER object sKexpected_type;
> +EXTER object sKpackage;
> +EXTER object sKformat_control;
> +EXTER object sKformat_arguments;
> EXTER object sKpackage_error;
> object wrong_type_argument();
> EXTER object sSuniversal_error_handler;
> @@ -561,13 +566,13 @@
> EXTER object sLcommon,sLnull,sLcons,sLlist,sLsymbol,sLarray,sLvector,sLbit_vector,sLstring;
> EXTER object sLsequence,sLsimple_array,sLsimple_vector,sLsimple_bit_vector,sLsimple_string;
> EXTER object sLcompiled_function,sLpathname,sLcharacter,sLnumber,sLrational,sLfloat,sLstring_char;
> -EXTER object sLinteger,sLratio,sLshort_float,sLstandard_char,sLfixnum,sLpositive_fixnum, sLcomplex;
> +EXTER object sLinteger,sLreal,sLratio,sLshort_float,sLstandard_char,sLfixnum,sLpositive_fixnum, sLcomplex;
> EXTER object sLsingle_float,sLpackage,sLbignum,sLrandom_state,sLdouble_float,sLstream,sLbit,sLreadtable;
> EXTER object sLlong_float,sLhash_table,sLstructure,sLboolean;
> EXTER object sLdivision_by_zero,sLfloating_point_inexact,sLfloating_point_invalid_operation;
> EXTER object sLfloating_point_overflow,sLfloating_point_underflow;
>
> -#ifdef ANSI_COMMON_LISP
> +/* #ifdef ANSI_COMMON_LISP */
> /* new ansi types */
> EXTER object sLarithmetic_error,sLbase_char,sLbase_string,sLbroadcast_stream,sLbuilt_in_class;
> EXTER object sLcell_error,sLclass,sLconcatenated_stream,sLcondition,sLcontrol_error;
> @@ -579,7 +584,7 @@
> EXTER object sLstream_error,sLstring_stream,sLstructure_class,sLstyle_warning,sLsynonym_stream;
> EXTER object sLtwo_way_stream,sLtype_error,sLunbound_slot,sLunbound_variable,sLundefined_function,sLwarning;
> EXTER object sLmethod_combination,sLstructure_object;
> -#endif
> +/* #endif */
>
> EXTER object sLsatisfies;
> EXTER object sLmember;
> diff -ruN t1/gcl-2.6.11/h/compdefs.h t2/gcl-2.6.12/h/compdefs.h
> --- t1/gcl-2.6.11/h/compdefs.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/compdefs.h 2014-10-23 17:29:00.000000000 -0400
> @@ -112,3 +112,5 @@
> aset
> stp_ordinary
> SIGNED_CHAR(x)
> +FEerror(x,y...)
> +FEwrong_type_argument(x,y)
> diff -ruN t1/gcl-2.6.11/h/compprotos.h t2/gcl-2.6.12/h/compprotos.h
> --- t1/gcl-2.6.11/h/compprotos.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/compprotos.h 2014-10-23 17:29:00.000000000 -0400
> @@ -113,8 +113,6 @@
> void check_arg_failed (int);
> void check_other_key (object,int, ...);
> object elt_set(object,int,object);
> -void FEerror(char *,int,...);
> -void FEwrong_type_argument(object,object);
> void funcall(object);
> object getf(object,object,object);
> struct htent * gethash(object,object);
> @@ -179,3 +177,6 @@
> void gcl_init_or_load1(void (*)(void),const char *);
> char *gcl_gets(char *,int);
> int gcl_puts(const char *);
> +int endp_error(object);
> +object Icall_gen_error_handler(object,object,object,object,ufixnum,...);
> +
> diff -ruN t1/gcl-2.6.11/h/elf64_aarch64_reloc.h t2/gcl-2.6.12/h/elf64_aarch64_reloc.h
> --- t1/gcl-2.6.11/h/elf64_aarch64_reloc.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/elf64_aarch64_reloc.h 2014-10-23 17:29:00.000000000 -0400
> @@ -46,3 +46,12 @@
> case R_AARCH64_LDST128_ABS_LO12_NC: /* LD/ST128: (S+A) & 0xff0 */
> store_val(where,MASK(12) << 10,((s+a) & 0xff0) << 6);
> break;
> + case R_AARCH64_PREL64:
> + store_val(where,~0L,(s+a-p));
> + break;
> + case R_AARCH64_PREL32:
> + store_val(where,MASK(32),(s+a-p));
> + break;
> + case R_AARCH64_PREL16:
> + store_val(where,MASK(16),(s+a-p));
> + break;
> diff -ruN t1/gcl-2.6.11/h/error.h t2/gcl-2.6.12/h/error.h
> --- t1/gcl-2.6.11/h/error.h 1969-12-31 19:00:00.000000000 -0500
> +++ t2/gcl-2.6.12/h/error.h 2014-10-23 17:29:00.000000000 -0400
> @@ -0,0 +1,203 @@
> +#define Icall_error_handler(a_,b_,c_,d_...) \
> + Icall_gen_error_handler(Cnil,null_string,a_,b_,c_,##d_)
> +#define Icall_continue_error_handler(a_,b_,c_,d_,e_...) \
> + Icall_gen_error_handler(Ct,a_,b_,c_,d_,##e_)
> +
> +
> +extern enum type t_vtype;
> +extern int vtypep_fn(object);
> +extern void Check_type(object *,int (*)(object),object);
> +
> +
> +#ifdef IN_MAIN
> +#define PFN(a_) int Join(a_,_fn)(object x) {return a_(x);}
> +#else
> +#define PFN(a_) extern int Join(a_,_fn)(object x);
> +#endif
> +PFN(integerp)
> +PFN(non_negative_integerp)
> +PFN(rationalp)
> +PFN(floatp)
> +PFN(realp)
> +PFN(numberp)
> +PFN(characterp)
> +PFN(symbolp)
> +PFN(stringp)
> +PFN(string_symbolp)
> +PFN(packagep)
> +PFN(consp)
> +PFN(listp)
> +PFN(streamp)
> +PFN(pathname_string_symbolp)
> +PFN(pathname_string_symbol_streamp)
> +PFN(randomp)
> +PFN(hashtablep)
> +PFN(arrayp)
> +PFN(vectorp)
> +PFN(readtablep)
> +PFN(functionp)
> +
> +#define TPE(a_,b_,c_) if (!(b_)(*(a_))) FEwrong_type_argument((c_),*(a_))
> +
> +#define check_type(a_,b_) ({t_vtype=(b_);TPE(&a_,vtypep_fn,type_name(t_vtype));})
> +#define check_type_function(a_) TPE(a_,functionp_fn,sLfunction)
> +#define check_type_integer(a_) TPE(a_,integerp_fn,sLinteger)
> +#define check_type_non_negative_integer(a_) TPE(a_,non_negative_integerp_fn,TSnon_negative_integer)
> +#define check_type_rational(a_) TPE(a_,rationalp_fn,sLrational)
> +#define check_type_float(a_) TPE(a_,floatp_fn,sLfloat)
> +#define check_type_real(a_) TPE(a_,realp_fn,sLreal)
> +#define check_type_or_rational_float(a_) TPE(a_,realp_fn,sLreal)
> +#define check_type_number(a_) TPE(a_,numberp_fn,sLnumber)
> +#define check_type_stream(a_) TPE(a_,streamp_fn,sLstream)
> +#define check_type_hash_table(a_) TPE(a_,hashtablep_fn,sLhash_table)
> +#define check_type_character(a_) TPE(a_,characterp_fn,sLcharacter)
> +#define check_type_sym(a_) TPE(a_,symbolp_fn,sLsymbol)
> +#define check_type_string(a_) TPE(a_,stringp_fn,sLstring)
> +#define check_type_or_string_symbol(a_) TPE(a_,string_symbolp_fn,TSor_symbol_string)
> +#define check_type_or_symbol_string(a_) TPE(a_,string_symbolp_fn,TSor_symbol_string)
> +#define check_type_or_pathname_string_symbol_stream(a_) TPE(a_,pathname_string_symbol_streamp_fn,TSor_pathname_string_symbol_stream)
> +#define check_type_or_Pathname_string_symbol(a_) TPE(a_,pathname_string_symbolp_fn,TSor_pathname_string_symbol)
> +#define check_type_package(a_) TPE(a_,packagep_fn,sLpackage)
> +#define check_type_cons(a_) TPE(a_,consp_fn,sLcons)
> +#define check_type_list(a_) TPE(a_,listp_fn,sLlist)
> +#define check_type_stream(a_) TPE(a_,streamp_fn,sLstream)
> +#define check_type_array(a_) TPE(a_,arrayp_fn,sLarray)
> +#define check_type_vector(a_) TPE(a_,vectorp_fn,sLvector)
> +#define check_type_readtable_no_default(a_) TPE(a_,readtablep_fn,sLreadtable)
> +#define check_type_readtable(a_) ({if (*(a_)==Cnil) *(a_)=standard_readtable;TPE(a_,readtablep_fn,sLreadtable);})
> +#define check_type_random_state(a_) TPE(a_,randomp_fn,sLrandom_state)
> +
> +#define stack_string(a_,b_) struct string _s={0};\
> + object a_=(object)&_s;\
> + set_type_of((a_),t_string);\
> + (a_)->st.st_self=(void *)(b_);\
> + (a_)->st.st_dim=(a_)->st.st_fillp=strlen(b_)
> +
> +#define stack_fixnum(a_,b_) struct fixnum_struct _s={0};\
> + object a_;\
> + if (is_imm_fix(b_)) (a_)=make_fixnum(b_); else {\
> + (a_)=(object)&_s;\
> + set_type_of((a_),t_fixnum);\
> + (a_)->FIX.FIXVAL=(b_);}
> +
> +/*FIXME the stack stuff is dangerous It works for error handling, but
> + simple errors may evan pass the format tring up the stack as a slot
> + in ansi*/
> +/* #define TYPE_ERROR(a_,b_) {stack_string(tp_err,"~S is not of type ~S.");\ */
> +/* Icall_error_handler(sKwrong_type_argument,tp_err,2,(a_),(b_));} */
> +
> +object ihs_top_function_name(ihs_ptr h);
> +#define FEerror(a_,b_...) Icall_error_handler(sLerror,null_string,\
> + 4,sKformat_control,make_simple_string(a_),sKformat_arguments,list(b_))
> +#define CEerror(a_,b_,c_...) Icall_continue_error_handler(make_simple_string(a_),sLerror,null_string,\
> + 4,sKformat_control,make_simple_string(b_),sKformat_arguments,list(c_))
> +
> +#define TYPE_ERROR(a_,b_) Icall_error_handler(sLtype_error,null_string,\
> + 4,sKdatum,(a_),sKexpected_type,(b_))
> +#define FEwrong_type_argument(a_,b_) TYPE_ERROR(b_,a_)
> +#define FEcannot_coerce(a_,b_) TYPE_ERROR(b_,a_)
> +#define FEinvalid_function(a_) TYPE_ERROR(a_,sLfunction)
> +
> +#define CONTROL_ERROR(a_) Icall_error_handler(sLcontrol_error,null_string,4,sKformat_control,make_simple_string(a_),sKformat_arguments,Cnil)
> +
> +#define PROGRAM_ERROR(a_,b_) Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string(a_),sKformat_arguments,list(1,(b_)))
> +#define FEtoo_few_arguments(a_,b_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string("~S [or a callee] requires more than ~R argument~:p."),\
> + sKformat_arguments,list(2,ihs_top_function_name(ihs_top),make_fixnum((b_)-(a_))))
> +#define FEwrong_no_args(a_,b_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string(a_),\
> + sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(b_)))
> +#define FEtoo_few_argumentsF(a_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string("Too few arguments."),\
> + sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_)))
> +
> +#define FEtoo_many_arguments(a_,b_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string("~S [or a callee] requires less than ~R argument~:p."),\
> + sKformat_arguments,list(2,ihs_top_function_name(ihs_top),make_fixnum((b_)-(a_))))
> +#define FEtoo_many_argumentsF(a_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string("Too many arguments."),\
> + sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_)))
> +#define FEinvalid_macro_call() \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string("Invalid macro call to ~S."),\
> + sKformat_arguments,list(1,ihs_top_function_name(ihs_top)))
> +#define FEunexpected_keyword(a_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string("~S does not allow the keyword ~S."),\
> + sKformat_arguments,list(2,ihs_top_function_name(ihs_top),(a_)))
> +#define FEinvalid_form(a_,b_) \
> + Icall_error_handler(sLprogram_error,null_string,4,\
> + sKformat_control,make_simple_string(a_),\
> + sKformat_arguments,list(1,(b_)))
> +#define FEinvalid_variable(a_,b_) FEinvalid_form(a_,b_)
> +
> +#define PARSE_ERROR(a_) Icall_error_handler(sLparse_error,null_string,4,\
> + sKformat_control,make_simple_string(a_),sKformat_arguments,Cnil)
> +#define STREAM_ERROR(a_,b_) Icall_error_handler(sLstream_error,null_string,6,\
> + sKstream,a_,\
> + sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)
> +#define READER_ERROR(a_,b_) Icall_error_handler(sLreader_error,null_string,6,\
> + sKstream,a_,\
> + sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)
> +#define FILE_ERROR(a_,b_) Icall_error_handler(sLfile_error,null_string,6,\
> + sKpathname,a_,\
> + sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)
> +#define END_OF_FILE(a_) Icall_error_handler(sLend_of_file,null_string,2,sKstream,a_)
> +#define PACKAGE_ERROR(a_,b_) Icall_error_handler(sLpackage_error,null_string,6,\
> + sKpackage,a_,\
> + sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)
> +#define FEpackage_error(a_,b_) PACKAGE_ERROR(a_,b_)
> +#define PACKAGE_CERROR(a_,b_,c_,d_...) \
> + Icall_continue_error_handler(make_simple_string(b_),\
> + sLpackage_error,null_string,6,\
> + sKpackage,a_,\
> + sKformat_control,make_simple_string(c_),sKformat_arguments,list(d_))
> +#define NEW_INPUT(a_) (a_)=Ieval1(read_object(sLAstandard_inputA->s.s_dbind))
> +
> +
> +#define CELL_ERROR(a_,b_) Icall_error_handler(sLcell_error,null_string,6,\
> + sKname,a_,\
> + sKformat_control,make_simple_string(b_),sKformat_arguments,Cnil)
> +#define UNBOUND_VARIABLE(a_) Icall_error_handler(sLunbound_variable,null_string,2,sKname,a_)
> +#define FEunbound_variable(a_) UNBOUND_VARIABLE(a_)
> +
> +#define UNBOUND_SLOT(a_,b_) Icall_error_handler(sLunbound_slot,null_string,4,sKname,a_,sKinstance,b_)
> +#define UNDEFINED_FUNCTION(a_) Icall_error_handler(sLundefined_function,null_string,2,sKname,a_)
> +#define FEundefined_function(a_) UNDEFINED_FUNCTION(a_)
> +
> +#define ARITHMETIC_ERROR(a_,b_) Icall_error_handler(sLarithmetic_error,null_string,4,sKoperation,a_,sKoperands,b_)
> +#define DIVISION_BY_ZERO(a_,b_) Icall_error_handler(sLdivision_by_zero,null_string,4,sKoperation,a_,sKoperands,b_)
> +#define FLOATING_POINT_OVERFLOW(a_,b_) Icall_error_handler(sLfloating_point_overflow,null_string,4,sKoperation,a_,sKoperands,b_)
> +#define FLOATING_POINT_UNDERFLOW(a_,b_) Icall_error_handler(sLfloating_point_underflow,null_string,4,sKoperation,a_,sKoperands,b_)
> +#define FLOATING_POINT_INEXACT(a_,b_) Icall_error_handler(sLfloating_point_inexact,null_string,4,sKoperation,a_,sKoperands,b_)
> +#define FLOATING_POINT_INVALID_OPERATION(a_,b_) Icall_error_handler(sLfloating_point_invalid_operation,null_string,4,sKoperation,a_,sKoperands,b_)
> +
> +#define PATHNAME_ERROR(a_,b_,c_...) Icall_error_handler(sLfile_error,null_string,6,\
> + sKpathname,(a_),\
> + sKformat_control,make_simple_string(b_),\
> + sKformat_arguments,list(c_))
> +#define WILD_PATH(a_) ({object _a=(a_);PATHNAME_ERROR(_a,"File ~s is wild",1,_a);})
> +
> +
> +#define NERROR(a_) ({object fmt=make_simple_string(a_ ": line ~a, file ~a, function ~a");\
> + {object line=make_fixnum(__LINE__);\
> + {object file=make_simple_string(__FILE__);\
> + {object function=make_simple_string(__FUNCTION__);\
> + Icall_error_handler(sKerror,fmt,3,line,file,function);}}}})
> +
> +#define ASSERT(a_) do {if (!(a_)) NERROR("The assertion " #a_ " failed");} while (0)
> +
> +#define gcl_abort() ({\
> + frame_ptr fr=frs_sch_catch(sSPtop_abort_tagP->s.s_dbind);\
> + vs_base[0]=sSPtop_abort_tagP->s.s_dbind;\
> + vs_top=vs_base+1;\
> + if (fr) unwind(fr,sSPtop_abort_tagP->s.s_dbind);\
> + abort();\
> + })
> +
> diff -ruN t1/gcl-2.6.11/h/globals.h t2/gcl-2.6.12/h/globals.h
> --- t1/gcl-2.6.11/h/globals.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/globals.h 2014-10-23 17:29:00.000000000 -0400
> @@ -21,5 +21,15 @@
> EXTER object sLcons;
> EXTER object sLhash_table;
>
> +EXTER object sLerror;
> +EXTER object sKformat_control;
> +EXTER object sKformat_arguments;
> +
> +EXTER object sLtype_error;
> +EXTER object sKdatum;
> +EXTER object sKexpected_type;
> +
> +
> EXTER object MVloc[10];
>
> +EXTER object null_string;
> diff -ruN t1/gcl-2.6.11/h/mingw.h t2/gcl-2.6.12/h/mingw.h
> --- t1/gcl-2.6.11/h/mingw.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/mingw.h 2014-10-23 17:29:00.000000000 -0400
> @@ -240,5 +240,6 @@
> #define FPE_FLTRES 6
> #define FPE_FLTINV 7
>
> +#include <limits.h>
>
>
> diff -ruN t1/gcl-2.6.11/h/notcomp.h t2/gcl-2.6.12/h/notcomp.h
> --- t1/gcl-2.6.11/h/notcomp.h 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/h/notcomp.h 2014-10-23 17:29:00.000000000 -0400
> @@ -367,3 +367,4 @@
> #define psystem(x) prof_block(system(x))
> #define pfork() prof_block(fork())
>
> +#include "error.h"
> diff -ruN t1/gcl-2.6.11/h/object.h t2/gcl-2.6.12/h/object.h
> --- t1/gcl-2.6.11/h/object.h 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/h/object.h 2014-10-23 17:29:00.000000000 -0400
> @@ -509,7 +509,7 @@
>
> EXTER unsigned plong signals_allowed, signals_pending;
>
> -#define endp_prop(a) (consp(a) ? FALSE : ((a)==Cnil ? TRUE : (FEwrong_type_argument(sLlist, (a)),FALSE)))
> +#define endp_prop(a) (consp(a) ? FALSE : ((a)==Cnil ? TRUE : endp_error(a)))
> #define endp(a) endp_prop(a)
>
> #define proper_list(a) (type_of(a)==t_cons || (a)==Cnil)
> diff -ruN t1/gcl-2.6.11/h/type.h t2/gcl-2.6.12/h/type.h
> --- t1/gcl-2.6.11/h/type.h 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/h/type.h 2014-10-23 17:29:00.000000000 -0400
> @@ -7,19 +7,19 @@
> t_shortfloat,
> t_longfloat,
> t_complex,
> - t_character,
> - t_symbol,
> - t_package,
> - t_hashtable,
> - t_array,
> - t_vector,
> + t_pathname,
> t_string,
> t_bitvector,
> + t_vector,
> + t_array,
> + t_hashtable,
> t_structure,
> + t_character,
> + t_symbol,
> + t_package,
> t_stream,
> t_random,
> t_readtable,
> - t_pathname,
> t_cfun,
> t_cclosure,
> t_sfun,
> @@ -105,3 +105,31 @@
> #define atom(x) !consp(x)
>
> #endif
> +
> +#define SPP(a_,b_) (type_of(a_)==Join(t_,b_))
> +#define streamp(a_) SPP(a_,stream)
> +#define packagep(a_) SPP(a_,package)
> +#define hashtablep(a_) SPP(a_,hashtable)
> +#define randomp(a_) SPP(a_,random)
> +#define characterp(a_) SPP(a_,character)
> +#define symbolp(a_) SPP(a_,symbol)
> +#define stringp(a_) SPP(a_,string)
> +#define fixnump(a_) SPP(a_,fixnum)
> +#define readtablep(a_) SPP(a_,readtable)
> +#define functionp(a_) ({enum type _t=type_of(a_);_t>=t_cfun && _t<=t_closure;})
> +#define compiled_functionp(a_) functionp(a_)
> +
> +#define integerp(a_) ({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp <= t_bignum;})
> +#define non_negative_integerp(a_) ({enum type _tp=type_of(a_); (_tp == t_fixnum && fix(a_)>=0) || (_tp==t_bignum && big_sign(a_)>=0);})
> +#define rationalp(a_)({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp <= t_ratio;})
> +#define floatp(a_) ({enum type _tp=type_of(a_); _tp == t_shortfloat || _tp == t_longfloat;})
> +#define realp(a_) ({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp < t_complex;})
> +#define numberp(a_) ({enum type _tp=type_of(a_); _tp >= t_fixnum && _tp <= t_complex;})
> +#define arrayp(a_) ({enum type _tp=type_of(a_); _tp >= t_string && _tp <= t_array;})
> +#define vectorp(a_) ({enum type _tp=type_of(a_); _tp >= t_string && _tp < t_array;})
> +
> +#define string_symbolp(a_) ({enum type _tp=type_of(a_); _tp == t_string || _tp == t_symbol;})
> +#define pathname_string_symbolp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || _tp == t_string\
> + || _tp == t_symbol;})
> +#define pathname_string_symbol_streamp(a_) ({enum type _tp=type_of(a_); _tp==t_pathname || _tp == t_string\
> + || _tp == t_symbol || _tp==t_stream;})
> diff -ruN t1/gcl-2.6.11/lsp/gcl_assert.lsp t2/gcl-2.6.12/lsp/gcl_assert.lsp
> --- t1/gcl-2.6.11/lsp/gcl_assert.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_assert.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -20,197 +20,62 @@
> ;;;; assert.lsp
>
>
> -(in-package 'lisp)
> +(in-package :si)
>
> -
> -(export '(check-type assert
> - ecase ccase typecase etypecase ctypecase))
> -
> -
> -(in-package 'system)
> -
> -
> -(proclaim '(optimize (safety 2) (space 3)))
> -
> -
> -(defmacro check-type (place typespec &optional (string nil s))
> - `(do ((*print-level* 4)
> - (*print-length* 4))
> - ((typep ,place ',typespec) nil)
> - (cerror ""
> - "The value of ~:@(~S~), ~:@(~S~), is not ~A."
> - ',place ,place
> - ,(if s string `',typespec))
> - ,(ask-for-form place)
> - (format *error-output* "Now continuing ...~%")))
> +(defun read-evaluated-form nil
> + (format *query-io* "~&type a form to be evaluated:~%")
> + (list (eval (read *query-io*))))
> +
> +(defun check-type-symbol (symbol value type &optional type-string
> + &aux (type-string (when type-string (concatenate 'string ": need a " type-string))))
> + (restart-case
> + (cerror "Check type again." 'type-error :datum value :expected-type type)
> + (store-value (v)
> + :report (lambda (stream) (format stream "Supply a new value of ~s. ~a" symbol (or type-string "")))
> + :interactive read-evaluated-form
> + (setf value v)))
> + (if (typep value type) value (check-type-symbol symbol value type type-string)))
> +
> +(defmacro check-type (place typespec &optional string)
> + (declare (optimize (safety 2)))
> + `(progn (,(if (symbolp place) 'setq 'setf) ,place
> + (the ,typespec (if (typep ,place ',typespec) ,place (check-type-symbol ',place ,place ',typespec ',string)))) nil))
>
>
> (defmacro assert (test-form &optional places string &rest args)
> - `(do ((*print-level* 4)
> - (*print-length* 4))
> + `(do nil;(*print-level* 4) (*print-length* 4)
> (,test-form nil)
> - ,(if string
> - `(cerror "" ,string ,@args)
> - `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form))
> - ,@(mapcar #'ask-for-form places)
> - (format *error-output* "Now continuing ...~%")))
> -
> -
> -(defun ask-for-form (place)
> - `(progn (format *error-output*
> - "Please input the new value for the place ~:@(~S~): "
> - ',place)
> - (finish-output *error-output*)
> - (setf ,place (read))))
> -
> -
> -(defmacro ecase (keyform &rest clauses &aux (key (gensym)))
> - (do ((l (reverse clauses) (cdr l))
> - (form `(let ((*print-level* 4)
> - (*print-length* 4))
> - (error
> - "The value of ~:@(~S~), ~:@(~S~), is ~
> - ~#[nonsense~;not ~:@(~S~)~;neither ~:@(~S~) nor ~:@(~S~)~
> - ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
> - ',keyform
> - ,key
> - ,@(mapcan #'(lambda (x)
> - (if (listp (car x))
> - (mapcar #'(lambda (y) `',y) (car x))
> - `(',(car x))))
> - clauses)))))
> - ((endp l) `(let ((,key ,keyform)) ,form))
> - (when (caar l)
> - (setq form `(if ,(if (listp (caar l))
> - `(member ,key ',(caar l))
> - `(eql ,key ',(caar l)))
> - (progn ,@(cdar l))
> - ,form))))
> -)
> -
> -(defmacro ccase (keyplace &rest clauses &aux (key (gensym)))
> - `(loop (let ((,key ,keyplace))
> - ,@(mapcar #'(lambda (l)
> - `(when ,(if (listp (car l))
> - `(member ,key ',(car l))
> - `(eql ,key ',(car l)))
> - (return (progn ,@(cdr l)))))
> - clauses)
> - (let ((*print-level* 4)
> - (*print-length* 4))
> - (cerror ""
> - "The value of ~:@(~S~), ~:@(~S~), is ~
> - ~#[nonsense~;not ~:@(~S~)~;neither ~
> - ~:@(~S~) nor ~:@(~S~)~
> - ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
> - ',keyplace
> - ,key
> - ,@(mapcan
> - #'(lambda (x)
> - (if (listp (car x))
> - (mapcar #'(lambda (y) `',y)
> - (car x))
> - `(',(car x))))
> - clauses))
> - ,(ask-for-form keyplace)
> - (format *error-output* "Now continuing ...~%"))))
> - )
> -
> -(defmacro typecase (keyform &rest clauses)
> - (do ((l (reverse clauses) (cdr l))
> - (form nil) (key (gensym)))
> - ((endp l) `(let ((,key ,keyform)) ,form))
> - (if (or (eq (caar l) 't) (eq (caar l) 'otherwise))
> - (setq form `(progn ,@(cdar l)))
> - (setq form
> - `(if (typep ,key (quote ,(caar l)))
> - (progn ,@(cdar l))
> - ,form))))
> - )
> -
> -(defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
> - (do ((l (reverse clauses) (cdr l))
> - (form `(error (typecase-error-string
> - ',keyform ,key
> - ',(mapcar #'(lambda (l) (car l)) clauses)))))
> - ((endp l) `(let ((,key ,keyform)) ,form))
> - (setq form `(if (typep ,key ',(caar l))
> - (progn ,@(cdar l))
> - ,form))
> - )
> - )
> -
> -(defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
> - `(loop (let ((,key ,keyplace))
> - ,@(mapcar #'(lambda (l)
> - `(when (typep ,key ',(car l))
> - (return (progn ,@(cdr l)))))
> - clauses)
> - (cerror ""
> - (typecase-error-string
> - ',keyplace ,key
> - ',(mapcar #'(lambda (l) (car l)) clauses))))
> - ,(ask-for-form keyplace)
> - (format *error-output* "Now continuing ...~%")))
> - )
> -
> -(defun typecase-error-string
> - (keyform keyvalue negs
> - &aux (negs1 nil) (poss nil) (poss1 nil))
> - (do ()
> - ((endp negs))
> - (if (symbolp (car negs))
> - (progn (push (list (car negs)) negs1) (pop negs))
> - (case (caar negs)
> - (or (setq negs (append (cdar negs) (cdr negs))))
> - (member (mapc #'(lambda (x) (push `(member ,x) negs1))
> - (cdar negs))
> - (pop negs))
> - (not (push (cadar negs) poss) (pop negs))
> - (otherwise (push (car negs) negs1) (pop negs)))))
> - (do ()
> - ((endp poss))
> - (cond ((symbolp (car poss)) (push (list (car poss)) poss1) (pop poss))
> - ((eq (caar poss) 'and)
> - (setq poss (append (cdar poss) (cdr poss))))
> - (t (push (car poss) poss1) (pop poss))))
> - (format
> - nil
> - "The value of ~:@(~S~), ~:@(~S~), is ~?~?."
> - keyform
> - keyvalue
> - "~#[~;~;~?~;~;~? and ~?~:;~%~@{~#[~;~;and ~]~?~^, ~}~]"
> - (mapcan 'typecase-error-strings poss1)
> - "~:[~[something~;~:;~%~]~;~[~:;, but~%~]~]~
> - ~#[~;~;not ~?~;~;neither ~? nor ~?~:;not ~@{~#[~;~;or ~]~?~^, ~}~]"
> - (cons poss1 (cons (length negs1)
> - (mapcan 'typecase-error-strings (reverse negs1))))
> - )
> - )
> -
> -(defun typecase-error-strings (type)
> - (cond ((eq (car type) 'member)
> - (case (length (cdr type))
> - (0 `("one of none" nil))
> - (1 `("~:@(~S~)" (,(cadr type))))
> - (2 `("either ~:@(~S~) or ~:@(~S~)" ,(cdr type)))
> - (t `("one of ~:@(~S~)" (,(cdr type))))))
> - ((eq (car type) 'satisfies)
> - `("an object satisfying ~:@(~S~)" ,(cdr type)))
> - ((or (endp (cdr type)) (null (remove '* (cdr type))))
> - (let ((x (assoc (car type)
> - '((t "anything")
> - (nil "none")
> - (null "nil")
> - (common "an object of a standard data type")))))
> - (if x
> - `(,(cadr x) nil)
> - `("~:[a~;an~] ~(~A~)" (,(boin-p (car type)) ,(car type))))))
> - (t `("~:[a~;an~] ~:@(~S~)" (,(boin-p (car type)) ,type))))
> - )
> -
> -(defun boin-p (symbol)
> - (member (elt (symbol-name symbol) 0)
> - '(#\A #\I #\U #\E #\O #\a #\i #\u #\e #\o))
> -)
> + ,(if string
> + `(cerror "" ,string ,@args)
> + `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form))
> + ,@(mapcan (lambda (place)
> + `((format *error-output*
> + "Please input the new value for the place ~:@(~S~): "
> + ',place)
> + (finish-output *error-output*)
> + (setf ,place (read)))) places)))
> +
> +(defmacro typecase (keyform &rest clauses &aux (key (if (symbolp keyform) keyform (sgen "TYPECASE"))))
> + (declare (optimize (safety 2)))
> + (labels ((l (x &aux (c (pop x))(tp (pop c))(fm (if (cdr c) (cons 'progn c) (car c)))(y (when x (l x))))
> + (if (or (eq tp t) (eq tp 'otherwise)) fm `(if (typep ,key ',tp) ,fm ,y))))
> + (let ((x (l clauses)))
> + (if (eq key keyform) x `(let ((,key ,keyform)) ,x)))))
> +
> +(defmacro ctypecase (keyform &rest clauses &aux (key (sgen "CTYPECASE")))
> + (declare (optimize (safety 2)))
> +; (check-type clauses (list-of proper-list))
> + `(do nil (nil)
> + (typecase ,keyform
> + ,@(mapcar (lambda (l)
> + `(,(car l) (return (progn ,@(subst key keyform (cdr l))))))
> + clauses))
> + (check-type ,keyform (or ,@(mapcar 'car clauses)))))
> +
> +(defmacro etypecase (keyform &rest clauses &aux (key (if (symbolp keyform) keyform (sgen "ETYPECASE"))))
> + (declare (optimize (safety 2)))
> +; (check-type clauses (list-of proper-list))
> + (let ((tp `(or ,@(mapcar 'car clauses))))
> + `(let ((,key ,keyform)) (typecase ,key ,@clauses (t (error 'type-error :datum ,key :expected-type ',tp))))))
> +
>
> diff -ruN t1/gcl-2.6.11/lsp/gcl_debug.lsp t2/gcl-2.6.12/lsp/gcl_debug.lsp
> --- t1/gcl-2.6.11/lsp/gcl_debug.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_debug.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -704,7 +704,7 @@
> line env (i 0))
> (loop
> (mv-setq (ihs fun line file env) (next-stack-frame ihs))
> - (or fun (return nil))
> + (or (and ihs fun) (return nil))
> (print-stack-frame i nil ihs fun line file env)
> (incf i)
> (cond ((fb >= i m) (return (values))))
> diff -ruN t1/gcl-2.6.11/lsp/gcl_defpackage.lsp t2/gcl-2.6.12/lsp/gcl_defpackage.lsp
> --- t1/gcl-2.6.11/lsp/gcl_defpackage.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_defpackage.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -155,9 +155,8 @@
> (rest (first result)))))
> (sloop for option in '(:size :documentation)
> when (<= 2 (count option options ':key #'car))
> - do (specific-error :invalid-form
> - "DEFPACKAGE option ~s specified more than once."
> - option))
> + do (error 'program-error :format-control "DEFPACKAGE option ~s specified more than once."
> + :format-arguments (list option)))
> (setq name (string name))
> (let ((nicknames (mapcar #'string (option-values ':nicknames options)))
> (documentation (first (option-values ':documentation options)))
> @@ -203,29 +202,31 @@
> (sloop for list in imported-from-symbol-names-list
> append (rest list)))
> do
> - (specific-error
> - :invalid-form
> - "The symbol ~s cannot coexist in these lists:~{ ~s~}"
> - (first duplicate)
> - (sloop for num in (rest duplicate)
> - collect
> - (case num
> - (1 ':SHADOW)
> - (2 ':INTERN)
> - (3 ':SHADOWING-IMPORT-FROM)
> - (4 ':IMPORT-FROM)))))
> + (error
> + 'program-error
> + :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}"
> + :format-arguments
> + (list (first duplicate)
> + (sloop for num in (rest duplicate)
> + collect
> + (case num
> + (1 :SHADOW)
> + (2 :INTERN)
> + (3 :SHADOWING-IMPORT-FROM)
> + (4 :IMPORT-FROM))))))
> (sloop for duplicate in
> (find-duplicates exported-symbol-names interned-symbol-names)
> do
> - (specific-error
> - :invalid-form
> - "The symbol ~s cannot coexist in these lists:~{ ~s~}"
> - (first duplicate)
> - (sloop for num in
> - (rest duplicate)
> - collect (case num
> - (1 ':EXPORT)
> - (2 ':INTERN))))))
> + (error
> + 'program-error
> + :format-control "The symbol ~s cannot coexist in these lists:~{ ~s~}"
> + :format-arguments
> + (list (first duplicate)
> + (sloop for num in
> + (rest duplicate)
> + collect (case num
> + (1 :EXPORT)
> + (2 :INTERN)))))))
> `(eval-when (load eval compile)
> (if (find-package ,name)
> (progn (rename-package ,name ,name)
> @@ -265,12 +266,12 @@
> (mapcar #'(lambda (list)
> `(SHADOWING-IMPORT
> (mapcar #'(lambda (symbol)
> - (if (find-symbol symbol ,(first list))
> - (intern symbol ,(first list))
> -; FIXME better error messages
> - (specific-correctable-error :package-error
> - "" ,(first list)
> - (format nil "Symbol ~S not present~%" symbol))))
> + (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p)
> + (cerror "Continue anyway" 'package-error
> + :package (first list)
> + :format-control "~%Symbol ~a not present"
> + :format-arguments (list symbol)))
> + (intern symbol ,(first list)))
> ',(rest list))))
> SHADOWING-IMPORTed-from-symbol-names-list))
> (USE-PACKAGE ',(if (member ':USE options ':test #'option-test)
> @@ -279,12 +280,12 @@
> ,@(when IMPORTed-from-symbol-names-list
> (mapcar #'(lambda (list)
> `(IMPORT (mapcar #'(lambda (symbol)
> - (if (find-symbol symbol ,(first list))
> - (intern symbol ,(first list))
> -; FIXME better error messages
> - (specific-correctable-error :package-error
> - "" ,(first list)
> - (format nil "Symbol ~S not present~%" symbol))))
> + (unless (multiple-value-bind (s p) (find-symbol symbol ,(first list)) p)
> + (cerror "Continue anyway" 'package-error
> + :package (first list)
> + :format-control "~%Symbol ~a not present"
> + :format-arguments (list symbol)))
> + (intern symbol ,(first list)))
> ',(rest list))))
> IMPORTed-from-symbol-names-list))
> ,@(when INTERNed-symbol-names
> diff -ruN t1/gcl-2.6.11/lsp/gcl_destructuring_bind.lsp t2/gcl-2.6.12/lsp/gcl_destructuring_bind.lsp
> --- t1/gcl-2.6.11/lsp/gcl_destructuring_bind.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_destructuring_bind.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -83,11 +83,6 @@
> "Takes a non-keyword symbol, symbol, and returns the corresponding keyword."
> (intern (symbol-name symbol) (find-package "KEYWORD")))
>
> -(defun defmacro-error (problem kind name)
> -; FIXME check this
> - (declare (ignore kind))
> - (specific-error :wrong-type-argument "~S is not of type ~S~%" problem name))
> -
> (defun verify-keywords (key-list valid-keys allow-other-keys)
> (do ((already-processed nil)
> (unknown-keyword nil)
> @@ -159,8 +154,7 @@
> (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
> (setf rest-of-args (cdr rest-of-args))
> (push-let-binding (car rest-of-args) arg-list-name nil))
> - (t
> - (defmacro-error "&WHOLE" error-kind name))))
> + (t (error "Bad &WHOLE"))))
> ((eq var '&environment)
> (cond (env-illegal
> (error "&Environment not valid with ~S." error-kind))
> @@ -171,8 +165,7 @@
> (setf rest-of-args (cdr rest-of-args))
> (push-let-binding (car rest-of-args) env-arg-name nil)
> (setf env-arg-used t))
> - (t
> - (defmacro-error "&ENVIRONMENT" error-kind name))))
> + (t (error "Bad &ENVIRONMENT"))))
> ((or (eq var '&rest) (eq var '&body))
> (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
> (setf rest-of-args (cdr rest-of-args))
> @@ -209,8 +202,7 @@
> (when doc-string-name
> (push-let-binding doc-string-name
> `(caddr ,parse-body-values) nil))))
> - (t
> - (defmacro-error (symbol-name var) error-kind name))))
> + (t (error "Bad lambda list"))))
> ((eq var '&optional)
> (setf now-processing :optionals))
> ((eq var '&key)
> diff -ruN t1/gcl-2.6.11/lsp/gcl_evalmacros.lsp t2/gcl-2.6.12/lsp/gcl_evalmacros.lsp
> --- t1/gcl-2.6.11/lsp/gcl_evalmacros.lsp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/lsp/gcl_evalmacros.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -31,6 +31,9 @@
> ;(eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
> (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
>
> +(defmacro sgen (&optional (pref "G"))
> + `(load-time-value (gensym ,pref)))
> +
>
> (defmacro defvar (var &optional (form nil form-sp) doc-string)
> `(progn (si:*make-special ',var)
> @@ -286,21 +289,27 @@
> `(if ,(if (when (eq a v) (listp v)) (m (mapcar #'sw v) 'or) (sw v)) ,(m c 'progn) ,y))
> c :initial-value df)))))
>
> -;; (defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
> -;; (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
> -;; (declare (object clause))
> -;; (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
> -;; (setq form `(progn ,@(cdr clause))))
> -;; ((consp (car clause))
> -;; (setq form `(if (member ,key ',(car clause))
> -;; (progn ,@(cdr clause))
> -;; ,form)))
> -;; ((car clause)
> -;; (setq form `(if (eql ,key ',(car clause))
> -;; (progn ,@(cdr clause))
> -;; ,form)))))
> -;; )
> +(defmacro ecase (keyform &rest clauses &aux (key (sgen "ECASE")))
> + (declare (optimize (safety 2)))
> + `(let ((,key ,keyform))
> + (declare (ignorable ,key))
> + (case ,key
> + ,@(mapcar (lambda (x) (if (member (car x) '(t otherwise)) (cons (list (car x)) (cdr x)) x)) clauses)
> + (otherwise
> + (error 'type-error :datum ,key
> + :expected-type '(member ,@(apply 'append (mapcar (lambda (x &aux (x (car x))) (if (listp x) x (list x))) clauses))))))))
> +
>
> +(defmacro ccase (keyform &rest clauses &aux (key (sgen "CCASE")))
> + (declare (optimize (safety 2)))
> + `(let ((,key ,keyform))
> + (declare (ignorable ,key))
> + (do nil (nil)
> + (case ,key
> + ,@(mapcar (lambda (x &aux (k (pop x)))
> + `(,(if (member k '(t otherwise)) (list k) k) (return ,(if (cdr x) (cons 'progn x) (car x))))) clauses)
> + (otherwise
> + (check-type ,key (member ,@(apply 'append (mapcar (lambda (x &aux (x (car x))) (if (listp x) x (list x))) clauses)))))))))
>
> (defmacro return (&optional (val nil)) `(return-from nil ,val))
>
> diff -ruN t1/gcl-2.6.11/lsp/gcl_export.lsp t2/gcl-2.6.12/lsp/gcl_export.lsp
> --- t1/gcl-2.6.11/lsp/gcl_export.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_export.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -307,4 +307,27 @@
>
> dynamic-extent
>
> +loop
> +check-type assert typecase etypecase ctypecase case ecase ccase
> +
> +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
> +
> +simple-condition simple-error simple-warning invoke-debugger *debugger-hook* *break-on-signals*
> +
> +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 cell-error-name
> + 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
> +
> ))
> diff -ruN t1/gcl-2.6.11/lsp/gcl_iolib.lsp t2/gcl-2.6.12/lsp/gcl_iolib.lsp
> --- t1/gcl-2.6.11/lsp/gcl_iolib.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_iolib.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -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 -ruN t1/gcl-2.6.11/lsp/gcl_listlib.lsp t2/gcl-2.6.12/lsp/gcl_listlib.lsp
> --- t1/gcl-2.6.11/lsp/gcl_listlib.lsp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/lsp/gcl_listlib.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -125,7 +125,7 @@
>
>
> (defmacro tp-error (x y)
> - `(specific-error :wrong-type-argument "~S is not of type ~S." ,x ',y))
> + `(error 'type-error :datum ,x :expected-type ',y))
>
> (defun smallnthcdr (n x)
> (declare (fixnum n))
> diff -ruN t1/gcl-2.6.11/lsp/gcl_loop.lsp t2/gcl-2.6.12/lsp/gcl_loop.lsp
> --- t1/gcl-2.6.11/lsp/gcl_loop.lsp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/lsp/gcl_loop.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -968,7 +968,8 @@
> (defun loop-error (format-string &rest format-args)
> #+(or Genera CLOE) (declare (dbg:error-reporter))
> #+Genera (setq format-args (copy-list format-args)) ;Don't ask.
> - (specific-error :invalid-form "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
> + (error 'program-error :format-control "~?~%Current LOOP context:~{ ~S~}."
> + :format-arguments (list format-string format-args (loop-context))))
>
>
> (defun loop-warn (format-string &rest format-args)
> @@ -1115,9 +1116,9 @@
> (push (loop-construct-return form) *loop-after-epilogue*)
> (when *loop-final-value-culprit*
> (if *loop-collection-no-into*
> - (specific-error :invalid-form "LOOP clause is providing a value for the iteration,~@
> + (error 'program-error :format-control "LOOP clause is providing a value for the iteration,~@
> however one was already established by a ~S clause."
> - *loop-final-value-culprit*)
> + :format-arguments (list *loop-final-value-culprit*))
> (loop-warn "LOOP clause is providing a value for the iteration,~@
> however one was already established by a ~S clause."
> *loop-final-value-culprit*)))
> diff -ruN t1/gcl-2.6.11/lsp/gcl_packlib.lsp t2/gcl-2.6.12/lsp/gcl_packlib.lsp
> --- t1/gcl-2.6.11/lsp/gcl_packlib.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_packlib.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -181,7 +181,7 @@
> (x (gensym))(y (gensym)) (access (gensym)) declaration)
> (multiple-value-setq (declaration body) (si::find-declarations body))
> (if (null symbol-types)
> - (specific-error :too-few-arguments "Symbol type specifiers must be supplied"))
> + (error 'program-error :format-control "Symbol type specifiers must be supplied"))
> `(let ((,p (cons t (if (atom ,plist) (list ,plist) ,plist))) (,q nil) (,l nil)
> (,i -1) (,x 0) (,y 0) (,dum nil) (,access nil))
> (declare (fixnum ,x ,y))
> diff -ruN t1/gcl-2.6.11/lsp/gcl_restart.lsp t2/gcl-2.6.12/lsp/gcl_restart.lsp
> --- t1/gcl-2.6.11/lsp/gcl_restart.lsp 1969-12-31 19:00:00.000000000 -0500
> +++ t2/gcl-2.6.12/lsp/gcl_restart.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -0,0 +1,196 @@
> +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
> +
> +(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 -ruN t1/gcl-2.6.11/lsp/gcl_seqlib.lsp t2/gcl-2.6.12/lsp/gcl_seqlib.lsp
> --- t1/gcl-2.6.11/lsp/gcl_seqlib.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_seqlib.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -72,7 +72,7 @@
> (error "both test and test not supplied"))
>
> (defun bad-seq-limit (x &optional y)
> - (specific-error :wrong-type-argument "bad sequence limit ~a" (if y (list x y) x)))
> + (error 'type-error :datum (if y (list x y) x) :expected-type 'sequence-limit));FIXME
>
>
> (eval-when (compile eval)
> diff -ruN t1/gcl-2.6.11/lsp/gcl_seq.lsp t2/gcl-2.6.12/lsp/gcl_seq.lsp
> --- t1/gcl-2.6.11/lsp/gcl_seq.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_seq.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -48,22 +48,19 @@
> (when (subtypep (car type) 'list)
> (if (or (and (eq 'null (car type)) (not (equal size 0)))
> (and (eq 'cons (car type)) (equal size 0)))
> - (specific-error :wrong-type-argument "~S is not of type ~S."
> - type (format nil "list (size ~S)" size)))
> + (error 'type-error :datum type :expected-type (format nil "list (size ~S)" size)))
> (return-from make-sequence
> (if iesp
> (make-list size :initial-element initial-element)
> (make-list size))))
> (unless (or (eq (car type) 'array)
> (eq (car type) 'simple-array))
> - (specific-error :wrong-type-argument "~S is not of type ~S."
> - type 'sequence))
> + (error 'type-error :datum type :expected-type 'sequence))
> (let ((ssize (caddr type)))
> (if (listp ssize) (setq ssize (car ssize)))
> (if (not (si::fixnump ssize)) (setq ssize size))
> (unless (equal ssize size)
> - (specific-error :wrong-type-argument "~S is not of type ~S."
> - type (format nil "~S (size ~S)" type size))))
> + (error 'type-error :datum type :expected-type (format nil "~S (size ~S)" type size))))
> (or (cadr type) t))))
> (setq element-type (si::best-array-element-type element-type))
> (setq sequence (si:make-vector element-type size nil nil nil nil nil))
> diff -ruN t1/gcl-2.6.11/lsp/gcl_serror.lsp t2/gcl-2.6.12/lsp/gcl_serror.lsp
> --- t1/gcl-2.6.11/lsp/gcl_serror.lsp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/lsp/gcl_serror.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -1,239 +1,281 @@
> -;;; -*- 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 :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))
> +
> +(proclaim '(ftype (function (t *) t) make-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* 1)
> +(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 &aux (control (member :format-control args)))
> + (labels ((r (x &aux (z (member-if (lambda (x) (member x '(:format-control :format-arguments))) x)))
> + (if z (nconc (ldiff x z) (r (cddr z))) x)))
> + (if control
> + (nconc (r args) (list (apply 'format nil (cadr control) (cadr (member :format-arguments args)))))
> + args)))
> +
> +(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 -ruN t1/gcl-2.6.11/lsp/gcl_setf.lsp t2/gcl-2.6.12/lsp/gcl_setf.lsp
> --- t1/gcl-2.6.11/lsp/gcl_setf.lsp 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/gcl_setf.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -142,7 +142,7 @@
> ((macro-function (car form))
> (get-setf-method-multiple-value (macroexpand form)))
> (t
> - (error "Cannot expand the SETF form ~S." form))))
> + (error 'program-error :format-control "Cannot expand the SETF form ~S." :format-arguments (list form)))))
>
>
> ;;;; SETF definitions.
> diff -ruN t1/gcl-2.6.11/lsp/gcl_top.lsp t2/gcl-2.6.12/lsp/gcl_top.lsp
> --- t1/gcl-2.6.11/lsp/gcl_top.lsp 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/lsp/gcl_top.lsp 2014-10-23 17:29:00.000000000 -0400
> @@ -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
> @@ -588,9 +451,13 @@
> (break-go ihs)
> (return))))
>
> +(defun break-resume ()
> + (if *debug-continue*
> + (invoke-restart *debug-continue*)
> + :resume))
>
> (putprop :b 'simple-backtrace 'break-command)
> -(putprop :r '(lambda () :resume) 'break-command)
> +(putprop :r 'break-resume 'break-command)
> (putprop :resume (get :r 'break-command) 'break-command)
> (putprop :bds 'break-bds 'break-command)
> (putprop :blocks 'break-blocks 'break-command)
> @@ -784,7 +651,3 @@
> (read-file st))
> (read-file *standard-input*))))
> (bye 1))
> -
> -(defmacro without-interrupts (&rest forms)
> - `(let (*quit-tag*)
> - ,@forms))
> diff -ruN t1/gcl-2.6.11/lsp/makefile t2/gcl-2.6.12/lsp/makefile
> --- t1/gcl-2.6.11/lsp/makefile 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/lsp/makefile 2014-10-23 17:29:00.000000000 -0400
> @@ -14,12 +14,12 @@
> 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
>
> -
> -COMPILE_FILE=$(PORTDIR)/saved_pre_gcl$(EXE) $(PORTDIR) -system-p -c-file -data-file -h-file -compile
> +LISP=$(PORTDIR)/saved_pre_gcl$(EXE)
> +COMPILE_FILE=$(LISP) $(PORTDIR) -system-p -c-file -data-file -h-file -compile
>
> %.o: $(PORTDIR)/saved_pre_gcl$(EXE) %.lsp
> $(COMPILE_FILE) $*
> @@ -27,7 +27,7 @@
> all: $(OBJS) #$(RL_OBJS)
>
> .lsp.fn: ../cmpnew/gcl_collectfn.o
> - ../xbin/make-fn $*.lsp
> + ../xbin/make-fn $*.lsp $(LISP)
>
> all: $(OBJS)
>
> diff -ruN t1/gcl-2.6.11/lsp/sys-proclaim.lisp t2/gcl-2.6.12/lsp/sys-proclaim.lisp
> diff -ruN t1/gcl-2.6.11/makefile t2/gcl-2.6.12/makefile
> --- t1/gcl-2.6.11/makefile 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/makefile 2014-10-23 17:29:00.000000000 -0400
> @@ -264,8 +264,8 @@
> (cd o && $(MAKE) ../$@)
>
> $(HDIR)mcompdefs.h: $(HDIR)compdefs.h $(HDIR)new_decl.h
> - $(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"cmponly.h\"";print "---"} {print "\"#define " $$1 "\" " $$1}' $< |\
> - cpp -I./$(HDIR) |\
> + $(AWK) 'BEGIN {print "#include \"include.h\"";print "#include \"cmponly.h\"";print "---"} {a=$$1;gsub("\\.\\.\\.","",a);print "\"#define " $$1 "\" " a}' $< |\
> + $(CC) -E -I./$(HDIR) - |\
> $(AWK) '/^\-\-\-$$/ {i=1;next} {if (!i) next} {gsub("\"","");print}' >$@
>
> $(HDIR)cmpinclude.h: $(HDIR)mcompdefs.h $(CMPINCLUDE_FILES) $(HDIR)config.h
> diff -ruN t1/gcl-2.6.11/o/error.c t2/gcl-2.6.12/o/error.c
> --- t1/gcl-2.6.11/o/error.c 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/o/error.c 2014-10-23 17:29:00.000000000 -0400
> @@ -30,8 +30,6 @@
> #include "include.h"
> object siSuniversal_error_handler;
>
> -static object null_string;
> -
> object sSterminal_interrupt;
>
> void
> @@ -112,7 +110,7 @@
> }
> }
>
> -static object
> +object
> ihs_top_function_name(ihs_ptr h)
> {
> object x;
> @@ -127,292 +125,30 @@
> return(Cnil);
> }
>
> -/* static void */
> -/* call_error_handler(void) */
> -/* { */
> -/* super_funcall(siSuniversal_error_handler); */
> -/* } */
> -
> -
> -
> object
> -Icall_error_handler(object error_name,object error_format_string,int nfmt_args,...)
> -{ object b[20];
> - b[0]= error_name;
> - b[1]= Cnil; /* continue format */
> - b[2] = ihs_top_function_name(ihs_top);
> - b[3] = null_string; /*continue format arg*/
> - b[4] = error_format_string;
> - {int i = 0;
> - va_list ap;
> - va_start(ap,nfmt_args);
> - while (i++ < nfmt_args)
> - { b[i+4]= va_arg(ap,object);
> - }
> - va_end(ap);
> - }
> - return IapplyVector(sSuniversal_error_handler,nfmt_args+5,b);
> -}
> +Icall_gen_error_handler(object ci,object cs,object en,object es,ufixnum n,...) {
>
> -static object
> -Icall_continue_error_handler(object error_name,object error_format_string,int nfmt_args,...)
> -{ object b[20];
> - b[0]= error_name;
> - b[1]= Ct; /* continue format */
> - b[2] = ihs_top_function_name(ihs_top);
> - b[3] = null_string; /*continue format arg*/
> - b[4] = error_format_string;
> - {int i = 0;
> - va_list ap;
> - va_start(ap,nfmt_args);
> - while (i++ < nfmt_args)
> - { b[i+4]= va_arg(ap,object);
> - }
> - va_end(ap);
> - }
> - return IapplyVector(sSuniversal_error_handler,nfmt_args+5,b);
> -}
> -
> -DEFUNO_NEW("ERROR",object,fLerror,LISP
> - ,1,F_ARG_LIMIT,NONE,OO,OO,OO,OO,void,Lerror,(object fmt_string,...),"")
> -{ int n = VFUN_NARGS,i=0;
> - object b[F_ARG_LIMIT];
> + object *b;
> + ufixnum i;
> va_list ap;
>
> - b[0]=sKerror;
> - b[1]=Cnil;
> - b[2]=ihs_top_function_name(ihs_top-1);
> - b[3]=null_string;
> - b[4]=fmt_string;
> - i=4;
> - va_start(ap,fmt_string);
> - while (--n)
> - b[++i]=va_arg(ap,object);
> - va_end(ap);
> - RETURN1(IapplyVector(sSuniversal_error_handler,++i,b));
> -/* RETURN1(Iapply_fun_n2(sSuniversal_error_handler,5,n-1, */
> -/* sKerror, */
> -/* Cnil, */
> -/* ihs_top_function_name(ihs_top-1), */
> -/* null_string,fmt_string, */
> -/* &ap)); */
> -}
> -
> -DEFUN_NEW("SPECIFIC-ERROR",object,fLspecific_error,LISP
> - ,1,F_ARG_LIMIT,NONE,OO,OO,OO,OO,(object error_name,object fmt_string,...),"")
> -{ int n = VFUN_NARGS,i=0;
> - object b[F_ARG_LIMIT];
> - va_list ap;
> -
> - b[0]=error_name;
> - b[1]=Cnil;
> - b[2]=ihs_top_function_name(ihs_top-1);
> - b[3]=null_string;
> - b[4]=fmt_string;
> - i=4;
> - va_start(ap,fmt_string);
> - n--;
> - while (--n)
> - b[++i]=va_arg(ap,object);
> - va_end(ap);
> - RETURN1(IapplyVector(sSuniversal_error_handler,++i,b));
> -}
> -
> -
> -DEFUN_NEW("SPECIFIC-CORRECTABLE-ERROR",object,fLspecific_correctable_error,LISP
> - ,1,F_ARG_LIMIT,NONE,OO,OO,OO,OO,
> - (object error_name,object fmt_string,...),"")
> -{ int n = VFUN_NARGS,i=0;
> - object b[F_ARG_LIMIT];
> - va_list ap;
> -
> - b[0]=error_name;
> - b[1]=Ct;
> - b[2]=ihs_top_function_name(ihs_top-1);
> - b[3]=null_string;
> - b[4]=fmt_string;
> - i=4;
> - va_start(ap,fmt_string);
> - n--;
> - while (--n)
> - b[++i]=va_arg(ap,object);
> - va_end(ap);
> - RETURN1(IapplyVector(sSuniversal_error_handler,++i,b));
> -}
> -
> -
> -DEFUNO_NEW("CERROR",object,fLcerror,LISP
> - ,2,F_ARG_LIMIT,NONE,OO,OO,OO,OO,void,Lcerror,(object continue_fmt_string,object fmt_string,...),"")
> -{ int n = VFUN_NARGS,i=0;
> - object b[F_ARG_LIMIT];
> - va_list ap;
> -
> - b[0]=sKerror;
> - b[1]=Ct;
> - b[2]=ihs_top_function_name(ihs_top-1);
> - b[3]=continue_fmt_string;
> - b[4]=fmt_string;
> - i=4;
> - n--;
> - va_start(ap,fmt_string);
> - while (--n)
> - b[++i]=va_arg(ap,object);
> + n+=5;
> + b=alloca(n*sizeof(*b));
> + b[0]= en;
> + b[1]= ci;
> + b[2] = ihs_top_function_name(ihs_top);
> + b[3] = cs;
> + b[4] = es;
> +
> + va_start(ap,n);
> + for (i=5;i<n;i++)
> + b[i]= va_arg(ap,object);
> va_end(ap);
> - RETURN1(IapplyVector(sSuniversal_error_handler,++i,b));
> -/* RETURN1(Iapply_fun_n2(sSuniversal_error_handler,5,n-2, */
> -/* sKerror, */
> -/* Ct, */
> -/* ihs_top_function_name(ihs_top-1), */
> -/* continue_fmt_string,fmt_string, */
> -/* &ap)); */
> -}
> -
> -
> -/* void */
> -/* FEerror(char *s, int num, object arg1, object arg2, object arg3, object arg4) */
> -void
> -FEerror(char *s,int num,...)
> -{
> - char *p = s;
> - int last = 0;
> - int count = 0;
> - int i;
> - object arg1,arg2,arg3,arg4;
> - va_list args;
> -
> - while (*p) { if (*p=='~' && last != '~')
> - count ++;
> - last = *p ; p++;}
> - VFUN_NARGS = (count == 0 ? 1 : (num > 50 ? count+1 : num+1));
> -
> - arg1=arg2=arg3=arg4=Cnil;
> - i=VFUN_NARGS;
> - va_start(args,num);
> - if (i && --i)
> - arg1=va_arg(args,object);
> - if (i && --i)
> - arg2=va_arg(args,object);
> - if (i && --i)
> - arg3=va_arg(args,object);
> - if (i && --i)
> - arg4=va_arg(args,object);
> - va_end(args);
> -
> - FFN(fLerror)(make_simple_string(s),arg1,arg2,arg3,arg4);
> -
> -}
> -
> -
> -void
> -FEwrong_type_argument(object type, object value)
> -{Icall_error_handler(sKwrong_type_argument,
> - make_simple_string("~S is not of type ~S."),
> - 2,(value),(type));
> -}
> -
> -void
> -FEtoo_few_arguments(object *base, object *top)
> -{ Icall_error_handler(sKtoo_few_arguments,
> - (make_simple_string("~S [or a callee] requires more than ~R argument~:p.")),
> - 2,(ihs_top_function_name(ihs_top)),
> - (make_fixnum(top - base)));
> -
> -}
> -
> -void
> -FEtoo_few_argumentsF(object args)
> -{Icall_error_handler(sKtoo_few_arguments,
> - make_simple_string("Too few arguments."),
> - 2,(ihs_top_function_name(ihs_top)),
> - (args));
> -}
>
> -void
> -FEtoo_many_arguments(object *base, object *top)
> -{ Icall_error_handler(sKtoo_many_arguments,
> - (make_simple_string("~S [or a callee] requires less than ~R argument~:p.")),
> - 2,(ihs_top_function_name(ihs_top)),(make_fixnum(top - base)));
> -}
> -
> -void
> -FEtoo_many_argumentsF(object args)
> -{
> - Icall_error_handler(sKtoo_many_arguments,
> - make_simple_string("Too many arguments."),0);
> -}
> + return IapplyVector(sSuniversal_error_handler,n,b);
>
> -static void
> -FEinvalid_macro_call(void)
> -{Icall_error_handler(sKinvalid_form,
> - (make_simple_string("Invalid macro call to ~S.")),
> - 1,(ihs_top_function_name(ihs_top)));
> -}
> -
> -void
> -FEunexpected_keyword(object key)
> -{/* if (!keywordp(key)) */
> -/* not_a_keyword(key); */
> -
> - Icall_error_handler(sKunexpected_keyword,
> - make_simple_string("~S does not allow the keyword ~S."),
> - 2,(ihs_top_function_name(ihs_top)),(key));
> -
> -}
> -
> -void
> -FEinvalid_form(char *s, object form)
> -{Icall_error_handler(sKinvalid_form,make_simple_string(s),
> - 1,(form));
> -
> -}
> -
> -void
> -FEunbound_variable(object sym)
> -{Icall_error_handler(sKunbound_variable,
> - make_simple_string("The variable ~S is unbound."),
> - 1,(sym));
> }
>
> -void
> -FEinvalid_variable(char *s, object obj)
> -{Icall_error_handler(sKinvalid_variable,make_simple_string(s),
> - 1,(obj));
> -}
> -
> -void
> -FEundefined_function(object fname)
> -{Icall_error_handler(sKundefined_function,
> - make_simple_string("The function ~S is undefined."),
> - 1,(fname));
> -}
> -
> -void
> -FEinvalid_function(object obj)
> -{Icall_error_handler(sKinvalid_function,
> - make_simple_string("~S is invalid as a function."),
> - 1,(obj));
> -
> -}
> -
> -void
> -FEpackage_error(object obj,const char *s)
> -{
> - Icall_continue_error_handler(sKpackage_error,
> - make_simple_string("A package error occurred on ~S: ~S."),
> - 2,(obj),make_simple_string(s));
> -}
> -
> -
> -object
> -CEerror(char *error_str, char *cont_str, int num, object arg1, object arg2, object arg3, object arg4)
> -{
> - VFUN_NARGS=num+2;
> - return FFN(fLcerror)(make_simple_string(cont_str),
> - make_simple_string(error_str),
> - arg1,arg2,arg3,arg4);
> -}
> -
> -
> /*
> Lisp interface to IHS
> */
> @@ -696,24 +432,6 @@
> FEinvalid_macro_call();
> }
>
> -/* static void */
> -/* keyword_value_mismatch(void) */
> -/* { */
> -/* FEerror("Keywords and values do not match.", 0); */
> -/* } */
> -
> -/* static void */
> -/* not_a_keyword(object x) */
> -/* { */
> -/* FEunexpected_keyword(x); */
> -/* } */
> -
> -/* static void */
> -/* unexpected_keyword(object key) */
> -/* { */
> -/* FEunexpected_keyword(key); */
> -/* } */
> -
> object
> wrong_type_argument(object typ, object obj)
> {
> @@ -728,11 +446,6 @@
> FEinvalid_form("~S is an illegal declaration form.", form);
> }
>
> -/* static void */
> -/* not_a_string(object obj) */
> -/* { FEwrong_type_argument(sLstring,obj); */
> -/* } */
> -
> void
> not_a_string_or_symbol(object x)
> {
> @@ -766,16 +479,6 @@
> FEwrong_type_argument(sLstream, strm);
> }
>
> -/* static object */
> -/* LVerror(object first,...) */
> -/* {va_list ap; */
> -/* va_start(ap,first); */
> -/* fcall.fun= make_cfun(Lerror,Cnil,Cnil,0,0); */
> -/* fcalln_general(first,ap); */
> -/* va_end(ap); */
> -/* return Cnil; */
> -/* } */
> -
> void
> vfun_wrong_number_of_args(object x)
> {
> @@ -816,6 +519,11 @@
> DEF_ORDINARY("UNDEFINED-FUNCTION",sKundefined_function,KEYWORD,"");
> DEF_ORDINARY("INVALID-FUNCTION",sKinvalid_function,KEYWORD,"");
> DEF_ORDINARY("PACKAGE-ERROR",sKpackage_error,KEYWORD,"");
> +DEF_ORDINARY("DATUM",sKdatum,KEYWORD,"");
> +DEF_ORDINARY("EXPECTED-TYPE",sKexpected_type,KEYWORD,"");
> +DEF_ORDINARY("PACKAGE",sKpackage,KEYWORD,"");
> +DEF_ORDINARY("FORMAT-CONTROL",sKformat_control,KEYWORD,"");
> +DEF_ORDINARY("FORMAT-ARGUMENTS",sKformat_arguments,KEYWORD,"");
> DEF_ORDINARY("CATCH",sKcatch,KEYWORD,"");
> DEF_ORDINARY("PROTECT",sKprotect,KEYWORD,"");
> DEF_ORDINARY("CATCHALL",sKcatchall,KEYWORD,"");
> @@ -824,9 +532,6 @@
> void
> gcl_init_error(void)
> {
> - make_function("ERROR", Lerror);
> - make_function("CERROR", Lcerror);
> - /* make_si_function("IHS-TOP", siLihs_top); */
> null_string = make_simple_string("");
> enter_mark_origin(&null_string);
> }
> diff -ruN t1/gcl-2.6.11/o/eval.c t2/gcl-2.6.12/o/eval.c
> --- t1/gcl-2.6.11/o/eval.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/eval.c 2014-10-23 17:29:00.000000000 -0400
> @@ -1006,7 +1006,7 @@
> DEFUNOM_NEW("APPLY",object,fLapply,LISP
> ,2,MAX_ARGS,NONE,OO,OO,OO,OO,void,Lapply,(object fun,...),"")
> { int m,n=VFUN_NARGS;
> - object list;
> + object l;
> object buf[MAX_ARGS];
> object *base=buf;
> va_list ap;
> @@ -1016,12 +1016,12 @@
> {*base++ = va_arg(ap,object);
> }
> m = n-2;
> - list = va_arg(ap,object);
> + l = va_arg(ap,object);
> va_end(ap);
> - while (!endp(list))
> + while (!endp(l))
> { if (m >= MAX_ARGS) FEerror(" Lisps arglist maximum surpassed",0);
> - *base++ = Mcar(list);
> - list = Mcdr(list);
> + *base++ = Mcar(l);
> + l = Mcdr(l);
> m++;}
> return IapplyVector(fun,m,buf);
> }
> diff -ruN t1/gcl-2.6.11/o/file.d t2/gcl-2.6.12/o/file.d
> --- t1/gcl-2.6.11/o/file.d 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/o/file.d 2014-10-23 17:29:00.000000000 -0400
> @@ -1523,7 +1523,7 @@
> object x;
>
> check_arg(1);
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> x = alloc_object(t_stream);
> x->sm.sm_mode = (short)smm_synonym;
> x->sm.sm_fp = NULL;
> @@ -1984,6 +1984,10 @@
> 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((FILE *)x->sm.sm_fp)) ? Ct : Cnil);
> +}
> +
> LFD(siLmake_string_output_stream_from_string)()
> {
> object strng, strm;
> diff -ruN t1/gcl-2.6.11/o/funlink.c t2/gcl-2.6.12/o/funlink.c
> --- t1/gcl-2.6.11/o/funlink.c 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/o/funlink.c 2014-10-23 17:29:00.000000000 -0400
> @@ -33,9 +33,12 @@
> if (!Rset || !sSAlink_listA->s.s_dbind) return;
> for (x=sSAlink_listA->s.s_dbind;x!=Cnil && x->c.c_car->c.c_car!=sym;x=x->c.c_cdr);
> if (x==Cnil)
> - sSAlink_listA->s.s_dbind=MMcons((x=list(6,sym,make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0))),sSAlink_listA->s.s_dbind);
> + sSAlink_listA->s.s_dbind=MMcons((x=list(7,sym,make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0),make_fixnum(0))),sSAlink_listA->s.s_dbind);
> else
> x=x->c.c_car;
> + x=x->c.c_cdr;
> + if (listp(sym->s.s_gfdef))
> + x->c.c_car=one_plus(x->c.c_car);
> for (x=x->c.c_cdr,i=0;i<n;i++,x=x->c.c_cdr);
> x->c.c_car=one_plus(x->c.c_car);
> }
> @@ -293,7 +296,7 @@
> object fun;
> int nargs;
>
> - check_type_symbol(&sym);
> + check_type_sym(&sym);
>
> fun=sym->s.s_gfdef;
> if (fun && (type_of(fun)==t_sfun
> @@ -400,7 +403,7 @@
>
> object fun;
> int nargs;
> - check_type_symbol(&sym);
> + check_type_sym(&sym);
> fun=sym->s.s_gfdef;
>
> if (fun && (type_of(fun)==t_sfun
> diff -ruN t1/gcl-2.6.11/o/list.d t2/gcl-2.6.12/o/list.d
> --- t1/gcl-2.6.11/o/list.d 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/o/list.d 2014-10-23 17:29:00.000000000 -0400
> @@ -727,8 +727,14 @@
> LFD(Lcdddar)(){check_arg(1); vs_base[0] = cdr(cdr(cdr(car(vs_base[0]))));}
> LFD(Lcddddr)(){check_arg(1); vs_base[0] = cdr(cdr(cdr(cdr(vs_base[0]))));}
>
> -DEFUNO_NEW("NTH",object,fLnth,LISP,2,2,NONE,OI,OO,OO,OO,void,Lnth,(fixnum index,object list),"")
> -{ object x = list;
> +int
> +endp_error(object x) {
> + FEwrong_type_argument(sLlist,x);
> + return 0;
> +}
> +
> +DEFUNO_NEW("NTH",object,fLnth,LISP,2,2,NONE,OI,OO,OO,OO,void,Lnth,(fixnum index,object y),"")
> +{ object x = y;
> if (index < 0)
> FEerror("Negative index: ~D.", 1, make_fixnum(index));
> while (1)
> @@ -737,7 +743,7 @@
> RETURN1(Mcar(x));
> else {x = Mcdr(x); index--;}}
> else if (x == sLnil) RETURN1(sLnil);
> - else FEwrong_type_argument(sLlist, list);}
> + else FEwrong_type_argument(sLlist, y);}
> }
> #ifdef STATIC_FUNCTION_POINTERS
> object
> diff -ruN t1/gcl-2.6.11/o/main.c t2/gcl-2.6.12/o/main.c
> --- t1/gcl-2.6.11/o/main.c 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/o/main.c 2014-10-23 17:29:00.000000000 -0400
> @@ -357,6 +357,19 @@
>
> gcl_init_alloc(&argv);
>
> +#ifdef GET_FULL_PATH_SELF
> + GET_FULL_PATH_SELF(kcl_self);
> +#else
> + kcl_self = argv[0];
> +#endif
> +#ifdef __MINGW32__
> + {
> + char *s=kcl_self;
> + for (;*s;s++) if (*s=='\\') *s='/';
> + }
> +#endif
> + *argv=kcl_self;
> +
> #ifdef CAN_UNRANDOMIZE_SBRK
> #include <stdio.h>
> #include <stdlib.h>
> @@ -381,19 +394,6 @@
> ARGV = argv;
> ENVP = envp;
>
> -#ifdef GET_FULL_PATH_SELF
> - GET_FULL_PATH_SELF(kcl_self);
> -#else
> - kcl_self = argv[0];
> -#endif
> -#ifdef __MINGW32__
> - {
> - char *s=kcl_self;
> - for (;*s;s++) if (*s=='\\') *s='/';
> - }
> -#endif
> - *argv=kcl_self;
> -
> vs_top = vs_base = vs_org;
> ihs_top = ihs_org-1;
> bds_top = bds_org-1;
> @@ -459,6 +459,8 @@
> /* catch certain signals */
> void install_segmentation_catcher(void)
> {
> + unblock_signals(SIGSEGV,SIGSEGV);
> + unblock_signals(SIGBUS,SIGBUS);
> (void) gcl_signal(SIGSEGV,segmentation_catcher);
> (void) gcl_signal(SIGBUS,segmentation_catcher);
> }
> diff -ruN t1/gcl-2.6.11/o/package.d t2/gcl-2.6.12/o/package.d
> --- t1/gcl-2.6.11/o/package.d 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/package.d 2014-10-23 17:29:00.000000000 -0400
> @@ -895,7 +895,7 @@
>
> @(defun unintern (symbl &optional (p `current_package()`))
> @
> - check_type_symbol(&symbl);
> + check_type_sym(&symbl);
> check_package_designator(p);
> p = coerce_to_package(p);
> if (unintern(symbl, p))
> @@ -924,7 +924,7 @@
> break;
>
> default:
> - check_type_symbol(&symbols);
> + check_type_sym(&symbols);
> goto BEGIN;
> }
> @(return Ct)
> @@ -950,7 +950,7 @@
> break;
>
> default:
> - check_type_symbol(&symbols);
> + check_type_sym(&symbols);
> goto BEGIN;
> }
> @(return Ct)
> @@ -975,7 +975,7 @@
> break;
>
> default:
> - check_type_symbol(&symbols);
> + check_type_sym(&symbols);
> goto BEGIN;
> }
> @(return Ct)
> @@ -1000,7 +1000,7 @@
> break;
>
> default:
> - check_type_symbol(&symbols);
> + check_type_sym(&symbols);
> goto BEGIN;
> }
> @(return Ct)
> diff -ruN t1/gcl-2.6.11/o/prelink.c t2/gcl-2.6.12/o/prelink.c
> --- t1/gcl-2.6.11/o/prelink.c 2014-11-07 10:10:10.000000000 -0500
> +++ t2/gcl-2.6.12/o/prelink.c 2014-10-23 17:29:00.000000000 -0400
> @@ -9,8 +9,8 @@
> my_stdout=stdout;
> my_stderr=stderr;
> #ifdef HAVE_READLINE
> - my_rl_completion_entry_function_ptr=&rl_completion_entry_function;
> - my_rl_readline_name_ptr=&rl_readline_name;
> + my_rl_completion_entry_function_ptr=(void *)&rl_completion_entry_function;
> + my_rl_readline_name_ptr=(void *)&rl_readline_name;
> #endif
>
> }
> diff -ruN t1/gcl-2.6.11/o/sequence.d t2/gcl-2.6.12/o/sequence.d
> --- t1/gcl-2.6.11/o/sequence.d 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/sequence.d 2014-10-23 17:29:00.000000000 -0400
> @@ -112,9 +112,7 @@
> E:
> vs_push(make_fixnum(index));
> /* FIXME message should indicate out of range */
> - Icall_error_handler(sKwrong_type_argument,
> - make_simple_string("The index, ~S, is too large."),
> - 1,vs_head);
> + TYPE_ERROR(make_fixnum(index),MMcons(sLinteger,MMcons(make_fixnum(0),MMcons(make_fixnum(length(seq)),Cnil))));
> return(Cnil);
> }
>
> diff -ruN t1/gcl-2.6.11/o/sfaslelf.c t2/gcl-2.6.12/o/sfaslelf.c
> --- t1/gcl-2.6.11/o/sfaslelf.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/sfaslelf.c 2014-10-23 17:29:00.000000000 -0400
> @@ -181,6 +181,7 @@
> #include RELOC_H
>
> default:
> + fprintf(stderr, "Unknown reloc type %lu\n", tp);
> massert(tp&~tp);
>
> }
> diff -ruN t1/gcl-2.6.11/o/symbol.d t2/gcl-2.6.12/o/symbol.d
> --- t1/gcl-2.6.11/o/symbol.d 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/symbol.d 2014-10-23 17:29:00.000000000 -0400
> @@ -25,6 +25,12 @@
> #include <string.h>
> #include "include.h"
>
> +/*FIXME this symbol is needed my maxima MAKE_SPECIAL*/
> +void
> +check_type_symbol(object *x) {
> + check_type_sym(x);
> +}
> +
> static void
> odd_plist(object);
>
> @@ -366,7 +372,7 @@
> /*
> if (type_of(s) != t_symbol) {
> vs_push(s);
> - check_type_symbol(&vs_head);
> + check_type_sym(&vs_head);
> vs_pop;
> }
> if (s->s.s_hpack == OBJNULL)
> @@ -377,7 +383,7 @@
>
> @(defun get (sym indicator &optional deflt)
> @
> - check_type_symbol(&sym);
> + check_type_sym(&sym);
> @(return `getf(sym->s.s_plist, indicator, deflt)`)
> @)
>
> @@ -385,7 +391,7 @@
> {
> check_arg(2);
>
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> if (remf(&vs_base[0]->s.s_plist, vs_base[1]))
> vs_base[0] = Ct;
> else
> @@ -397,7 +403,7 @@
> {
> check_arg(1);
>
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> vs_base[0] = vs_base[0]->s.s_plist;
> }
>
> @@ -463,7 +469,7 @@
>
> @(defun copy_symbol (sym &optional cp &aux x)
> @
> - check_type_symbol(&sym);
> + check_type_sym(&sym);
> x = make_symbol(sym);
> if (cp == Cnil)
> @(return x)
> @@ -577,7 +583,7 @@
> {
> check_arg(1);
>
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> vs_base[0] = vs_base[0]->s.s_hpack;
> }
>
> @@ -629,7 +635,7 @@
> {
> check_arg(2);
>
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> vs_base[0]->s.s_plist = vs_base[1];
> vs_base[0] = vs_base[1];
> vs_popp;
> @@ -639,7 +645,7 @@
> {
> check_arg(3);
>
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> vs_base[0]->s.s_plist
> = putf(vs_base[0]->s.s_plist, vs_base[1], vs_base[2]);
> vs_base[0] = vs_base[1];
> diff -ruN t1/gcl-2.6.11/o/toplevel.c t2/gcl-2.6.12/o/toplevel.c
> --- t1/gcl-2.6.11/o/toplevel.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/toplevel.c 2014-10-23 17:29:00.000000000 -0400
> @@ -101,7 +101,7 @@
> FFN(siLAmake_special)(void)
> {
> check_arg(1);
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
> FEerror("~S is a constant.", 1, vs_base[0]);
> vs_base[0]->s.s_stype = (short)stp_special;
> @@ -111,7 +111,7 @@
> FFN(siLAmake_constant)(void)
> {
> check_arg(2);
> - check_type_symbol(&vs_base[0]);
> + check_type_sym(&vs_base[0]);
> if ((enum stype)vs_base[0]->s.s_stype == stp_special)
> FEerror(
> "The argument ~S to DEFCONSTANT is a special variable.",
> diff -ruN t1/gcl-2.6.11/o/typespec.c t2/gcl-2.6.12/o/typespec.c
> --- t1/gcl-2.6.11/o/typespec.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/typespec.c 2014-10-23 17:29:00.000000000 -0400
> @@ -28,264 +28,10 @@
> #define NEED_MP_H
> #include "include.h"
>
> -
> -
> -
> object sLkeyword;
>
> -
> -void
> -check_type_integer(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_fixnum && t != t_bignum)
> - *p = wrong_type_argument(sLinteger, *p);
> -}
> -
> -void
> -check_type_non_negative_integer(object *p)
> -{
> - enum type t;
> -
> - for (;;) {
> - t = type_of(*p);
> - if (t == t_fixnum) {
> - if (fix((*p)) >= 0)
> - break;
> - } else if (t == t_bignum) {
> - if (big_sign((*p)) >= 0)
> - break;
> - }
> - *p = wrong_type_argument(TSnon_negative_integer, *p);
> - }
> -}
> -
> -void
> -check_type_rational(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_fixnum &&
> - t != t_bignum && t != t_ratio)
> - *p = wrong_type_argument(sLrational, *p);
> -}
> -
> -void
> -check_type_float(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_shortfloat && t != t_longfloat)
> - *p = wrong_type_argument(sLfloat, *p);
> -}
> -
> -/* static void */
> -/* check_type_or_integer_float(object *p) */
> -/* { */
> -/* enum type t; */
> -
> -/* while ((t = type_of(*p)) != t_fixnum && t != t_bignum && */
> -/* t != t_shortfloat && t != t_longfloat) */
> -/* *p = wrong_type_argument(TSor_integer_float, *p); */
> -/* } */
> -
> -void
> -check_type_or_rational_float(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
> - t != t_ratio && t != t_shortfloat && t != t_longfloat)
> - *p = wrong_type_argument(TSor_rational_float, *p);
> -}
> -
> -void
> -check_type_number(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
> - t != t_ratio && t != t_shortfloat && t != t_longfloat &&
> - t != t_complex)
> - *p = wrong_type_argument(sLnumber, *p);
> -}
> -
> -/* static void */
> -/* check_type_bit(object *p) */
> -/* { */
> -/* while (type_of(*p) != t_fixnum || */
> -/* (fix((*p)) != 0 && fix((*p)) != 1)) */
> -/* *p = wrong_type_argument(sLbit, *p); */
> -/* } */
> -
> -void
> -check_type_character(object *p)
> -{
> - while (type_of(*p) != t_character)
> - *p = wrong_type_argument(sLcharacter, *p);
> -}
> -
> -/* static void */
> -/* check_type_string_char(object *p) */
> -/* { */
> -/* while (type_of(*p) != t_character || */
> -/* char_font((*p)) != 0 || */
> -/* char_bits((*p)) != 0) */
> -/* *p = wrong_type_argument(sLcharacter, *p); */
> -/* } */
> -
> -void
> -check_type_symbol(object *p)
> -{
> - while (type_of(*p) != t_symbol)
> - *p = wrong_type_argument(sLsymbol, *p);
> -}
> -
> -void
> -check_type_or_symbol_string(object *p)
> -{
> - while (type_of(*p) != t_symbol && type_of(*p) != t_string)
> - *p = wrong_type_argument(TSor_symbol_string, *p);
> -}
> -
> -void
> -check_type_or_string_symbol(object *p)
> -{
> - while (type_of(*p) != t_symbol && type_of(*p) != t_string)
> - *p = wrong_type_argument(TSor_string_symbol, *p);
> -}
> -
> -/* static void */
> -/* check_type_or_symbol_string_package(object *p) */
> -/* { */
> -/* while (type_of(*p) != t_symbol && */
> -/* type_of(*p) != t_string && */
> -/* type_of(*p) != t_package) */
> -/* *p = wrong_type_argument(TSor_symbol_string_package, */
> -/* *p); */
> -/* } */
> -
> -void
> -check_type_package(object *p)
> -{
> - while (type_of(*p) != t_package)
> - *p = wrong_type_argument(sLpackage, *p);
> -}
> -
> -void
> -check_type_string(object *p)
> -{
> - while (type_of(*p) != t_string)
> - *p = wrong_type_argument(sLstring, *p);
> -}
> -
> -/* static void */
> -/* check_type_bit_vector(object *p) */
> -/* { */
> -/* while (type_of(*p) != t_bitvector) */
> -/* *p = wrong_type_argument(sLbit_vector, *p); */
> -/* } */
> -
> -void
> -check_type_cons(object *p)
> -{
> - while (type_of(*p) != t_cons)
> - *p = wrong_type_argument(sLcons, *p);
> -}
> -
> -void
> -check_type_stream(object *p)
> -{
> - while (type_of(*p) != t_stream)
> - *p = wrong_type_argument(sLstream, *p);
> -}
> -
> -void
> -check_type_readtable(object *p)
> -{
> - while (type_of(*p) != t_readtable)
> - *p = wrong_type_argument(sLreadtable, *p);
> -}
> -
> -#ifdef UNIX
> -void
> -check_type_or_Pathname_string_symbol(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_pathname &&
> - t != t_string && t != t_symbol)
> - *p = wrong_type_argument(
> - TSor_pathname_string_symbol, *p);
> -}
> -#endif
> -
> -void
> -check_type_or_pathname_string_symbol_stream(object *p)
> -{
> - enum type t;
> -
> - while ((t = type_of(*p)) != t_pathname &&
> - t != t_string && t != t_symbol && t != t_stream)
> - *p = wrong_type_argument(
> - TSor_pathname_string_symbol_stream, *p);
> -}
> -
> -void
> -check_type_random_state(object *p)
> -{
> - while (type_of(*p) != t_random)
> - *p = wrong_type_argument(sLrandom_state, *p);
> -}
> -
> -void
> -check_type_hash_table(object *p)
> -{
> - while (type_of(*p) != t_hashtable)
> - *p = wrong_type_argument(sLhash_table, *p);
> -}
> -
> -void
> -check_type_array(object *p)
> -{
> -BEGIN:
> - switch (type_of(*p)) {
> - case t_array:
> - case t_vector:
> - case t_string:
> - case t_bitvector:
> - return;
> -
> - default:
> - *p = wrong_type_argument(sLarray, *p);
> - goto BEGIN;
> - }
> -}
> -
> -/* static void */
> -/* check_type_vector(object *p) */
> -/* { */
> -/* BEGIN: */
> -/* switch (type_of(*p)) { */
> -/* case t_vector: */
> -/* case t_string: */
> -/* case t_bitvector: */
> -/* return; */
> -
> -/* default: */
> -/* *p = wrong_type_argument(sLvector, *p); */
> -/* goto BEGIN; */
> -/* } */
> -/* } */
> -
> -void
> -check_type(object x, int t)
> -{if (type_of(x) !=t)
> - FEerror("~s is not a ~a",2,
> - x,make_simple_string(tm_table[t].tm_name +1));
> -}
> -
> +enum type t_vtype;
> +int vtypep_fn(object x) {return type_of(x)==t_vtype;}
>
> LFD(Ltype_of)(void)
> {
> @@ -452,6 +198,7 @@
> DEF_ORDINARY("RATIONAL",sLrational,LISP,"");
> DEF_ORDINARY("FLOAT",sLfloat,LISP,"");
> DEF_ORDINARY("STRING-CHAR",sLstring_char,LISP,"");
> +DEF_ORDINARY("REAL",sLreal,LISP,"");
> DEF_ORDINARY("INTEGER",sLinteger,LISP,"");
> DEF_ORDINARY("RATIO",sLratio,LISP,"");
> DEF_ORDINARY("SHORT-FLOAT",sLshort_float,LISP,"");
> @@ -492,8 +239,12 @@
> DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,"");
> DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,"");
> DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,"");
> +DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,"");
> +DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,"");
> +DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,"");
> +DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,"");
>
> -#ifdef ANSI_COMMON_LISP
> +/* #ifdef ANSI_COMMON_LISP */
> /* New ansi types */
> DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,"");
> DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,"");
> @@ -516,10 +267,8 @@
> DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,"");
> DEF_ORDINARY("METHOD",sLmethod,LISP,"");
> /* FIXME -- need this for types in predlib.lsp, why can't we use the keyword sKpackage_error ? */
> -DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,"");
> DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,"");
> DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,"");
> -DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,"");
> DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,"");
> DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,"");
> DEF_ORDINARY("SIMPLE-BASE-STRING",sLsimple_base_string,LISP,"");
> @@ -540,10 +289,8 @@
> DEF_ORDINARY("TWO-WAY-STREAM",sLtwo_way_stream,LISP,"");
> DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,"");
> DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,"");
> -DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,"");
> -DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,"");
> DEF_ORDINARY("WARNING",sLwarning,LISP,"");
> -#endif
> +/* #endif */
>
> DEFCONST("CHAR-SIZE",sSchar_size,SI,small_fixnum(CHAR_SIZE),"Size in bits of a character");
> DEFCONST("SHORT-SIZE",sSshort_size,SI,small_fixnum(CHAR_SIZE*sizeof(short)),"Size in bits of a short integer");
> diff -ruN t1/gcl-2.6.11/o/utils.c t2/gcl-2.6.12/o/utils.c
> --- t1/gcl-2.6.11/o/utils.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/o/utils.c 2014-10-23 17:29:00.000000000 -0400
> @@ -7,7 +7,6 @@
> argument. They may in future allow resetting the argument.
> */
>
> -object CEerror(char *error_str, char *cont_str, int num, object arg1, object arg2, object arg3, object arg4);
> object
> IisSymbol(object f)
> { if (type_of(f) != t_symbol)
> @@ -192,10 +191,10 @@
> and return the actual value (or nil if no values); */
> object
> Ivs_values(void)
> -{ int n = fcall.nvalues = vs_top - vs_base;
> +{ fixnum n = fcall.nvalues = vs_top - vs_base;
> object *b = vs_base,*p=&fcall.values[0];
> object res = (n > 0 ? b[0] : sLnil);
> - if (n>=sizeof(fcall.values)/sizeof(*fcall.values))
> + if (n>=(fixnum)(sizeof(fcall.values)/sizeof(*fcall.values)))
> FEerror("Too many function call values",0);
> while (--n > 0)
> { *++p= *++b;}
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/clcs/gcl_clcs_install.lisp t2/gcl-2.6.12/.pc/2.6.12pre1/clcs/gcl_clcs_install.lisp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/clcs/gcl_clcs_kcl_cond.lisp t2/gcl-2.6.12/.pc/2.6.12pre1/clcs/gcl_clcs_kcl_cond.lisp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/clcs/gcl_clcs_restart.lisp t2/gcl-2.6.12/.pc/2.6.12pre1/clcs/gcl_clcs_restart.lisp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/clcs/gcl_clcs_top_patches.lisp t2/gcl-2.6.12/.pc/2.6.12pre1/clcs/gcl_clcs_top_patches.lisp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpcall.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpcall.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpenv.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpenv.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpeval.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpeval.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpflet.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpflet.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpfun.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpfun.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpinline.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpinline.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmplam.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmplam.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmplet.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmplet.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmploc.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmploc.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpmain.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpmain.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpmulti.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpmulti.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpopt.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpopt.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpspecial.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpspecial.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmptag.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmptag.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmptop.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmptop.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmptype.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmptype.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmputil.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmputil.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpvar.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpvar.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/gcl_cmpwt.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/gcl_cmpwt.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/makefile t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/makefile
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/cmpnew/sys-proclaim.lisp t2/gcl-2.6.12/.pc/2.6.12pre1/cmpnew/sys-proclaim.lisp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/configure t2/gcl-2.6.12/.pc/2.6.12pre1/configure
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/configure.in t2/gcl-2.6.12/.pc/2.6.12pre1/configure.in
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/elf64_ppcle_reloc.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/elf64_ppcle_reloc.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/elf64_ppcle_reloc_special.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/elf64_ppcle_reloc_special.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/elf64_ppc_reloc.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/elf64_ppc_reloc.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/frame.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/frame.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/notcomp.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/notcomp.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/object.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/object.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/powerpc-linux.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/powerpc-linux.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/prelink.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/prelink.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/h/protoize.h t2/gcl-2.6.12/.pc/2.6.12pre1/h/protoize.h
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_arraylib.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_arraylib.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_autoload.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_autoload.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_evalmacros.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_evalmacros.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_listlib.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_listlib.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_loop.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_loop.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_make_defpackage.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_make_defpackage.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_module.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_module.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_serror.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_serror.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/gcl_top.lsp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/gcl_top.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/lsp/sys-proclaim.lisp t2/gcl-2.6.12/.pc/2.6.12pre1/lsp/sys-proclaim.lisp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/makefile t2/gcl-2.6.12/.pc/2.6.12pre1/makefile
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/cfun.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/cfun.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/error.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/error.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/fasldlsym.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/fasldlsym.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/file.d t2/gcl-2.6.12/.pc/2.6.12pre1/o/file.d
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/funlink.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/funlink.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/gbc.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/gbc.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/gcl_readline.d t2/gcl-2.6.12/.pc/2.6.12pre1/o/gcl_readline.d
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/hash.d t2/gcl-2.6.12/.pc/2.6.12pre1/o/hash.d
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/list.d t2/gcl-2.6.12/.pc/2.6.12pre1/o/list.d
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/main.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/main.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/makefun.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/makefun.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/prelink.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/prelink.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/run_process.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/run_process.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/sgbc.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/sgbc.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre1/o/unixsys.c t2/gcl-2.6.12/.pc/2.6.12pre1/o/unixsys.c
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre2/cmpnew/gcl_cmptype.lsp t2/gcl-2.6.12/.pc/2.6.12pre2/cmpnew/gcl_cmptype.lsp
> diff -ruN t1/gcl-2.6.11/.pc/2.6.12pre2/minvers t2/gcl-2.6.12/.pc/2.6.12pre2/minvers
> diff -ruN t1/gcl-2.6.11/.pc/applied-patches t2/gcl-2.6.12/.pc/applied-patches
> diff -ruN t1/gcl-2.6.11/pcl/sys-package.lisp t2/gcl-2.6.12/pcl/sys-package.lisp
> diff -ruN t1/gcl-2.6.11/pcl/sys-proclaim.lisp t2/gcl-2.6.12/pcl/sys-proclaim.lisp
> diff -ruN t1/gcl-2.6.11/unixport/init_ansi_gcl.lsp.in t2/gcl-2.6.12/unixport/init_ansi_gcl.lsp.in
> --- t1/gcl-2.6.11/unixport/init_ansi_gcl.lsp.in 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/init_ansi_gcl.lsp.in 2014-10-23 17:29:00.000000000 -0400
> @@ -1,7 +1,6 @@
> (make-package "COMPILER" :use '("LISP"))
> (import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
> (make-package "SLOOP" :use '("LISP"))
> -(make-package "SERROR" :use '("LISP" "SLOOP"))
> (make-package "ANSI-LOOP" :use '("LISP"))
> (make-package "DEFPACKAGE" :use '("LISP"))
> (make-package "TK" :use '("LISP" "SLOOP"))
> diff -ruN t1/gcl-2.6.11/unixport/init_gcl.lsp.in t2/gcl-2.6.12/unixport/init_gcl.lsp.in
> --- t1/gcl-2.6.11/unixport/init_gcl.lsp.in 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/init_gcl.lsp.in 2014-10-23 17:29:00.000000000 -0400
> @@ -1,7 +1,6 @@
> (make-package "COMPILER" :use '("LISP"))
> (import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
> (make-package "SLOOP" :use '("LISP"))
> -(make-package "SERROR" :use '("LISP" "SLOOP"))
> (make-package "ANSI-LOOP" :use '("LISP"))
> (make-package "DEFPACKAGE" :use '("LISP"))
> (make-package "TK" :use '("LISP" "SLOOP"))
> diff -ruN t1/gcl-2.6.11/unixport/init_pcl_gcl.lsp.in t2/gcl-2.6.12/unixport/init_pcl_gcl.lsp.in
> --- t1/gcl-2.6.11/unixport/init_pcl_gcl.lsp.in 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/init_pcl_gcl.lsp.in 2014-10-23 17:29:00.000000000 -0400
> @@ -1,7 +1,6 @@
> (make-package "COMPILER" :use '("LISP"))
> (import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
> (make-package "SLOOP" :use '("LISP"))
> -(make-package "SERROR" :use '("LISP" "SLOOP"))
> (make-package "ANSI-LOOP" :use '("LISP"))
> (make-package "DEFPACKAGE" :use '("LISP"))
> (make-package "TK" :use '("LISP" "SLOOP"))
> diff -ruN t1/gcl-2.6.11/unixport/init_pre_gcl.lsp.in t2/gcl-2.6.12/unixport/init_pre_gcl.lsp.in
> --- t1/gcl-2.6.11/unixport/init_pre_gcl.lsp.in 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/init_pre_gcl.lsp.in 2014-10-23 17:29:00.000000000 -0400
> @@ -1,7 +1,6 @@
> (make-package "COMPILER" :use '("LISP"))
> (import '(si::proclaimed-function si::proclaimed-closure si::proclaimed-return-type si::proclaimed-arg-types) :compiler)
> (make-package "SLOOP" :use '("LISP"))
> -(make-package "SERROR" :use '("LISP" "SLOOP"))
> (make-package "ANSI-LOOP" :use '("LISP"))
> (make-package "DEFPACKAGE" :use '("LISP"))
> (make-package "TK" :use '("LISP" "SLOOP"))
> diff -ruN t1/gcl-2.6.11/unixport/sys_ansi_gcl.c t2/gcl-2.6.12/unixport/sys_ansi_gcl.c
> --- t1/gcl-2.6.11/unixport/sys_ansi_gcl.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/sys_ansi_gcl.c 2014-10-23 17:29:00.000000000 -0400
> @@ -32,6 +32,7 @@
> 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 @@
> 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 -ruN t1/gcl-2.6.11/unixport/sys_gcl.c t2/gcl-2.6.12/unixport/sys_gcl.c
> --- t1/gcl-2.6.11/unixport/sys_gcl.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/sys_gcl.c 2014-10-23 17:29:00.000000000 -0400
> @@ -29,6 +29,7 @@
> 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 -ruN t1/gcl-2.6.11/unixport/sys_pcl_gcl.c t2/gcl-2.6.12/unixport/sys_pcl_gcl.c
> --- t1/gcl-2.6.11/unixport/sys_pcl_gcl.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/sys_pcl_gcl.c 2014-10-23 17:29:00.000000000 -0400
> @@ -32,6 +32,7 @@
> 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 -ruN t1/gcl-2.6.11/unixport/sys_pre_gcl.c t2/gcl-2.6.12/unixport/sys_pre_gcl.c
> --- t1/gcl-2.6.11/unixport/sys_pre_gcl.c 2014-09-06 11:45:30.000000000 -0400
> +++ t2/gcl-2.6.12/unixport/sys_pre_gcl.c 2014-10-23 17:29:00.000000000 -0400
> @@ -30,6 +30,7 @@
> 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");
> =============================================================================
>
> Thank you so much for your consideration, and your workon Debian!
>
> unblock gcl/2.6.12-1
>
> -- System Information:
> Debian Release: jessie/sid
> APT prefers unstable
> APT policy: (500, 'unstable')
> Architecture: amd64 (x86_64)
>
> Kernel: Linux 3.12.2 (SMP w/4 CPU cores)
> Locale: LANG=en_US.UTF-8, LC_CTYPE=en_US.UTF-8 (charmap=UTF-8)
> Shell: /bin/sh linked to /bin/dash
--
Camm Maguire camm@maguirefamily.org
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
Reply to: