mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-20 11:32:35 -08:00
Add IGNORE declarations and remove some unused variables.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
169d2997df
commit
7a2d30770b
34 changed files with 127 additions and 57 deletions
|
|
@ -55,9 +55,10 @@
|
|||
(setq form `(progn (setf (symbol-function ',name) #',form) ',name))))
|
||||
(values (eval form) nil nil))
|
||||
|
||||
(defun bc-compile-file-pathname (name &key (output-file name) (type :fasl type-supplied-p)
|
||||
verbose print c-file h-file data-file shared-data-file
|
||||
system-p load)
|
||||
(defun bc-compile-file-pathname (name &key (output-file name) (type :fasl)
|
||||
verbose print c-file h-file data-file
|
||||
shared-data-file system-p load)
|
||||
(declare (ignore load c-file h-file data-file shared-data-file system-p verbose print))
|
||||
(let ((extension "fasc"))
|
||||
(case type
|
||||
((:fasl :fas) (setf extension "fasc"))
|
||||
|
|
|
|||
|
|
@ -219,12 +219,15 @@
|
|||
(values (slot-unbound class self (slot-definition-name slotd))))))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class class) self slotd)
|
||||
(declare (ignore class))
|
||||
(si::sl-boundp (standard-instance-get self slotd)))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (val (class class) self slotd)
|
||||
(declare (ignore class))
|
||||
(standard-instance-set val self slotd))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class class) instance slotd)
|
||||
(declare (ignore class))
|
||||
(ensure-up-to-date-instance instance)
|
||||
(let* ((location (slot-definition-location slotd)))
|
||||
(cond ((ext:fixnump location)
|
||||
|
|
@ -244,10 +247,11 @@
|
|||
|
||||
(defmethod slot-missing ((class t) object slot-name operation
|
||||
&optional new-value)
|
||||
(declare (ignore operation new-value))
|
||||
(declare (ignore operation new-value class))
|
||||
(error "~A is not a slot of ~A" slot-name object))
|
||||
|
||||
(defmethod slot-unbound ((class t) object slot-name)
|
||||
(declare (ignore class))
|
||||
(error 'unbound-slot :instance object :name slot-name))
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -106,8 +106,10 @@
|
|||
finally (si::*make-constant '+builtin-classes+ array))
|
||||
|
||||
(defmethod ensure-class-using-class ((class null) name &rest rest)
|
||||
(declare (ignore class))
|
||||
(multiple-value-bind (metaclass direct-superclasses options)
|
||||
(apply #'help-ensure-class rest)
|
||||
(declare (ignore direct-superclasses))
|
||||
(apply #'make-instance metaclass :name name options)))
|
||||
|
||||
(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
|
||||
|
|
@ -121,18 +123,23 @@
|
|||
(apply #'make-instance (find-class class-name) initargs))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class built-in-class) self slotd)
|
||||
(declare (ignore class self slotd))
|
||||
(error "SLOT-MAKUNBOUND-USING-CLASS cannot be applied on built-in objects"))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class built-in-class) self slotd)
|
||||
(declare (ignore class self slotd))
|
||||
(error "SLOT-BOUNDP-USING-CLASS cannot be applied on built-in objects"))
|
||||
|
||||
(defmethod slot-value-using-class ((class built-in-class) self slotd)
|
||||
(declare (ignore class self slotd))
|
||||
(error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects"))
|
||||
|
||||
(defmethod (setf slot-value-using-class) (val (class built-in-class) self slotd)
|
||||
(declare (ignore class self slotd val))
|
||||
(error "SLOT-VALUE-USING-CLASS cannot be applied on built-in objects"))
|
||||
|
||||
(defmethod slot-exists-p-using-class ((class built-in-class) self slotd)
|
||||
(declare (ignore class self slotd))
|
||||
nil)
|
||||
|
||||
;;; ======================================================================
|
||||
|
|
@ -169,7 +176,7 @@
|
|||
(:metaclass structure-class))
|
||||
|
||||
(defmethod make-load-form ((object structure-object) &optional environment)
|
||||
(make-load-form-saving-slots object))
|
||||
(make-load-form-saving-slots object :key environment))
|
||||
|
||||
(defmethod print-object ((obj structure-object) stream)
|
||||
(let* ((class (si:instance-class obj))
|
||||
|
|
|
|||
|
|
@ -62,8 +62,7 @@
|
|||
;; unbound."
|
||||
;; "The values of slots specified as shared in the class Cfrom and
|
||||
;; as local in the class Cto are retained."
|
||||
(let* ((old-local-slotds (class-slots (class-of old-instance)))
|
||||
(new-local-slotds (class-slots (class-of instance))))
|
||||
(let* ((new-local-slotds (class-slots (class-of instance))))
|
||||
(dolist (new-slot new-local-slotds)
|
||||
;; CHANGE-CLASS can only operate on the value of local slots.
|
||||
(when (eq (slot-definition-allocation new-slot) :INSTANCE)
|
||||
|
|
@ -77,6 +76,7 @@
|
|||
instance))
|
||||
|
||||
(defmethod change-class ((instance class) new-class &rest initargs)
|
||||
(declare (ignore new-class initargs))
|
||||
(if (forward-referenced-class-p instance)
|
||||
(call-next-method)
|
||||
(error "The metaclass of a class metaobject cannot be changed.")))
|
||||
|
|
@ -114,7 +114,6 @@
|
|||
(defmethod update-instance-for-redefined-class
|
||||
((instance standard-object) added-slots discarded-slots property-list
|
||||
&rest initargs)
|
||||
(declare (ignore discarded-slots property-list))
|
||||
(check-initargs (class-of instance) initargs
|
||||
(valid-keywords-from-methods
|
||||
(compute-applicable-methods
|
||||
|
|
|
|||
|
|
@ -203,6 +203,7 @@
|
|||
,name (&optional (order :MOST-SPECIFIC-FIRST))
|
||||
((around (:AROUND))
|
||||
(principal (,name) :REQUIRED t))
|
||||
,documentation
|
||||
(let ((main-effective-method
|
||||
`(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL))
|
||||
(if (eql order :MOST-SPECIFIC-LAST)
|
||||
|
|
@ -237,7 +238,6 @@
|
|||
(when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
|
||||
(setf body (rest body))
|
||||
(unless (symbolp (setf generic-function (second x)))
|
||||
(print 1)
|
||||
(syntax-error))))
|
||||
(dolist (group method-groups)
|
||||
(destructuring-bind (group-name predicate &key description
|
||||
|
|
@ -257,7 +257,7 @@
|
|||
(if (eql q '*)
|
||||
`(every #'equal ',p .METHOD-QUALIFIERS.)
|
||||
`(equal ',p .METHOD-QUALIFIERS.))))))
|
||||
(t (print 2) (syntax-error)))))
|
||||
(t (syntax-error)))))
|
||||
(push `(,condition (push .METHOD. ,group-name)) group-checks))
|
||||
(when required
|
||||
(push `(unless ,group-name
|
||||
|
|
@ -307,7 +307,6 @@
|
|||
;;;
|
||||
|
||||
(defun compute-effective-method (gf method-combination applicable-methods)
|
||||
(declare (ignore method-combination-type method-combination-args))
|
||||
(let* ((method-combination-name (car method-combination))
|
||||
(method-combination-args (cdr method-combination)))
|
||||
(if (eq method-combination-name 'STANDARD)
|
||||
|
|
|
|||
|
|
@ -775,7 +775,6 @@ that caused the error. CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the
|
|||
format strings of the error message. ARGS are the arguments to the format
|
||||
strings."
|
||||
(declare (inline apply) ;; So as not to get bogus frames in debugger
|
||||
(ignore error-name)
|
||||
#-ecl-min
|
||||
(c::policy-debug-ihs-frame))
|
||||
(let ((condition (coerce-to-condition datum args 'simple-error 'error)))
|
||||
|
|
|
|||
|
|
@ -68,11 +68,13 @@
|
|||
(defmethod reader-method-class ((class std-class)
|
||||
(direct-slot direct-slot-definition)
|
||||
&rest initargs)
|
||||
(declare (ignore class direct-slot initargs))
|
||||
(find-class 'standard-reader-method))
|
||||
|
||||
(defmethod writer-method-class ((class std-class)
|
||||
(direct-slot direct-slot-definition)
|
||||
&rest initargs)
|
||||
(declare (ignore class direct-slot initargs))
|
||||
(find-class 'standard-writer-method))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
@ -96,7 +98,7 @@
|
|||
(cond ((null old-class)
|
||||
(find-class 'standard-method))
|
||||
((symbolp old-class)
|
||||
(find-class old-class))
|
||||
(find-class (the symbol old-class)))
|
||||
(t
|
||||
old-class))))
|
||||
(si::instance-sig-set gfun)
|
||||
|
|
@ -133,6 +135,7 @@
|
|||
(defun congruent-lambda-p (l1 l2)
|
||||
(multiple-value-bind (r1 opts1 rest1 key-flag1 keywords1 a-o-k1)
|
||||
(si::process-lambda-list l1 'FUNCTION)
|
||||
(declare (ignore a-o-k1))
|
||||
(multiple-value-bind (r2 opts2 rest2 key-flag2 keywords2 a-o-k2)
|
||||
(si::process-lambda-list l2 'FUNCTION)
|
||||
(and (= (length r2) (length r1))
|
||||
|
|
@ -145,7 +148,7 @@
|
|||
(null key-flag2)
|
||||
a-o-k2
|
||||
(null (set-difference (all-keywords keywords1)
|
||||
(all-keywords keywords2))))
|
||||
(all-keywords keywords2))))
|
||||
t))))
|
||||
|
||||
(defun add-method (gf method)
|
||||
|
|
@ -232,7 +235,7 @@ their lambda lists ~A and ~A are not congruent."
|
|||
(mapcar #'type-of args)))
|
||||
|
||||
(defmethod no-next-method (gf method &rest args)
|
||||
(declare (ignore gf args))
|
||||
(declare (ignore gf))
|
||||
(error "In method ~A~%No next method given arguments ~A" method args))
|
||||
|
||||
(defun no-primary-method (gf &rest args)
|
||||
|
|
@ -242,7 +245,8 @@ their lambda lists ~A and ~A are not congruent."
|
|||
;;; Now we protect classes from redefinition:
|
||||
(eval-when (compile load)
|
||||
(defun setf-find-class (new-value name &optional errorp env)
|
||||
(let ((old-class (find-class name nil)))
|
||||
(declare (ignore errorp))
|
||||
(let ((old-class (find-class name nil env)))
|
||||
(cond
|
||||
((typep old-class 'built-in-class)
|
||||
(error "The class associated to the CL specifier ~S cannot be changed."
|
||||
|
|
@ -269,7 +273,7 @@ their lambda lists ~A and ~A are not congruent."
|
|||
(function-to-method 'add-dependent '((c standard-generic-function) function))
|
||||
|
||||
(defmethod add-dependent ((c class) dep)
|
||||
(pushnew c (class-dependents c)))
|
||||
(pushnew dep (class-dependents c)))
|
||||
|
||||
(defmethod remove-dependent ((c standard-generic-function) dep)
|
||||
(setf (generic-function-dependents c)
|
||||
|
|
@ -290,6 +294,7 @@ their lambda lists ~A and ~A are not congruent."
|
|||
|
||||
(defmethod update-dependents ((object generic-function) (dep initargs-updater)
|
||||
&rest initargs)
|
||||
(declare (ignore dep initargs))
|
||||
(recursively-update-classes +the-class+))
|
||||
|
||||
(setf *clos-booted* t)
|
||||
|
|
|
|||
|
|
@ -123,6 +123,7 @@
|
|||
method-combination
|
||||
(method-class (find-class 'method))
|
||||
)
|
||||
(declare (ignore initargs slot-names))
|
||||
;;
|
||||
;; Check the validity of several fields.
|
||||
;;
|
||||
|
|
@ -173,6 +174,7 @@
|
|||
|
||||
(defmethod shared-initialize ((gfun standard-generic-function) slot-names
|
||||
&rest initargs)
|
||||
(declare (ignore initargs slot-names))
|
||||
(call-next-method)
|
||||
(compute-g-f-spec-list gfun)
|
||||
gfun)
|
||||
|
|
@ -216,6 +218,7 @@
|
|||
(method-class 'STANDARD-METHOD method-class-p)
|
||||
(generic-function-class 'STANDARD-GENERIC-FUNCTION)
|
||||
(delete-methods nil))
|
||||
(declare (ignore delete-methods gfun))
|
||||
;; else create a new generic function object
|
||||
(setf args (copy-list args))
|
||||
(remf args :generic-function-class)
|
||||
|
|
@ -242,7 +245,7 @@
|
|||
((macro-function name)
|
||||
(simple-program-error "The symbol ~A is bound to a macro and is not a valid name for a generic function" name))
|
||||
((not *clos-booted*)
|
||||
(setf (fdefinition (or traced name))
|
||||
(setf (fdefinition name)
|
||||
(apply #'ensure-generic-function-using-class nil name args))
|
||||
(fdefinition name))
|
||||
(t
|
||||
|
|
|
|||
|
|
@ -162,6 +162,7 @@
|
|||
(warn "Ignoring class definition for ~S" class)))
|
||||
|
||||
(defun setf-find-class (new-value name &optional errorp env)
|
||||
(declare (ignore errorp env))
|
||||
(let ((old-class (find-class name nil)))
|
||||
(cond
|
||||
((and old-class
|
||||
|
|
|
|||
|
|
@ -139,7 +139,8 @@
|
|||
(> (count-if #'function-boundary (car env)) 1)))
|
||||
|
||||
(defun walk-method-lambda (method-lambda required-parameters env)
|
||||
(declare (si::c-local))
|
||||
(declare (si::c-local)
|
||||
(ignore required-parameters))
|
||||
(let ((call-next-method-p nil)
|
||||
(next-method-p-p nil)
|
||||
(in-closure-p nil))
|
||||
|
|
@ -270,6 +271,7 @@ have disappeared."
|
|||
(defun add-method-keywords (method)
|
||||
(multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys)
|
||||
(si::process-lambda-list (method-lambda-list method) t)
|
||||
(declare (ignore reqs opts rest key-flag))
|
||||
(setf (method-keywords method)
|
||||
(if allow-other-keys
|
||||
't
|
||||
|
|
@ -322,8 +324,6 @@ have disappeared."
|
|||
(defun find-method (gf qualifiers specializers &optional (errorp t))
|
||||
(declare (notinline method-qualifiers))
|
||||
(let* ((method-list (generic-function-methods gf))
|
||||
(required-args (subseq (generic-function-lambda-list gf) 0
|
||||
(length specializers)))
|
||||
found)
|
||||
(dolist (method method-list)
|
||||
(when (and (equal qualifiers (method-qualifiers method))
|
||||
|
|
|
|||
|
|
@ -36,9 +36,10 @@
|
|||
`(slot-makunbound ,object ',slot-name))
|
||||
initialization)))))
|
||||
|
||||
(defun need-to-make-load-form-p (object)
|
||||
(defun need-to-make-load-form-p (object env)
|
||||
"Return T if the object cannot be externalized using the lisp
|
||||
printer and we should rather use MAKE-LOAD-FORM."
|
||||
(declare (ignore env))
|
||||
(let ((*load-form-cache* nil))
|
||||
(declare (special *load-form-cache*))
|
||||
(labels ((recursive-test (object)
|
||||
|
|
@ -80,12 +81,12 @@ printer and we should rather use MAKE-LOAD-FORM."
|
|||
(recursive-test object)
|
||||
nil))))
|
||||
|
||||
(defmethod make-load-form ((object t) &optional environment)
|
||||
(defmethod make-load-form ((object t) &optional env)
|
||||
(flet ((maybe-quote (object)
|
||||
(if (or (consp object) (symbolp object))
|
||||
(list 'quote object)
|
||||
object)))
|
||||
(unless (need-to-make-load-form-p object)
|
||||
(unless (need-to-make-load-form-p object env)
|
||||
(return-from make-load-form (maybe-quote object)))
|
||||
(typecase object
|
||||
(compiled-function
|
||||
|
|
@ -93,10 +94,10 @@ printer and we should rather use MAKE-LOAD-FORM."
|
|||
(si::bc-split object)
|
||||
(unless code
|
||||
(error "Cannot externalize object ~a" object))
|
||||
(values `(si::bc-join ,(make-load-form lex)
|
||||
(values `(si::bc-join ,(make-load-form lex env)
|
||||
',code ; An specialized array, no load form
|
||||
,(make-load-form data)
|
||||
,(make-load-form name)))))
|
||||
,(make-load-form data env)
|
||||
,(make-load-form name env)))))
|
||||
(array
|
||||
(let ((init-forms '()))
|
||||
(values `(make-array ',(array-dimensions object)
|
||||
|
|
@ -105,7 +106,7 @@ printer and we should rather use MAKE-LOAD-FORM."
|
|||
:initial-contents
|
||||
',(loop for i from 0 below (array-total-size object)
|
||||
collect (let ((x (row-major-aref object i)))
|
||||
(if (need-to-make-load-form-p x)
|
||||
(if (need-to-make-load-form-p x env)
|
||||
(progn (push `(setf (row-major-aref ,object ,i) ',x)
|
||||
init-forms)
|
||||
0)
|
||||
|
|
@ -113,7 +114,8 @@ printer and we should rather use MAKE-LOAD-FORM."
|
|||
(and init-forms `(progn ,@init-forms)))))
|
||||
(cons
|
||||
(values `(cons ,(maybe-quote (car object)) nil)
|
||||
(and (rest object) `(rplacd ,(maybe-quote object) ,(maybe-quote (cdr object))))))
|
||||
(and (rest object) `(rplacd ,(maybe-quote object)
|
||||
,(maybe-quote (cdr object))))))
|
||||
(hash-table
|
||||
(let* ((content (ext:hash-table-content object))
|
||||
(make-form `(make-hash-table
|
||||
|
|
@ -121,7 +123,7 @@ printer and we should rather use MAKE-LOAD-FORM."
|
|||
:rehash-size ,(hash-table-rehash-size object)
|
||||
:rehash-threshold ,(hash-table-rehash-threshold object)
|
||||
:test ',(hash-table-test object))))
|
||||
(if (need-to-make-load-form-p content)
|
||||
(if (need-to-make-load-form-p content env)
|
||||
(values
|
||||
make-form
|
||||
`(dolist (i ',(loop for key being each hash-key in object
|
||||
|
|
@ -135,15 +137,17 @@ printer and we should rather use MAKE-LOAD-FORM."
|
|||
(error "Cannot externalize object ~a" object)))))
|
||||
|
||||
(defmethod make-load-form ((object standard-object) &optional environment)
|
||||
(make-load-form-saving-slots object))
|
||||
(make-load-form-saving-slots object :environment environment))
|
||||
|
||||
(defmethod make-load-form ((class class) &optional environment)
|
||||
(declare (ignore environment))
|
||||
(let ((name (class-name class)))
|
||||
(if (and name (eq (find-class name) class))
|
||||
`(find-class ',name)
|
||||
(error "Cannot externalize anonymous class ~A" class))))
|
||||
|
||||
(defmethod make-load-form ((package package) &optional environment)
|
||||
(declare (ignore environment))
|
||||
`(find-package ,(package-name package)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -138,9 +138,11 @@
|
|||
initargs)))
|
||||
|
||||
(defmethod direct-slot-definition-class ((class T) &rest canonicalized-slot)
|
||||
(declare (ignore class canonicalized-slot))
|
||||
(find-class 'standard-direct-slot-definition nil))
|
||||
|
||||
(defmethod effective-slot-definition-class ((class T) &rest canonicalized-slot)
|
||||
(declare (ignore class canonicalized-slot))
|
||||
(find-class 'standard-effective-slot-definition nil))
|
||||
|
||||
(defun has-forward-referenced-parents (class)
|
||||
|
|
@ -155,6 +157,7 @@
|
|||
|
||||
(defmethod initialize-instance ((class class) &rest initargs
|
||||
&key sealedp direct-superclasses direct-slots)
|
||||
(declare (ignore sealedp))
|
||||
;; convert the slots from lists to direct slots
|
||||
(setf direct-slots (loop for s in direct-slots
|
||||
collect (canonical-slot-to-direct-slot class s)))
|
||||
|
|
@ -194,6 +197,7 @@
|
|||
(defmethod shared-initialize ((class std-class) slot-names &rest initargs &key
|
||||
(optimize-slot-access (list *optimize-slot-access*))
|
||||
sealedp)
|
||||
(declare (ignore initargs slot-names))
|
||||
(setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)
|
||||
(slot-value class 'sealedp) (and sealedp t))
|
||||
(setf class (call-next-method))
|
||||
|
|
@ -436,8 +440,10 @@ because it contains a reference to the undefined class~% ~A"
|
|||
;;;
|
||||
(defmethod ensure-class-using-class ((class class) name &rest rest
|
||||
&key direct-slots direct-default-initargs)
|
||||
(declare (ignore direct-default-initargs direct-slots))
|
||||
(multiple-value-bind (metaclass direct-superclasses options)
|
||||
(apply #'help-ensure-class rest)
|
||||
(declare (ignore direct-superclasses))
|
||||
(cond ((forward-referenced-class-p class)
|
||||
(change-class class metaclass))
|
||||
((not (eq (class-of class) metaclass))
|
||||
|
|
@ -758,21 +764,22 @@ because it contains a reference to the undefined class~% ~A"
|
|||
|
||||
(defmethod describe-object ((obj std-class) (stream t))
|
||||
(let ((slotds (class-slots (si:instance-class obj))))
|
||||
(format t "~%~A is an instance of class ~A"
|
||||
(format stream "~%~A is an instance of class ~A"
|
||||
obj (class-name (si:instance-class obj)))
|
||||
(do ((scan slotds (cdr scan))
|
||||
(i 0 (1+ i)))
|
||||
((null scan))
|
||||
(declare (fixnum i))
|
||||
(print (slot-definition-name (car scan))) (princ ": ")
|
||||
(print (slot-definition-name (car scan)) stream)
|
||||
(princ ": " stream)
|
||||
(case (slot-definition-name (car scan))
|
||||
((SUPERIORS INFERIORS PRECEDENCE-LIST)
|
||||
(princ "(")
|
||||
(princ "(" stream)
|
||||
(do* ((scan (si:instance-ref obj i) (cdr scan))
|
||||
(e (car scan) (car scan)))
|
||||
((null scan))
|
||||
(prin1 (class-name e))
|
||||
(when (cdr scan) (princ " ")))
|
||||
(prin1 (class-name e) stream)
|
||||
(when (cdr scan) (princ " " stream)))
|
||||
(princ ")"))
|
||||
(otherwise (prin1 (si:instance-ref obj i))))))
|
||||
(otherwise (prin1 (si:instance-ref obj i) stream)))))
|
||||
obj)
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@
|
|||
(defun function-keywords (method)
|
||||
(multiple-value-bind (reqs opts rest-var key-flag keywords)
|
||||
(si::process-lambda-list (slot-value method 'lambda-list) 'function)
|
||||
(declare (ignore reqs opts rest-var))
|
||||
(when key-flag
|
||||
(do* ((output '())
|
||||
(l (cdr keywords) (cddddr l)))
|
||||
|
|
@ -58,4 +59,5 @@
|
|||
(defclass standard-writer-method (standard-accessor-method) ())
|
||||
|
||||
(defmethod shared-initialize ((method standard-method) slot-names &rest initargs)
|
||||
(declare (ignore initargs method slot-names))
|
||||
(add-method-keywords (call-next-method)))
|
||||
|
|
|
|||
|
|
@ -284,6 +284,7 @@
|
|||
;; CLEAR-INPUT
|
||||
|
||||
(defmethod stream-clear-input ((stream fundamental-character-input-stream))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
(defmethod stream-clear-input ((stream ansi-stream))
|
||||
|
|
@ -296,6 +297,7 @@
|
|||
;; CLEAR-OUTPUT
|
||||
|
||||
(defmethod stream-clear-output ((stream fundamental-output-stream))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
(defmethod stream-clear-output ((stream ansi-stream))
|
||||
|
|
@ -316,12 +318,14 @@
|
|||
(cl:close stream :abort abort))
|
||||
|
||||
(defmethod close ((stream t) &key abort)
|
||||
(declare (ignore abort))
|
||||
(bug-or-error stream 'close))
|
||||
|
||||
|
||||
;; STREAM-ELEMENT-TYPE
|
||||
|
||||
(defmethod stream-element-type ((stream fundamental-character-stream))
|
||||
(declare (ignore stream))
|
||||
'character)
|
||||
|
||||
(defmethod stream-element-type ((stream ansi-stream))
|
||||
|
|
@ -333,6 +337,7 @@
|
|||
;; FINISH-OUTPUT
|
||||
|
||||
(defmethod stream-finish-output ((stream fundamental-output-stream))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
(defmethod stream-finish-output ((stream ansi-stream))
|
||||
|
|
@ -345,6 +350,7 @@
|
|||
;; FORCE-OUTPUT
|
||||
|
||||
(defmethod stream-force-output ((stream fundamental-output-stream))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
(defmethod stream-force-output ((stream ansi-stream))
|
||||
|
|
@ -368,9 +374,11 @@
|
|||
;; INPUT-STREAM-P
|
||||
|
||||
(defmethod input-stream-p ((stream fundamental-stream))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
(defmethod input-stream-p ((stream fundamental-input-stream))
|
||||
(declare (ignore stream))
|
||||
t)
|
||||
|
||||
(defmethod input-stream-p ((stream ansi-stream))
|
||||
|
|
@ -392,7 +400,8 @@
|
|||
;; LINE-COLUMN
|
||||
|
||||
(defmethod stream-line-column ((stream fundamental-character-output-stream))
|
||||
nil)
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
|
||||
;; LISTEN
|
||||
|
|
@ -422,9 +431,11 @@
|
|||
;; OUTPUT-STREAM-P
|
||||
|
||||
(defmethod output-stream-p ((stream fundamental-stream))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
(defmethod output-stream-p ((stream fundamental-output-stream))
|
||||
(declare (ignore stream))
|
||||
t)
|
||||
|
||||
(defmethod output-stream-p ((stream ansi-stream))
|
||||
|
|
@ -473,6 +484,7 @@
|
|||
(cl:unread-char character stream))
|
||||
|
||||
(defmethod stream-unread-char ((stream ansi-stream) character)
|
||||
(declare (ignore character))
|
||||
(bug-or-error stream 'stream-unread-char))
|
||||
|
||||
|
||||
|
|
@ -531,6 +543,7 @@
|
|||
(si:do-read-sequence stream sequence start end))
|
||||
|
||||
(defmethod stream-read-sequence ((stream t) sequence &optional start end)
|
||||
(declare (ignore sequence start end))
|
||||
(bug-or-error stream 'stream-read-sequence))
|
||||
|
||||
|
||||
|
|
@ -551,9 +564,11 @@
|
|||
;; STREAM-P
|
||||
|
||||
(defmethod streamp ((stream stream))
|
||||
(declare (ignore stream))
|
||||
t)
|
||||
|
||||
(defmethod streamp ((stream t))
|
||||
(declare (ignore stream))
|
||||
nil)
|
||||
|
||||
|
||||
|
|
@ -563,6 +578,7 @@
|
|||
(cl:write-byte integer stream))
|
||||
|
||||
(defmethod stream-write-byte ((stream t) integer)
|
||||
(declare (ignore integer))
|
||||
(bug-or-error stream 'stream-write-byte))
|
||||
|
||||
|
||||
|
|
@ -572,6 +588,7 @@
|
|||
(cl:write-char character stream))
|
||||
|
||||
(defmethod stream-write-char ((stream t) character)
|
||||
(declare (ignore character))
|
||||
(bug-or-error stream 'stream-write-char))
|
||||
|
||||
|
||||
|
|
@ -589,6 +606,7 @@
|
|||
(si::do-write-sequence sequence stream start end))
|
||||
|
||||
(defmethod stream-write-sequence ((stream t) sequence &optional start end)
|
||||
(declare (ignore sequence start end))
|
||||
(bug-or-error stream 'stream-write-sequence))
|
||||
|
||||
|
||||
|
|
@ -612,6 +630,7 @@
|
|||
(cl:write-string string stream :start start :end end))
|
||||
|
||||
(defmethod stream-write-string ((stream t) string &optional start end)
|
||||
(declare (ignore string start end))
|
||||
(bug-or-error stream 'stream-write-string))
|
||||
|
||||
|
||||
|
|
@ -663,6 +682,7 @@
|
|||
|
||||
(defmethod stream-file-descriptor ((stream file-stream) &optional (direction
|
||||
:input))
|
||||
(declare (ignore direction))
|
||||
(si:file-stream-fd stream))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -22,8 +22,7 @@
|
|||
(EQ 'SI::HASH-EQ)
|
||||
(EQL 'SI::HASH-EQL)
|
||||
(EQUAL 'SI::HASH-EQUAL)
|
||||
(t (setf test 'EQUALP) 'SI::HASH-EQUALP)))
|
||||
(hash (gensym "HASH")))
|
||||
(t (setf test 'EQUALP) 'SI::HASH-EQUALP))))
|
||||
`(progn
|
||||
(defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil))
|
||||
(defun ,reset-name ()
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@
|
|||
(*current-form* form)
|
||||
(*first-error* t)
|
||||
(*setjmps* 0))
|
||||
;(let ((*print-level* 3)) (print form))
|
||||
(catch *cmperr-tag*
|
||||
(when (consp form)
|
||||
(let ((fun (car form)) (args (cdr form)) fd)
|
||||
|
|
@ -110,7 +109,6 @@
|
|||
&aux def top-output-string
|
||||
(*volatile* " volatile "))
|
||||
|
||||
;(let ((*print-level* 3)) (pprint *top-level-forms*))
|
||||
(setq *top-level-forms* (nreverse *top-level-forms*))
|
||||
(wt-nl1 "#include \"" (brief-namestring h-pathname) "\"")
|
||||
|
||||
|
|
@ -376,7 +374,6 @@ return f2;
|
|||
(equal (ref-ref-clb x) (ref-ref-clb y))
|
||||
(equal (ref-ref x) (ref-ref y))))
|
||||
(similar-var (x y)
|
||||
(print (list (var-loc x) (var-loc y)))
|
||||
(and! (similar-ref x y)
|
||||
(equal (var-name x) (var-name y))
|
||||
(equal (var-kind x) (var-kind y))
|
||||
|
|
@ -390,7 +387,6 @@ return f2;
|
|||
(eql (c1form-sp-change x) (c1form-sp-change y))
|
||||
(eql (c1form-volatile x) (c1form-volatile y))))
|
||||
(similar-fun (x y)
|
||||
(print (list '? (fun-name x) (fun-name y)))
|
||||
(and! (similar-ref x y)
|
||||
(eql (fun-global x) (fun-global y))
|
||||
(eql (fun-exported x) (fun-exported y))
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@
|
|||
(add-object 0 :duplicate t :permanent t))
|
||||
|
||||
(defun add-load-form (object location)
|
||||
(when (clos::need-to-make-load-form-p object)
|
||||
(when (clos::need-to-make-load-form-p object *cmp-env*)
|
||||
(if (not (eq *compiler-phase* 't1))
|
||||
(cmperr "Unable to internalize complex object ~A in ~a phase" object *compiler-phase*)
|
||||
(multiple-value-bind (make-form init-form) (make-load-form object)
|
||||
|
|
|
|||
|
|
@ -2071,7 +2071,7 @@ extern ECL_API cl_object cl_slot_value(cl_object object, cl_object slot);
|
|||
extern ECL_API cl_object cl_slot_exists_p(cl_object object, cl_object slot);
|
||||
|
||||
/* print.lsp */
|
||||
extern ECL_API cl_object clos_need_to_make_load_form_p(cl_object o);
|
||||
extern ECL_API cl_object clos_need_to_make_load_form_p(cl_object o, cl_object env);
|
||||
|
||||
/* defclass.lsp */
|
||||
extern ECL_API cl_object clos_load_defclass(cl_object name, cl_object superclasses, cl_object slots, cl_object options);
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ Gives a global declaration. See DECLARE for possible DECL-SPECs."
|
|||
)
|
||||
|
||||
(defmacro with-compilation-unit (options &rest body)
|
||||
(declare (ignore options))
|
||||
`(progn ,@body))
|
||||
|
||||
;;; Editor.
|
||||
|
|
@ -72,6 +73,7 @@ Displays information about storage allocation in the following format.
|
|||
* number of pages ECL can use.
|
||||
The number of times the garbage collector has been called is not shown, if the
|
||||
number is zero. The optional X is simply ignored."
|
||||
(declare (ignorable x))
|
||||
#+boehm-gc
|
||||
(progn
|
||||
(format t "
|
||||
|
|
|
|||
|
|
@ -184,6 +184,7 @@ An excerpt of the rules used by ECL:
|
|||
"
|
||||
(multiple-value-bind (commands loadrc unprocessed-options)
|
||||
(produce-init-code args rules)
|
||||
(declare (ignore unprocessed-options))
|
||||
(restart-case
|
||||
(handler-bind ((error
|
||||
#'(lambda (c)
|
||||
|
|
|
|||
|
|
@ -250,14 +250,17 @@
|
|||
ppn
|
||||
doc)))))
|
||||
|
||||
#+ecl-min
|
||||
(si::fset 'defmacro
|
||||
#'(ext::lambda-block defmacro (def env)
|
||||
(declare (ignore env))
|
||||
(let* ((name (second def))
|
||||
(vl (third def))
|
||||
(body (cdddr def))
|
||||
(function))
|
||||
(multiple-value-bind (function pprint doc)
|
||||
(sys::expand-defmacro name vl body)
|
||||
(declare (ignore doc))
|
||||
(setq function `(function ,function))
|
||||
(when *dump-defmacro-definitions*
|
||||
(print function)
|
||||
|
|
@ -298,6 +301,7 @@
|
|||
(find-declarations body)
|
||||
(multiple-value-bind (ppn whole dl arg-check)
|
||||
(destructure vl nil)
|
||||
(declare (ignore ppn))
|
||||
`(let* ((,whole ,list) ,@dl)
|
||||
,@decls
|
||||
,@arg-check
|
||||
|
|
@ -317,11 +321,13 @@ or SYMBOL-MACRO forms, and also to evaluate other forms."
|
|||
(declare (si::c-local))
|
||||
(flet ((local-var-error-function (name)
|
||||
#'(lambda (whole env)
|
||||
(declare (ignore whole env))
|
||||
(error
|
||||
"In a MACROLET function you tried to access a local variable, ~A,
|
||||
from the function in which it appears." name)))
|
||||
(local-fun-error-function (name)
|
||||
#'(lambda (whole env)
|
||||
(declare (ignore whole env))
|
||||
(error
|
||||
"In a MACROLET function you tried to access a local function, ~A,
|
||||
from the function in which it appears." name))))
|
||||
|
|
|
|||
|
|
@ -468,8 +468,6 @@ inspect commands, or type '?' to the inspector."
|
|||
(values)))
|
||||
|
||||
(defun inspect (object)
|
||||
(print 'hola)
|
||||
(print ext:*inspector-hook*)
|
||||
(if ext:*inspector-hook*
|
||||
(funcall *inspector-hook* object)
|
||||
(default-inspector object))
|
||||
|
|
|
|||
|
|
@ -111,6 +111,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)."
|
|||
(defmacro define-compiler-macro (&whole whole name vl &rest body)
|
||||
(multiple-value-bind (function pprint doc-string)
|
||||
(sys::expand-defmacro name vl body)
|
||||
(declare (ignore pprint))
|
||||
(setq function `(function ,function))
|
||||
(when *dump-defun-definitions*
|
||||
(print function)
|
||||
|
|
|
|||
|
|
@ -55,6 +55,7 @@
|
|||
;; defmacro.lsp.
|
||||
;;
|
||||
(let ((f #'(ext::lambda-block dolist (whole env)
|
||||
(declare (ignore env))
|
||||
(let (body pop finished control var expr exit)
|
||||
(setq body (rest whole))
|
||||
(when (endp body)
|
||||
|
|
@ -81,6 +82,7 @@
|
|||
(si::fset 'dolist f t))
|
||||
|
||||
(let ((f #'(ext::lambda-block dotimes (whole env)
|
||||
(declare (ignore env))
|
||||
(let (body pop finished control var expr exit)
|
||||
(setq body (rest whole))
|
||||
(when (endp body)
|
||||
|
|
@ -108,6 +110,7 @@
|
|||
(si::fset 'dotimes f t))
|
||||
|
||||
(let ((f #'(ext::lambda-block do/do*-expand (whole env)
|
||||
(declare (ignore env))
|
||||
(let (do/do* control test result vl step let psetq body)
|
||||
(setq do/do* (first whole) body (rest whole))
|
||||
(if (eq do/do* 'do)
|
||||
|
|
|
|||
|
|
@ -96,6 +96,7 @@
|
|||
align (apply #'max (mapcar #'(lambda (field)
|
||||
(multiple-value-bind (field-size field-align)
|
||||
(size-of-foreign-type (second field))
|
||||
(declare (ignore field-size))
|
||||
field-align))
|
||||
(rest type))))
|
||||
(%align-data size align))
|
||||
|
|
|
|||
|
|
@ -239,6 +239,7 @@ strings."
|
|||
;; (EXT:OPTIONAL-ANNOTATION arguments for EXT:ANNOTATE)
|
||||
(si::fset 'ext:optional-annotation
|
||||
#'(ext:lambda-block ext:optional-annotation (whole env)
|
||||
(declare (ignore env #-ecl-min whole))
|
||||
#+ecl-min
|
||||
`(ext:annotate ,@(rest whole)))
|
||||
t)
|
||||
|
|
|
|||
|
|
@ -296,6 +296,7 @@ hash table; otherwise it signals that we have reached the end of the hash table.
|
|||
,@body)))
|
||||
|
||||
(defun sharp-!-reader (stream subchar arg)
|
||||
(declare (ignore arg subchar))
|
||||
(read-line stream)
|
||||
(values))
|
||||
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ by ALLOW-WITH-INTERRUPTS."
|
|||
;; the get-lock statement, to ensure that the unlocking is done with
|
||||
;; interrupts disabled.
|
||||
#+threads
|
||||
(ext:with-unique-names (lock count interrupts)
|
||||
(ext:with-unique-names (lock count)
|
||||
`(let* ((,lock ,lock-form)
|
||||
(,count (mp:lock-count-mine ,lock)))
|
||||
(without-interrupts
|
||||
|
|
|
|||
|
|
@ -56,6 +56,7 @@ is used."
|
|||
AGAIN
|
||||
(multiple-value-bind (found key value)
|
||||
(funcall iterator)
|
||||
(declare (ignore key))
|
||||
(cond
|
||||
(found
|
||||
(when (eq type :inherited)
|
||||
|
|
|
|||
|
|
@ -136,6 +136,7 @@
|
|||
(pretty-out stream char))
|
||||
|
||||
(defmethod gray::stream-force-output ((stream pretty-stream))
|
||||
(declare (ignore stream))
|
||||
;(force-pretty-output stream)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -362,6 +362,7 @@ and is not adjustable."
|
|||
'(SINGLE-FLOAT DOUBLE-FLOAT T)))
|
||||
|
||||
(defun upgraded-array-element-type (element-type &optional env)
|
||||
(declare (ignore env))
|
||||
(let* ((hash (logand 127 (si:hash-eql element-type)))
|
||||
(record (aref *upgraded-array-element-type-cache* hash)))
|
||||
(declare (type (integer 0 127) hash))
|
||||
|
|
@ -378,6 +379,7 @@ and is not adjustable."
|
|||
answer))))
|
||||
|
||||
(defun upgraded-complex-part-type (real-type &optional env)
|
||||
(declare (ignore env))
|
||||
;; ECL does not have specialized complex types. If we had them, the
|
||||
;; code would look as follows
|
||||
;; (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
|
||||
|
|
@ -408,7 +410,6 @@ and is not adjustable."
|
|||
|
||||
(defun error-type-specifier (type)
|
||||
(declare (si::c-local))
|
||||
(print type)
|
||||
(error "~S is not a valid type specifier." type))
|
||||
|
||||
(defun match-dimensions (array pat)
|
||||
|
|
@ -883,7 +884,8 @@ if not possible."
|
|||
;; somewhere up, to denote failure of the decision procedure.
|
||||
;;
|
||||
(defun register-satisfies-type (type)
|
||||
(declare (si::c-local))
|
||||
(declare (si::c-local)
|
||||
(ignore type))
|
||||
(throw '+canonical-type-failure+ 'satisfies))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
|
|
@ -1391,6 +1393,7 @@ if not possible."
|
|||
(values nil nil)))))
|
||||
|
||||
(defun subtypep (t1 t2 &optional env)
|
||||
(declare (ignore env))
|
||||
;; One easy case: types are equal
|
||||
(when (eq t1 t2)
|
||||
(return-from subtypep (values t t)))
|
||||
|
|
|
|||
|
|
@ -68,6 +68,7 @@
|
|||
(let ((function (si::coerce-to-function function)))
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0)))
|
||||
(with-start-end (start end sequence length)
|
||||
(declare (ignore length))
|
||||
(with-key (key)
|
||||
(cond ((>= start end)
|
||||
(if ivsp
|
||||
|
|
@ -416,7 +417,8 @@
|
|||
(defun find (item sequence &key test test-not (start 0) end from-end key)
|
||||
(with-tests (test test-not key)
|
||||
(declare (optimize (speed 3) (safety 0) (debug 0)))
|
||||
(with-start-end (start end sequence l)
|
||||
(with-start-end (start end sequence length)
|
||||
(declare (ignore length))
|
||||
(let ((output nil))
|
||||
(do-sequence (elt sequence start end
|
||||
:output output :index index :specialize t)
|
||||
|
|
|
|||
|
|
@ -43,6 +43,7 @@
|
|||
(defun setf-method-wrapper (name setf-lambda)
|
||||
(declare (si::c-local))
|
||||
#'(lambda (env &rest args)
|
||||
(declare (ignore env))
|
||||
(do-setf-method-expansion name setf-lambda args)))
|
||||
|
||||
(defun do-defsetf (access-fn function)
|
||||
|
|
@ -342,7 +343,6 @@ Does not check if the third gang is a single-element list."
|
|||
(declare (si::c-local))
|
||||
(multiple-value-bind (vars vals stores store-form access-form)
|
||||
(get-setf-expansion place env)
|
||||
(declare (ignore access-form))
|
||||
(cond ((trivial-setf-form place vars stores store-form access-form)
|
||||
(list 'setq place newvalue))
|
||||
((try-simpler-expansion place vars stores newvalue store-form))
|
||||
|
|
|
|||
|
|
@ -503,6 +503,7 @@ Use special code 0 to cancel this operation.")
|
|||
(continue ())))
|
||||
|
||||
(defun terminal-interrupt (&optional (correctablep t))
|
||||
(declare (ignore correctablep))
|
||||
#+threads
|
||||
(mp:without-interrupts
|
||||
(let* ((suspended '())
|
||||
|
|
@ -773,7 +774,7 @@ Use special code 0 to cancel this operation.")
|
|||
(terpri))
|
||||
(values))
|
||||
|
||||
(defun tpl-disassemble-command (&optional no-values)
|
||||
(defun tpl-disassemble-command ()
|
||||
(let*((*print-level* 2)
|
||||
(*print-length* 4)
|
||||
(*print-pretty* t)
|
||||
|
|
@ -785,7 +786,7 @@ Use special code 0 to cancel this operation.")
|
|||
(format t " Function cannot be disassembled.~%"))
|
||||
(values)))
|
||||
|
||||
(defun tpl-lambda-expression-command (&optional no-values)
|
||||
(defun tpl-lambda-expression-command ()
|
||||
(let*(;;(*print-level* 2)
|
||||
;;(*print-length* 4)
|
||||
;;(*print-pretty* t)
|
||||
|
|
@ -972,7 +973,8 @@ Use special code 0 to cancel this operation.")
|
|||
(blocks '())
|
||||
(local-variables '())
|
||||
(special-variables '())
|
||||
(restarts '()))
|
||||
(restarts '())
|
||||
record0 record1)
|
||||
(dolist (record (decode-ihs-env (ihs-env ihs-index)))
|
||||
(cond ((atom record)
|
||||
(push (compiled-function-name record) functions))
|
||||
|
|
@ -1494,7 +1496,8 @@ value."
|
|||
(unwind-protect
|
||||
(handler-bind ((serious-condition
|
||||
(if err-value-p
|
||||
#'(lambda (c)
|
||||
#'(lambda (condition)
|
||||
(declare (ignore condition))
|
||||
(return-from safe-eval err-value))
|
||||
#'invoke-debugger)))
|
||||
(setf output (si::eval-with-env form env)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue