diff --git a/src/cmp/cmpc-inliner.lsp b/src/cmp/cmpc-inliner.lsp index ed0540d41..a507a4d23 100644 --- a/src/cmp/cmpc-inliner.lsp +++ b/src/cmp/cmpc-inliner.lsp @@ -51,14 +51,14 @@ ;; the variable *INLINE-BLOCKS*. (and (inline-possible fname) (not (gethash fname *c2-dispatch-table*)) - (let* ((dest-rep-type (loc-representation-type *destination*)) + (let* (;; (dest-rep-type (loc-representation-type *destination*)) (ii (get-inline-info fname arg-types return-type return-rep-type))) ii))) (defun apply-inline-info (ii inlined-locs) (let* ((arg-types (inline-info-arg-types ii)) (out-rep-type (inline-info-return-rep-type ii)) - (out-type (inline-info-return-type ii)) + ;; (out-type (inline-info-return-type ii)) (side-effects-p (function-may-have-side-effects (inline-info-name ii))) (fun (inline-info-expansion ii)) (one-liner (inline-info-one-liner ii))) diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp index 6e6d64e8b..4514a4640 100644 --- a/src/cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -64,14 +64,16 @@ (mapc #'wt1 forms)) ;;; Blocks beyond this value will not be indented -(defvar +max-depth+ 10) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +max-depth+ 10)) + (defvar +c-newline-indent-strings+ #.(coerce (let ((basis (make-array (1+ +max-depth+) :initial-element #\Space :element-type 'base-char))) (setf (aref basis 0) #\Newline) (loop for i from 0 to +max-depth+ - collect (subseq basis 0 (1+ i)))) + collect (subseq basis 0 (1+ i)))) 'vector)) (defun wt-nl-indent () @@ -136,7 +138,7 @@ ((or (eq c #\Newline) (eq c #\Tab)) (princ c stream)) ((or (< code 32) (> code 127)) - (format stream "\ux" code)) + (format stream "\u~x" code)) ((and (char= c #\*) (char= (schar text (1+ n)) #\/)) (princ #\\ stream)) (t @@ -184,6 +186,7 @@ (defun wt-filtered-data (string stream &key one-liner (external-format #-unicode :default #+unicode :utf-8)) + (declare (ignorable external-format)) #+unicode (setf string (encode-string string external-format)) (let ((N (length string)) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index b0ff95964..086fa9bce 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -110,7 +110,7 @@ (c2expr* form) (list type temp)) (list type - (list 'SYS:STRUCTURE-REF + (list 'si:STRUCTURE-REF (first (coerce-locs (inline-args (list (c1form-arg 0 form))))) (c1form-arg 1 form) @@ -125,7 +125,7 @@ (c2expr* form) (list type temp)) (list type - (list 'SYS:INSTANCE-REF + (list 'si:instance-ref (first (coerce-locs (inline-args (list (c1form-arg 0 form))))) (c1form-arg 1 form) @@ -140,10 +140,10 @@ (emit-inlined-variable form forms)) (CALL-GLOBAL (emit-inlined-call-global form (c1form-primary-type form))) - (SYS:STRUCTURE-REF + (si:STRUCTURE-REF (emit-inlined-structure-ref form forms)) #+clos - (SYS:INSTANCE-REF + (si:INSTANCE-REF (emit-inlined-instance-ref form forms)) (SETQ (emit-inlined-setq form forms)) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index e0fbefa09..762900507 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -24,7 +24,7 @@ (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) - (if (<= l si::c-arguments-limit) + (if (<= l si:c-arguments-limit) (make-c1form* 'FUNCALL :sp-change t :side-effects t :args (c1expr fun) (c1args* arguments)) (unoptimized-long-call fun arguments)))) @@ -101,7 +101,7 @@ form))) (let* ((fun (first args)) (arguments (rest args))) - (cond ((eql (first (last arguments)) 'clos::.combined-method-args.) + (cond ((eql (first (last arguments)) 'clos:.combined-method-args.) ;; Uses frames instead of lists as last argumennt (default-apply fun arguments)) ((and (consp fun) @@ -257,7 +257,7 @@ ;;; arguments) expression into an equivalent let* statement. Returns ;;; the bindings and body as two values. (defun transform-funcall/apply-into-let* (lambda-form arguments apply-p - &aux body apply-list apply-var + &aux apply-list apply-var let-vars extra-stmts all-keys) (multiple-value-bind (requireds optionals rest key-flag keywords allow-other-keys aux-vars) diff --git a/src/cmp/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index 89f57cc54..01bddb9ef 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -121,7 +121,7 @@ ;; inconsistent. ((and (not item) (not duplicate) (symbolp object) (multiple-value-bind (foundp symbol) - (si::mangle-name object) + (si:mangle-name object) (and foundp (return-from add-object symbol))))) (t diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp index 5f4c0809d..da447459f 100644 --- a/src/cmp/cmppass1-fun.lsp +++ b/src/cmp/cmppass1-fun.lsp @@ -278,6 +278,7 @@ (var (c1make-var name ss is ts)) (init (third specs)) (flag (fourth specs))) + (declare (ignore key)) (setq init (if init (and-form-type (var-type var) (c1expr init) init :safe "In (LAMBDA ~a...)" function-name) diff --git a/src/cmp/cmppass1-special.lsp b/src/cmp/cmppass1-special.lsp index 04e40a48c..e40b681ae 100644 --- a/src/cmp/cmppass1-special.lsp +++ b/src/cmp/cmppass1-special.lsp @@ -61,7 +61,7 @@ (setq args (progv symbols values (c1progn (cdr args)))) (make-c1form 'ext:compiler-let args symbols values args)) -(defun c1function (args &aux fd) +(defun c1function (args) (check-args-number 'FUNCTION args 1 1) (let ((fun (car args))) (cond ((si::valid-function-name-p fun) diff --git a/src/cmp/cmppass1-stack.lsp b/src/cmp/cmppass1-stack.lsp index f45ed4ecc..ff091691b 100644 --- a/src/cmp/cmppass1-stack.lsp +++ b/src/cmp/cmppass1-stack.lsp @@ -30,6 +30,7 @@ :args body))) (defun c1innermost-stack-frame (args) + (declare (ignore args)) `(ffi:c-inline () () :object "_ecl_inner_frame" :one-liner t :side-effects nil)) diff --git a/src/cmp/cmppass1-top.lsp b/src/cmp/cmppass1-top.lsp index ee4fed445..22f6df3ca 100644 --- a/src/cmp/cmppass1-top.lsp +++ b/src/cmp/cmppass1-top.lsp @@ -117,7 +117,7 @@ (destructuring-bind (name lambda-list &rest body) args (multiple-value-bind (function pprint doc-string) - (sys::expand-defmacro name lambda-list body) + (si:expand-defmacro name lambda-list body) (declare (ignore pprint doc-string)) (let ((fn (cmp-eval function *cmp-env*))) (cmp-env-register-global-macro name fn)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 1d4f3b010..8cbce8b8b 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -22,9 +22,11 @@ `(format *standard-output* ,string ,@args)))) (defun p1ordinary (c1form assumptions form) + (declare (ignore c1form)) (p1propagate form assumptions)) (defun p1fset (c1form assumptions fun fname macro pprint c1forms) + (declare (ignore c1form fun fname macro pprint c1forms)) (values 'function assumptions)) (defun p1propagate (form assumptions) @@ -67,13 +69,14 @@ (values type assumptions))) (defun p1values (form assumptions values) + (declare (ignore form)) (loop for v in values - collect (multiple-value-bind (type new-assumptions) - (p1propagate v assumptions) - (setf assumptions new-assumptions) - (values-type-primary-type type)) - into all-values - finally (return (values `(values ,@all-values) assumptions)))) + collect (multiple-value-bind (type new-assumptions) + (p1propagate v assumptions) + (setf assumptions new-assumptions) + (values-type-primary-type type)) + into all-values + finally (return (values `(values ,@all-values) assumptions)))) (defun p1propagate-list (list assumptions) (loop with final-type = t @@ -91,10 +94,12 @@ of the occurrences in those lists." (baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions"))) (defun revise-var-type (variable assumptions where-to-stop) + (declare (ignore variable)) (unless (and (null assumptions) (null where-to-stop)) (baboon :format-control "REVISE-VAR-TYPE got a non-empty list of assumptions"))) (defun p1block (c1form assumptions blk body) + (declare (ignore c1form)) (setf (blk-type blk) nil) (multiple-value-bind (normal-type assumptions) (p1propagate body assumptions) @@ -103,6 +108,7 @@ of the occurrences in those lists." assumptions)))) (defun p1return-from (c1form assumptions blk return-type value) + (declare (ignore c1form return-type)) (let* ((values-type (p1propagate value assumptions)) (blk-type (blk-type blk))) (setf (blk-type blk) (if blk-type @@ -111,39 +117,49 @@ of the occurrences in those lists." (values values-type assumptions))) (defun p1call-global (c1form assumptions fname args) + (declare (ignore c1form)) (loop for v in args - do (multiple-value-bind (arg-type local-ass) - (p1propagate v assumptions) - (setf assumptions local-ass)) - finally (let ((type (propagate-types fname args))) - (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" - fname (mapcar #'c1form-primary-type args) - type (c1form-type c1form)) - (return (values type assumptions))))) + do (multiple-value-bind (arg-type local-ass) + (p1propagate v assumptions) + (declare (ignore arg-type)) + (setf assumptions local-ass)) + finally (let ((type (propagate-types fname args))) + (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" + fname (mapcar #'c1form-primary-type args) + type (c1form-type c1form)) + (return (values type assumptions))))) (defun p1call-local (c1form assumptions fun args) + (declare (ignore c1form)) (loop for v in args - do (multiple-value-bind (arg-type local-ass) - (p1propagate v assumptions) - (setf assumptions local-ass)) - finally (return (values (fun-return-type fun) - assumptions)))) + do (multiple-value-bind (arg-type local-ass) + (p1propagate v assumptions) + (declare (ignore arg-type)) + (setf assumptions local-ass)) + finally (return (values (fun-return-type fun) + assumptions)))) (defun p1catch (c1form assumptions tag body) + (declare (ignore c1form)) (multiple-value-bind (tag-type assumptions) (p1propagate tag assumptions) + (declare (ignore tag-type)) (p1propagate body assumptions)) (values t assumptions)) (defun p1throw (c1form assumptions catch-value output-value) + (declare (ignore c1form)) (multiple-value-bind (type new-assumptions) (p1propagate catch-value assumptions) + (declare (ignore type)) (p1propagate output-value new-assumptions)) (values t assumptions)) (defun p1if (c1form assumptions fmla true-branch false-branch) + (declare (ignore c1form)) (multiple-value-bind (fmla-type base-assumptions) (p1propagate fmla assumptions) + (declare (ignore fmla-type)) (multiple-value-bind (t1 a1) (p1propagate true-branch base-assumptions) (multiple-value-bind (t2 a2) @@ -152,40 +168,45 @@ of the occurrences in those lists." (p1merge-branches base-assumptions (list a1 a2))))))) (defun p1fmla-not (c1form assumptions form) + (declare (ignore c1form)) (multiple-value-bind (type assumptions) (p1propagate form assumptions) + (declare (ignore type)) (values '(member t nil) assumptions))) (defun p1fmla-and (c1form orig-assumptions butlast last) + (declare (ignore c1form)) (loop with type = t - with assumptions = orig-assumptions - for form in (append butlast (list last)) - collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - assumptions) - into assumptions-list - finally (return (values (type-or 'null (values-type-primary-type type)) - (p1merge-branches orig-assumptions - assumptions-list))))) + with assumptions = orig-assumptions + for form in (append butlast (list last)) + collect (progn + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + assumptions) + into assumptions-list + finally (return (values (type-or 'null (values-type-primary-type type)) + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1fmla-or (c1form orig-assumptions butlast last) + (declare (ignore c1form)) (loop with type - with output-type = t - with assumptions = orig-assumptions - for form in (append butlast (list last)) - collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - (setf output-type (type-or (values-type-primary-type type) - output-type)) - assumptions) - into assumptions-list - finally (return (values output-type - (p1merge-branches orig-assumptions - assumptions-list))))) + with output-type = t + with assumptions = orig-assumptions + for form in (append butlast (list last)) + collect (progn + (multiple-value-setq (type assumptions) + (p1propagate form assumptions)) + (setf output-type (type-or (values-type-primary-type type) + output-type)) + assumptions) + into assumptions-list + finally (return (values output-type + (p1merge-branches orig-assumptions + assumptions-list))))) (defun p1lambda (c1form assumptions lambda-list doc body &rest not-used) + (declare (ignore c1form lambda-list doc not-used)) (prop-message "~&;;;~&;;; Propagating function~&;;;") (let ((type (p1propagate body assumptions))) (values type assumptions))) @@ -197,66 +218,75 @@ of the occurrences in those lists." assumptions))) (defun p1let* (c1form base-assumptions vars forms body) + (declare (ignore c1form)) (let ((assumptions base-assumptions)) (loop with type - for v in vars - for f in forms - unless (or (global-var-p v) (var-set-nodes v)) - do (progn - (multiple-value-setq (type assumptions) (p1propagate f assumptions)) - (setf (var-type v) (type-and (values-type-primary-type type) - (var-type v))) - (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v)))) + for v in vars + for f in forms + unless (or (global-var-p v) (var-set-nodes v)) + do (progn + (multiple-value-setq (type assumptions) (p1propagate f assumptions)) + (setf (var-type v) (type-and (values-type-primary-type type) + (var-type v))) + (prop-message "~&;;; Variable ~A assigned type ~A" + (var-name v) (var-type v)))) (multiple-value-bind (type assumptions) (p1propagate body assumptions) (loop for v in vars - do (revise-var-type v assumptions base-assumptions)) + do (revise-var-type v assumptions base-assumptions)) (values type assumptions)))) (defun p1locals (c1form assumptions funs body labels) + (declare (ignore c1form labels)) (loop for f in funs - do (p1propagate-function f assumptions)) + do (p1propagate-function f assumptions)) (p1propagate body assumptions)) (defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body) + (declare (ignore c1form)) (multiple-value-bind (init-form-type assumptions) (p1propagate init-c1form assumptions) (loop for v in vars-list - for type in (values-type-to-n-types init-form-type (length vars-list)) - unless (or (global-var-p v) - (var-set-nodes v)) - do (setf (var-type v) (type-and (var-type v) type)) and - do (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v))) + for type in (values-type-to-n-types init-form-type (length vars-list)) + unless (or (global-var-p v) + (var-set-nodes v)) + do (setf (var-type v) (type-and (var-type v) type)) and + do (prop-message "~&;;; Variable ~A assigned type ~A" + (var-name v) (var-type v))) (p1propagate body assumptions))) (defun p1multiple-value-setq (c1form assumptions vars-list value-c1form) + (declare (ignore c1form vars-list)) (multiple-value-bind (init-form-type assumptions) (p1propagate value-c1form assumptions) (values init-form-type assumptions))) (defun p1progn (c1form assumptions forms) + (declare (ignore c1form)) (p1propagate-list forms assumptions)) (defun p1compiler-typecase (c1form assumptions variable expressions) + (declare (ignore c1form)) (let ((var-type (var-type variable))) (loop with output-type = t - for (a-type c1form) in expressions - for c1form-type = (p1propagate c1form assumptions) - when (or (member a-type '(t otherwise)) - (subtypep var-type a-type)) - do (setf output-type c1form-type) - finally (return (values output-type assumptions))))) + for (a-type c1form) in expressions + for c1form-type = (p1propagate c1form assumptions) + when (or (member a-type '(t otherwise)) + (subtypep var-type a-type)) + do (setf output-type c1form-type) + finally (return (values output-type assumptions))))) (defun p1checked-value (c1form assumptions type value let-form) - (let* ((value-type (p1propagate value assumptions)) - (alt-type (p1propagate let-form assumptions))) + (declare (ignore c1form let-form)) + (let ((value-type (p1propagate value assumptions)) + ;;(alt-type (p1propagate let-form assumptions)) + ) (if (subtypep value-type type) value-type type))) (defun p1progv (c1form assumptions variables values body) + (declare (ignore c1form)) (let (type) (multiple-value-setq (type assumptions) (p1propagate variables assumptions)) @@ -272,17 +302,20 @@ of the occurrences in those lists." assumptions))) (defun p1psetq (c1form assumptions vars c1forms) + (declare (ignore c1form vars)) (loop for form in c1forms - do (multiple-value-bind (new-type assumptions) - (p1propagate form assumptions))) + do (p1propagate form assumptions)) (values 'null assumptions)) (defun p1with-stack (c1form assumptions body) + (declare (ignore c1form)) (p1propagate body assumptions)) (defun p1stack-push-values (c1form assumptions form inline) + (declare (ignore c1form inline)) (multiple-value-bind (form-type assumptions) (p1propagate form assumptions) + (declare (ignore form-type)) (values nil assumptions))) (defvar *tagbody-depth* -1 @@ -291,6 +324,7 @@ of the occurrences in those lists." as 2^*tagbody-limit* in the worst cases.") (defun p1go (c1form assumptions tag-var return-type) + (declare (ignore c1form tag-var return-type)) (values t assumptions)) (defun filter-only-declarations (assumptions) @@ -305,7 +339,7 @@ as 2^*tagbody-limit* in the worst cases.") (values 'null (append (p1merge-branches nil ass-list) orig-assumptions)))) (defun p1tagbody-one-pass (c1form assumptions tag-loc body) - (declare (ignore tag-loc)) + (declare (ignore c1form tag-loc)) (loop with local-ass = assumptions with ass-list = '() with aux diff --git a/src/cmp/cmptype-assert.lsp b/src/cmp/cmptype-assert.lsp index 591b7f2c4..a449d9d3f 100644 --- a/src/cmp/cmptype-assert.lsp +++ b/src/cmp/cmptype-assert.lsp @@ -143,7 +143,7 @@ value let-form))) -(defmacro optional-type-assertion (&whole whole value type &environment env) +(defmacro optional-type-assertion (value type &environment env) "If safety settings are high enough, generates a type check on an expression, ensuring that it is satisfied." (when (and (policy-type-assertions env) @@ -151,7 +151,7 @@ expression, ensuring that it is satisfied." (cmpdebug "Checking type of ~A to be ~A" value type) `(ext:checked-value ,type ,value))) -(defmacro type-assertion (&whole whole value type &environment env) +(defmacro type-assertion (value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." (cmpdebug "Checking type of ~A to be ~A" value type) (unless (trivial-type-p type) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 664382292..55132af6b 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -182,7 +182,7 @@ "if (ecl_unlikely(!(#0))) FEwrong_type_argument(#1,#2);" :one-liner nil)))) -(defmacro assert-type-if-known (&whole whole value type &environment env) +(defmacro assert-type-if-known (value type &environment env) "Generates a type check on an expression, ensuring that it is satisfied." (multiple-value-bind (trivial valid) (subtypep 't type) @@ -211,8 +211,7 @@ (otherwise type))))) -(defmacro optional-type-check (&whole whole value type &environment env) - (declare (ignore env)) +(defmacro optional-type-check (value type) (if (policy-assume-right-type) value `(assert-type-if-known ,value ,type)))