| 1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
|---|
| 4 | ;;; This file is part of OpenMCL. |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
|---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
|---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
|---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
|---|
| 10 | ;;; conflict, the preamble takes precedence. |
|---|
| 11 | ;;; |
|---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
|---|
| 13 | ;;; |
|---|
| 14 | ;;; The LLGPL is also available online at |
|---|
| 15 | ;;; http://opensource.franz.com/preamble.html |
|---|
| 16 | |
|---|
| 17 | |
|---|
| 18 | ;; used by compiler and eval - stuff here is not excised with rest of compiler |
|---|
| 19 | |
|---|
| 20 | |
|---|
| 21 | (in-package :ccl) |
|---|
| 22 | |
|---|
| 23 | #| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it: |
|---|
| 24 | ; for compiler-special-form-p, called by cheap-eval-in-environment |
|---|
| 25 | (defparameter *nx1-compiler-special-forms* |
|---|
| 26 | `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND |
|---|
| 27 | DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE |
|---|
| 28 | LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL |
|---|
| 29 | MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP |
|---|
| 30 | OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET |
|---|
| 31 | SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS)) |
|---|
| 32 | |# |
|---|
| 33 | |
|---|
| 34 | (eval-when (:compile-toplevel) |
|---|
| 35 | (require 'nxenv)) |
|---|
| 36 | |
|---|
| 37 | (defvar *lisp-compiler-version* 666 "I lost count.") |
|---|
| 38 | |
|---|
| 39 | (defvar *nx-compile-time-types* nil) |
|---|
| 40 | (defvar *nx-proclaimed-types* nil) |
|---|
| 41 | (defvar *nx-method-warning-name* nil) |
|---|
| 42 | |
|---|
| 43 | (defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq)) |
|---|
| 44 | |
|---|
| 45 | (let ((policy (%istruct 'compiler-policy |
|---|
| 46 | #'(lambda (env) |
|---|
| 47 | (neq (debug-optimize-quantity env) 3)) ; allow-tail-recursion-elimination |
|---|
| 48 | #'(lambda (env) |
|---|
| 49 | (eq (debug-optimize-quantity env) 3)) ; inhibit-register-allocation |
|---|
| 50 | #'(lambda (env) |
|---|
| 51 | (let* ((safety (safety-optimize-quantity env))) |
|---|
| 52 | (and (< safety 3) |
|---|
| 53 | (>= (speed-optimize-quantity env) |
|---|
| 54 | safety)))) ; trust-declarations |
|---|
| 55 | #'(lambda (env) |
|---|
| 56 | (>= (speed-optimize-quantity env) |
|---|
| 57 | (+ (space-optimize-quantity env) 2))) ; open-code-inline |
|---|
| 58 | #'(lambda (env) |
|---|
| 59 | (and (eq (speed-optimize-quantity env) 3) |
|---|
| 60 | (eq (safety-optimize-quantity env) 0))) ; inhibit-safety-checking |
|---|
| 61 | #'(lambda (env) |
|---|
| 62 | (and (eq (speed-optimize-quantity env) 3) |
|---|
| 63 | (eq (safety-optimize-quantity env) 0))) ; inhibit-event-polling |
|---|
| 64 | #'(lambda (env) |
|---|
| 65 | (neq (debug-optimize-quantity env) 3)) ; inline-self-calls |
|---|
| 66 | #'(lambda (env) |
|---|
| 67 | (and (neq (compilation-speed-optimize-quantity env) 3) |
|---|
| 68 | (neq (safety-optimize-quantity env) 3) |
|---|
| 69 | (neq (debug-optimize-quantity env) 3))) ; allow-transforms |
|---|
| 70 | #'(lambda (var env) ; force-boundp-checks |
|---|
| 71 | (declare (ignore var)) |
|---|
| 72 | (eq (safety-optimize-quantity env) 3)) |
|---|
| 73 | #'(lambda (var val env) ; allow-constant-substitution |
|---|
| 74 | (declare (ignore var val env)) |
|---|
| 75 | t) |
|---|
| 76 | nil ; extensions |
|---|
| 77 | ))) |
|---|
| 78 | (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p) |
|---|
| 79 | (inhibit-register-allocation nil ira-p) |
|---|
| 80 | (trust-declarations nil td-p) |
|---|
| 81 | (open-code-inline nil oci-p) |
|---|
| 82 | (inhibit-safety-checking nil ischeck-p) |
|---|
| 83 | (inhibit-event-polling nil iep-p) |
|---|
| 84 | (inline-self-calls nil iscall-p) |
|---|
| 85 | (allow-transforms nil at-p) |
|---|
| 86 | (force-boundp-checks nil fb-p) |
|---|
| 87 | (allow-constant-substitution nil acs-p)) |
|---|
| 88 | (let ((p (copy-uvector policy))) |
|---|
| 89 | (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination)) |
|---|
| 90 | (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation)) |
|---|
| 91 | (if td-p (setf (policy.trust-declarations p) trust-declarations)) |
|---|
| 92 | (if oci-p (setf (policy.open-code-inline p) open-code-inline)) |
|---|
| 93 | (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking)) |
|---|
| 94 | (if iep-p (setf (policy.inhibit-event-checking p) inhibit-event-polling)) |
|---|
| 95 | (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls)) |
|---|
| 96 | (if at-p (setf (policy.allow-transforms p) allow-transforms)) |
|---|
| 97 | (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks)) |
|---|
| 98 | (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution)) |
|---|
| 99 | p)) |
|---|
| 100 | (defun %default-compiler-policy () policy)) |
|---|
| 101 | |
|---|
| 102 | (%include "ccl:compiler;lambda-list.lisp") |
|---|
| 103 | |
|---|
| 104 | |
|---|
| 105 | |
|---|
| 106 | ;Syntactic Environment Access. |
|---|
| 107 | |
|---|
| 108 | (defun declaration-information (decl-name &optional env) |
|---|
| 109 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 110 | (report-bad-arg env 'lexical-environment)) |
|---|
| 111 | ; *** This needs to deal with things defined with DEFINE-DECLARATION *** |
|---|
| 112 | (case decl-name |
|---|
| 113 | (optimize |
|---|
| 114 | (list |
|---|
| 115 | (list 'speed (speed-optimize-quantity env)) |
|---|
| 116 | (list 'safety (safety-optimize-quantity env)) |
|---|
| 117 | (list 'compilation-speed (compilation-speed-optimize-quantity env)) |
|---|
| 118 | (list 'space (space-optimize-quantity env)) |
|---|
| 119 | (list 'debug (debug-optimize-quantity env)))) |
|---|
| 120 | (declaration |
|---|
| 121 | *nx-known-declarations*))) |
|---|
| 122 | |
|---|
| 123 | (defun function-information (name &optional env &aux decls) |
|---|
| 124 | (let ((name (ensure-valid-function-name name))) |
|---|
| 125 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 126 | (report-bad-arg env 'lexical-environment)) |
|---|
| 127 | (if (special-operator-p name) |
|---|
| 128 | (values :special-form nil nil) |
|---|
| 129 | (flet ((process-new-fdecls (fdecls) |
|---|
| 130 | (dolist (fdecl fdecls) |
|---|
| 131 | (when (eq (car fdecl) name) |
|---|
| 132 | (let ((decl-type (cadr fdecl))) |
|---|
| 133 | (when (and (memq decl-type '(dynamic-extent inline ftype)) |
|---|
| 134 | (not (assq decl-type decls))) |
|---|
| 135 | (push (cdr fdecl) decls))))))) |
|---|
| 136 | (declare (dynamic-extent #'process-new-fdecls)) |
|---|
| 137 | (do* ((root t) |
|---|
| 138 | (contour env (when root (lexenv.parent-env contour)))) |
|---|
| 139 | ((null contour) |
|---|
| 140 | (if (macro-function name) |
|---|
| 141 | (values :macro nil nil) |
|---|
| 142 | (if (fboundp name) |
|---|
| 143 | (values :function |
|---|
| 144 | nil |
|---|
| 145 | (if (assq 'inline decls) |
|---|
| 146 | decls |
|---|
| 147 | (if (proclaimed-inline-p name) |
|---|
| 148 | (push '(inline . inline) decls) |
|---|
| 149 | (if (proclaimed-notinline-p name) |
|---|
| 150 | (push '(inline . notinline) decls))))) |
|---|
| 151 | (values nil nil decls)))) |
|---|
| 152 | (if (eq (uvref contour 0) 'definition-environment) |
|---|
| 153 | (if (assq name (defenv.functions contour)) |
|---|
| 154 | (return (values :macro nil nil)) |
|---|
| 155 | (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour)))) |
|---|
| 156 | (progn |
|---|
| 157 | (process-new-fdecls (lexenv.fdecls contour)) |
|---|
| 158 | (let ((found (assq name (lexenv.functions contour)))) |
|---|
| 159 | (when found |
|---|
| 160 | (return |
|---|
| 161 | (if (and (consp (cdr found))(eq (%cadr found) 'macro)) |
|---|
| 162 | (values :macro t nil) |
|---|
| 163 | (values :function t decls)))))))))))) |
|---|
| 164 | |
|---|
| 165 | (defun variable-information (var &optional env) |
|---|
| 166 | (setq var (require-type var 'symbol)) |
|---|
| 167 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 168 | (report-bad-arg env 'lexical-environment)) |
|---|
| 169 | (let* ((vartype nil) |
|---|
| 170 | (boundp nil) |
|---|
| 171 | (envtype nil) |
|---|
| 172 | (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us. |
|---|
| 173 | (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls))))) |
|---|
| 174 | (loop |
|---|
| 175 | (cond ((null env) |
|---|
| 176 | (if (constant-symbol-p var) |
|---|
| 177 | (setq vartype :constant decls nil) |
|---|
| 178 | (if (proclaimed-special-p var) |
|---|
| 179 | (setq vartype :special) |
|---|
| 180 | (let* ((not-a-symbol-macro (cons nil nil))) |
|---|
| 181 | (declare (dynamic-extent not-a-symbol-macro)) |
|---|
| 182 | (unless (eq (gethash var *symbol-macros* not-a-symbol-macro) |
|---|
| 183 | not-a-symbol-macro) |
|---|
| 184 | (setq vartype :symbol-macro))))) |
|---|
| 185 | (return)) |
|---|
| 186 | ((eq (setq envtype (%svref env 0)) 'definition-environment) |
|---|
| 187 | (cond ((assq var (defenv.constants env)) |
|---|
| 188 | (setq vartype :constant) |
|---|
| 189 | (return)) |
|---|
| 190 | ((assq var (defenv.symbol-macros env)) |
|---|
| 191 | (setq vartype :symbol-macro) |
|---|
| 192 | (return)) |
|---|
| 193 | ((assq var (defenv.specials env)) |
|---|
| 194 | (setq vartype :special) |
|---|
| 195 | (return)))) |
|---|
| 196 | (t |
|---|
| 197 | (dolist (vdecl (lexenv.vdecls env)) |
|---|
| 198 | (when (eq (car vdecl) var) |
|---|
| 199 | (let ((decltype (cadr vdecl))) |
|---|
| 200 | (unless (assq decltype decls) |
|---|
| 201 | (case decltype |
|---|
| 202 | (special (setq vartype :special)) |
|---|
| 203 | ((type dynamic-extent ignore) (push (cdr vdecl) decls))))))) |
|---|
| 204 | (let ((vars (lexenv.variables env))) |
|---|
| 205 | (unless (atom vars) |
|---|
| 206 | (dolist (v vars) |
|---|
| 207 | (when (eq (var-name v) var) |
|---|
| 208 | (setq boundp t) |
|---|
| 209 | (if (and (consp (var-ea v)) |
|---|
| 210 | (eq :symbol-macro (car (var-ea v)))) |
|---|
| 211 | (setq vartype :symbol-macro) |
|---|
| 212 | (unless vartype (setq vartype |
|---|
| 213 | (let* ((bits (var-bits v))) |
|---|
| 214 | (if (and (typep bits 'integer) |
|---|
| 215 | (logbitp $vbitspecial bits)) |
|---|
| 216 | :special |
|---|
| 217 | :lexical))))) |
|---|
| 218 | (return))) |
|---|
| 219 | (when vartype (return)))))) |
|---|
| 220 | (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env)))) |
|---|
| 221 | (values vartype boundp decls))) |
|---|
| 222 | |
|---|
| 223 | (defun nx-target-type (typespec) |
|---|
| 224 | ;; Could do a lot more here |
|---|
| 225 | (if (or (eq *host-backend* *target-backend*) |
|---|
| 226 | (not (eq typespec 'fixnum))) |
|---|
| 227 | typespec |
|---|
| 228 | (target-word-size-case |
|---|
| 229 | (32 '(signed-byte 30)) |
|---|
| 230 | (64 '(signed-byte 61))))) |
|---|
| 231 | |
|---|
| 232 | ; Type declarations affect all references. |
|---|
| 233 | (defun nx-declared-type (sym &optional (env *nx-lexical-environment*)) |
|---|
| 234 | (loop |
|---|
| 235 | (when (or (null env) (eq (uvref env 0) 'definition-environment)) (return)) |
|---|
| 236 | (dolist (decl (lexenv.vdecls env)) |
|---|
| 237 | (if (and (eq (car decl) sym) |
|---|
| 238 | (eq (cadr decl) 'type)) |
|---|
| 239 | (return-from nx-declared-type (nx-target-type (cddr decl))))) |
|---|
| 240 | (let ((vars (lexenv.variables env))) |
|---|
| 241 | (when (and (consp vars) |
|---|
| 242 | (dolist (var vars) |
|---|
| 243 | (when (eq (var-name var) sym) |
|---|
| 244 | (return t)))) |
|---|
| 245 | (return-from nx-declared-type t))) |
|---|
| 246 | (setq env (lexenv.parent-env env))) |
|---|
| 247 | (let ((decl (or (assq sym *nx-compile-time-types*) |
|---|
| 248 | (assq sym *nx-proclaimed-types*)))) |
|---|
| 249 | (if decl (%cdr decl) t))) |
|---|
| 250 | |
|---|
| 251 | (defmacro define-declaration (decl-name lambda-list &body body &environment env) |
|---|
| 252 | (multiple-value-bind (body decls) |
|---|
| 253 | (parse-body body env) |
|---|
| 254 | (let ((fn `(nfunction (define-declaration ,decl-name) |
|---|
| 255 | (lambda ,lambda-list |
|---|
| 256 | ,@decls |
|---|
| 257 | (block ,decl-name |
|---|
| 258 | ,@body))))) |
|---|
| 259 | `(progn |
|---|
| 260 | (proclaim '(declaration ,decl-name)) |
|---|
| 261 | (setf (getf *declaration-handlers* ',decl-name) ,fn))))) |
|---|
| 262 | |
|---|
| 263 | (defun check-environment-args (variable symbol-macro function macro) |
|---|
| 264 | (flet ((check-all-pairs (pairlist argname) |
|---|
| 265 | (dolist (pair pairlist) |
|---|
| 266 | (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair))) |
|---|
| 267 | (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" |
|---|
| 268 | argname |
|---|
| 269 | pair |
|---|
| 270 | 'name |
|---|
| 271 | 'definition |
|---|
| 272 | pairlist)))) |
|---|
| 273 | (check-all-symbols (symlist argname pairs pairsname) |
|---|
| 274 | (dolist (v symlist) |
|---|
| 275 | (unless (symbolp v) |
|---|
| 276 | (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist)) |
|---|
| 277 | (when (assq v pairs) |
|---|
| 278 | (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs)))))) |
|---|
| 279 | (check-all-pairs symbol-macro :symbol-macro) |
|---|
| 280 | (check-all-pairs macro :macro) |
|---|
| 281 | (check-all-symbols variable :variable symbol-macro :symbol-macro) |
|---|
| 282 | (check-all-symbols function :function macro :macro))) |
|---|
| 283 | |
|---|
| 284 | |
|---|
| 285 | ;; This -isn't- PARSE-DECLARATIONS. It can't work; neither can this ... |
|---|
| 286 | (defun process-declarations (env decls symbol-macros) |
|---|
| 287 | (let ((vdecls nil) |
|---|
| 288 | (fdecls nil) |
|---|
| 289 | (mdecls nil)) |
|---|
| 290 | (flet ((add-type-decl (spec) |
|---|
| 291 | (destructuring-bind (typespec &rest vars) spec |
|---|
| 292 | (dolist (var vars) |
|---|
| 293 | (when (non-nil-symbol-p var) |
|---|
| 294 | (push (list* var |
|---|
| 295 | 'type |
|---|
| 296 | (let ((already (assq 'type (nth-value 2 (variable-information var env))))) |
|---|
| 297 | (if already |
|---|
| 298 | (let ((oldtype (%cdr already))) |
|---|
| 299 | (if oldtype |
|---|
| 300 | (if (subtypep oldtype typespec) |
|---|
| 301 | oldtype |
|---|
| 302 | (if (subtypep typespec oldtype) |
|---|
| 303 | typespec)))) |
|---|
| 304 | typespec))) |
|---|
| 305 | vdecls)))))) |
|---|
| 306 | ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it. |
|---|
| 307 | (dolist (decl decls) |
|---|
| 308 | (when (eq (car decl) 'special) |
|---|
| 309 | (dolist (spec (%cdr decl)) |
|---|
| 310 | (when (non-nil-symbol-p spec) |
|---|
| 311 | (if (assq spec symbol-macros) |
|---|
| 312 | (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec)) |
|---|
| 313 | (push (list* spec 'special t) vdecls))))) |
|---|
| 314 | (dolist (decl decls) |
|---|
| 315 | (let ((decltype (car decl))) |
|---|
| 316 | (case decltype |
|---|
| 317 | ((inline notinline) |
|---|
| 318 | (dolist (spec (%cdr decl)) |
|---|
| 319 | (let ((fname nil)) |
|---|
| 320 | (if (non-nil-symbol-p spec) |
|---|
| 321 | (setq fname spec) |
|---|
| 322 | (if (and (consp spec) (eq (%car spec) 'setf)) |
|---|
| 323 | (setq fname (setf-function-name (cadr spec))))) |
|---|
| 324 | (if fname |
|---|
| 325 | (push (list* fname decltype t) fdecls))))) |
|---|
| 326 | (optimize |
|---|
| 327 | (dolist (spec (%cdr decl)) |
|---|
| 328 | (let ((val 3) |
|---|
| 329 | (quantity spec)) |
|---|
| 330 | (if (consp spec) |
|---|
| 331 | (setq quantity (car spec) val (cadr spec))) |
|---|
| 332 | (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed))) |
|---|
| 333 | (push (cons quantity val) mdecls))))) |
|---|
| 334 | (dynamic-extent |
|---|
| 335 | (dolist (spec (%cdr decl)) |
|---|
| 336 | (if (non-nil-symbol-p spec) |
|---|
| 337 | (push (list* spec decltype t) vdecls) |
|---|
| 338 | (if (and (consp spec) (eq (%car spec) 'function)) |
|---|
| 339 | (let ((fname (cadr spec))) |
|---|
| 340 | (if (not (non-nil-symbol-p fname)) |
|---|
| 341 | (setq fname |
|---|
| 342 | (if (and (consp fname) (eq (%car fname) 'setf)) |
|---|
| 343 | (setf-function-name (cadr fname))))) |
|---|
| 344 | (if fname (push (list* fname decltype t) fdecls))))))) |
|---|
| 345 | (type (add-type-decl (cdr decl))) |
|---|
| 346 | (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl) |
|---|
| 347 | (dolist (name fnames) |
|---|
| 348 | (let ((fname name)) |
|---|
| 349 | (if (not (non-nil-symbol-p fname)) |
|---|
| 350 | (setq fname |
|---|
| 351 | (if (and (consp fname) (eq (%car fname) 'setf)) |
|---|
| 352 | (setf-function-name (cadr fname))))) |
|---|
| 353 | (if fname (push (list* fname decltype typespec) fdecls)))))) |
|---|
| 354 | (special) |
|---|
| 355 | (t |
|---|
| 356 | (if (memq decltype *cl-types*) |
|---|
| 357 | (add-type-decl decl) |
|---|
| 358 | (let ((handler (getf *declaration-handlers* decltype))) |
|---|
| 359 | (when handler |
|---|
| 360 | (multiple-value-bind (type info) (funcall handler decl) |
|---|
| 361 | (ecase type |
|---|
| 362 | (:variable |
|---|
| 363 | (dolist (v info) (push (apply #'list* v) vdecls))) |
|---|
| 364 | (:function |
|---|
| 365 | (dolist (f info) (push (apply #'list* f) fdecls))) |
|---|
| 366 | (:declare ;; N.B. CLtL/2 semantics |
|---|
| 367 | (push info mdecls))))))))))) |
|---|
| 368 | (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env)) |
|---|
| 369 | (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env)) |
|---|
| 370 | (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env)))))) |
|---|
| 371 | |
|---|
| 372 | |
|---|
| 373 | (defun cons-var (name &optional (bits 0)) |
|---|
| 374 | (%istruct 'var name bits nil nil nil nil nil)) |
|---|
| 375 | |
|---|
| 376 | |
|---|
| 377 | (defun augment-environment (env &key variable symbol-macro function macro declare) |
|---|
| 378 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 379 | (report-bad-arg env 'lexical-environment)) |
|---|
| 380 | (check-environment-args variable symbol-macro function macro) |
|---|
| 381 | (let* ((vars (mapcar #'cons-var variable)) |
|---|
| 382 | (symbol-macros (mapcar #'(lambda (s) |
|---|
| 383 | (let* ((sym (car s))) |
|---|
| 384 | (unless (and (symbolp sym) |
|---|
| 385 | (not (constantp sym env)) |
|---|
| 386 | (not (eq (variable-information sym env) :special))) |
|---|
| 387 | (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym)) |
|---|
| 388 | (let ((v (cons-var (car s)))) |
|---|
| 389 | (setf (var-expansion v) (cons :symbol-macro (cadr s))) |
|---|
| 390 | v))) |
|---|
| 391 | symbol-macro)) |
|---|
| 392 | (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro)) |
|---|
| 393 | (functions (mapcar #'(lambda (f) (list* f 'function nil)) function)) |
|---|
| 394 | (new-env (new-lexical-environment env))) |
|---|
| 395 | (setf (lexenv.variables new-env) (nconc vars symbol-macros) |
|---|
| 396 | (lexenv.functions new-env) (nconc functions macros)) |
|---|
| 397 | (process-declarations new-env declare symbol-macro) |
|---|
| 398 | new-env)) |
|---|
| 399 | |
|---|
| 400 | (defun enclose (lambda-expression &optional env) |
|---|
| 401 | (if (and env (not (istruct-typep env 'lexical-environment))) |
|---|
| 402 | (report-bad-arg env 'lexical-environment)) |
|---|
| 403 | (unless (lambda-expression-p lambda-expression) |
|---|
| 404 | (error "Invalid lambda-expression ~S." lambda-expression)) |
|---|
| 405 | (%make-function nil lambda-expression env)) |
|---|
| 406 | |
|---|
| 407 | #| Might be nicer to do %declaim |
|---|
| 408 | (defmacro declaim (&rest decl-specs &environment env) |
|---|
| 409 | `(progn |
|---|
| 410 | (eval-when (:load-toplevel :execute) |
|---|
| 411 | (proclaim ',@decl-specs)) |
|---|
| 412 | (eval-when (:compile-toplevel) |
|---|
| 413 | (%declaim ',@decl-specs ,env)))) |
|---|
| 414 | |# |
|---|
| 415 | |
|---|
| 416 | (defmacro declaim (&environment env &rest decl-specs) |
|---|
| 417 | "DECLAIM Declaration* |
|---|
| 418 | Do a declaration or declarations for the global environment." |
|---|
| 419 | (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs))) |
|---|
| 420 | `(progn |
|---|
| 421 | (eval-when (:compile-toplevel) |
|---|
| 422 | (compile-time-proclamation ',decl-specs ,env)) |
|---|
| 423 | (eval-when (:load-toplevel :execute) |
|---|
| 424 | ,@body)))) |
|---|
| 425 | |
|---|
| 426 | ;;; If warnings have more than a single entry on their |
|---|
| 427 | ;;; args slot, don't merge them. |
|---|
| 428 | (defun merge-compiler-warnings (old-warnings) |
|---|
| 429 | (let ((warnings nil)) |
|---|
| 430 | (dolist (w old-warnings) |
|---|
| 431 | (let* ((w-args (compiler-warning-args w))) |
|---|
| 432 | (if |
|---|
| 433 | (or (cdr w-args) |
|---|
| 434 | (dolist (w1 warnings t) |
|---|
| 435 | (let ((w1-args (compiler-warning-args w1))) |
|---|
| 436 | (when (and (eq (compiler-warning-warning-type w) |
|---|
| 437 | (compiler-warning-warning-type w1)) |
|---|
| 438 | w1-args |
|---|
| 439 | (null (cdr w1-args)) |
|---|
| 440 | (eq (%car w-args) |
|---|
| 441 | (%car w1-args))) |
|---|
| 442 | (incf (compiler-warning-nrefs w1)) |
|---|
| 443 | (return))))) |
|---|
| 444 | (push w warnings)))) |
|---|
| 445 | warnings)) |
|---|
| 446 | |
|---|
| 447 | ;;; This is called by, e.g., note-function-info & so can't be -too- funky ... |
|---|
| 448 | ;;; don't call proclaimed-inline-p or proclaimed-notinline-p with |
|---|
| 449 | ;;; alphatized crap |
|---|
| 450 | |
|---|
| 451 | (defun nx-declared-inline-p (sym env) |
|---|
| 452 | (setq sym (maybe-setf-function-name sym)) |
|---|
| 453 | (loop |
|---|
| 454 | (when (listp env) |
|---|
| 455 | (return (and (symbolp sym) |
|---|
| 456 | (proclaimed-inline-p sym)))) |
|---|
| 457 | (dolist (decl (lexenv.fdecls env)) |
|---|
| 458 | (when (and (eq (car decl) sym) |
|---|
| 459 | (eq (cadr decl) 'inline)) |
|---|
| 460 | (return-from nx-declared-inline-p (eq (cddr decl) 'inline)))) |
|---|
| 461 | (setq env (lexenv.parent-env env)))) |
|---|
| 462 | |
|---|
| 463 | (defun report-compile-time-argument-mismatch (condition stream) |
|---|
| 464 | (destructuring-bind (callee reason args spread-p) |
|---|
| 465 | (compiler-warning-args condition) |
|---|
| 466 | (format stream "In the ~a ~s with arguments ~:s,~% " |
|---|
| 467 | (if spread-p "application of" "call to") |
|---|
| 468 | callee |
|---|
| 469 | args) |
|---|
| 470 | (case (car reason) |
|---|
| 471 | (:toomany |
|---|
| 472 | (destructuring-bind (provided max) |
|---|
| 473 | (cdr reason) |
|---|
| 474 | (format stream "~d argument~p were provided, but at most ~d ~a accepted~& by " provided provided max (if (eql max 1) "is" "are")))) |
|---|
| 475 | (:toofew |
|---|
| 476 | (destructuring-bind (provided min) |
|---|
| 477 | (cdr reason) |
|---|
| 478 | (format stream "~d argument~p were provided, but at least ~d ~a required~& by " provided provided min (if (eql min 1) "is" "are") ))) |
|---|
| 479 | (:odd-keywords |
|---|
| 480 | (let* ((tail (cadr reason))) |
|---|
| 481 | (format stream "the variable portion of the argument list ~s contains an odd number~& of arguments and so can't be used to initialize keyword parameters~& for " tail))) |
|---|
| 482 | (:unknown-keyword |
|---|
| 483 | (destructuring-bind (badguy goodguys) |
|---|
| 484 | (cdr reason) |
|---|
| 485 | (format stream "the keyword argument ~s is not one of ~s, which are recognized~& by " badguy goodguys)))) |
|---|
| 486 | (format stream |
|---|
| 487 | (ecase (compiler-warning-warning-type condition) |
|---|
| 488 | (:global-mismatch "the current global definition of ~s") |
|---|
| 489 | (:environment-mismatch "the definition of ~s visible in the current compilation unit.") |
|---|
| 490 | (:lexical-mismatch "the lexically visible definition of ~s")) |
|---|
| 491 | callee))) |
|---|
| 492 | |
|---|
| 493 | (defparameter *compiler-warning-formats* |
|---|
| 494 | '((:special . "Undeclared free variable ~S") |
|---|
| 495 | (:unused . "Unused lexical variable ~S") |
|---|
| 496 | (:ignore . "Variable ~S not ignored.") |
|---|
| 497 | (:undefined-function . "Undefined function ~S") |
|---|
| 498 | (:unknown-declaration . "Unknown declaration ~S") |
|---|
| 499 | (:unknown-type-declaration . "Unknown type ~S") |
|---|
| 500 | (:macro-used-before-definition . "Macro function ~S was used before it was defined.") |
|---|
| 501 | (:unsettable . "Shouldn't assign to variable ~S") |
|---|
| 502 | (:global-mismatch . report-compile-time-argument-mismatch) |
|---|
| 503 | (:environment-mismatch . report-compile-time-argument-mismatch) |
|---|
| 504 | (:lexical-mismatch . report-compile-time-argument-mismatch) |
|---|
| 505 | (:type . "Type declarations violated in ~S") |
|---|
| 506 | (:type-conflict . "Conflicting type declarations for ~S") |
|---|
| 507 | (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.") |
|---|
| 508 | (:lambda . "Suspicious lambda-list: ~s") |
|---|
| 509 | (:result-ignored . "Function result ignored in call to ~s") |
|---|
| 510 | (:program-error . "~a"))) |
|---|
| 511 | |
|---|
| 512 | |
|---|
| 513 | (defun report-compiler-warning (condition stream) |
|---|
| 514 | (let* ((warning-type (compiler-warning-warning-type condition)) |
|---|
| 515 | (format-string (cdr (assq warning-type *compiler-warning-formats*)))) |
|---|
| 516 | (format stream "In ") |
|---|
| 517 | (print-nested-name (reverse (compiler-warning-function-name condition)) stream) |
|---|
| 518 | (format stream ": ") |
|---|
| 519 | (if (typep format-string 'string) |
|---|
| 520 | (apply #'format stream format-string (compiler-warning-args condition)) |
|---|
| 521 | (funcall format-string condition stream)) |
|---|
| 522 | ;(format stream ".") |
|---|
| 523 | (let ((nrefs (compiler-warning-nrefs condition))) |
|---|
| 524 | (when (and nrefs (neq nrefs 1)) |
|---|
| 525 | (format stream " (~D references)" nrefs))))) |
|---|
| 526 | |
|---|
| 527 | (defun environment-structref-info (name env) |
|---|
| 528 | (let ((defenv (definition-environment env))) |
|---|
| 529 | (when defenv |
|---|
| 530 | (cdr (assq name (defenv.structrefs defenv)))))) |
|---|
| 531 | |
|---|
| 532 | ; end |
|---|
