Changeset 12069


Ignore:
Timestamp:
May 15, 2009, 3:18:52 PM (10 years ago)
Author:
gz
Message:

merge r12050

Location:
trunk/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx0.lisp

    r12045 r12069  
    10691069
    10701070(defun %proclaim-optimize (specs &aux q v)
    1071  (dolist (spec specs)
    1072   (if (atom spec)
    1073    (setq q spec v 3)
    1074    (setq q (%car spec) v (cadr spec)))
    1075   (when (and (fixnump v) (<= 0 v 3))
    1076    (if (eq q 'speed)
    1077     (setq *nx-speed* v)
    1078     (if (eq q 'space)
    1079      (setq *nx-space* v)
    1080      (if (eq q 'compilation-speed)
    1081       (setq *nx-cspeed* v)
    1082       (if (eq q 'safety)
    1083        (setq *nx-safety* v)
    1084        (if (eq q 'debug)
    1085          (setq *nx-debug* v)))))))))
     1071  (dolist (spec specs)
     1072    (if (atom spec)
     1073      (setq q spec v 3)
     1074      (setq q (%car spec) v (cadr spec)))
     1075    (or (and (fixnump v)
     1076             (<= 0 v 3)
     1077             (case q
     1078               (speed (setq *nx-speed* v))
     1079               (space (setq *nx-space* v))
     1080               (compilation-speed (setq *nx-cspeed* v))
     1081               (safety (setq *nx-safety* v))
     1082               (debug (setq *nx-debug* v))))
     1083        (bad-proclaim-spec `(optimize ,spec)))))
    10861084
    10871085(defun nx-lexical-finfo (sym &optional (env *nx-lexical-environment*))
  • trunk/source/level-1/l1-aprims.lisp

    r11958 r12069  
    295295  (multiple-value-bind (valid-p nm) (valid-function-name-p name)
    296296    (if valid-p nm (error "Invalid function name ~s." name))))
     297
     298
     299(defun maybe-setf-function-name (name)
     300  (if (and (consp name) (eq (car name) 'setf))
     301    (setf-function-name (cadr name))
     302    name))
    297303
    298304
  • trunk/source/level-1/l1-readloop.lisp

    r12045 r12069  
    587587            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
    588588       (and info (def-info.function-p (cdr info)) info)))))
    589 
    590 (defun maybe-setf-function-name (name)
    591   (if (and (consp name) (eq (car name) 'setf))
    592     (setf-function-name (cadr name))
    593     name))
    594589
    595590;;; Must differ from -something-, but not sure what ...
  • trunk/source/level-1/l1-utils.lisp

    r12045 r12069  
    535535    (type (apply #'proclaim-type (%cdr spec)))
    536536    (ftype (apply #'proclaim-ftype (%cdr spec)))
    537     ;(function (proclaim-ftype (cons 'function (cddr spec)) (cadr spec)))
    538     (t (unless (memq (%car spec) *nx-known-declarations*) ;not really right...
     537    (function (apply #'proclaim-type spec))
     538    (t (unless (memq (%car spec) *nx-known-declarations*)
    539539         ;; Any type name is now (ANSI CL) a valid declaration.  Any symbol could become a type.
    540540         (if (symbolp (%car spec))
     
    542542           (warn "Unknown declaration specifier(s) in ~S" spec))))))
    543543
     544(defun bad-proclaim-spec (spec)
     545  (signal-program-error "Invalid declaration specifier ~s" spec))
     546
    544547(defun proclaim-type (type &rest vars)
    545548  (declare (dynamic-extent vars))
     549  ;; Called too early to use (every #'symbolp vars)
     550  (unless (loop for v in vars always (symbolp v)) (bad-proclaim-spec `(,type ,@vars)))
     551  (when *type-system-initialized*
     552    ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     553    (handler-case (specifier-type type)
     554      (parse-unknown-type (c)
     555        (warn "Undefined type ~s in declaration specifier ~s"
     556              (parse-unknown-type-specifier c) `(,type ,@vars)))))
    546557  (dolist (var vars)
    547     (if (symbolp var)
    548       (let ((spec (assq var *nx-proclaimed-types*)))
    549         ;; Check the type.  This will signal program-error's in case of invalid types, let it.
    550         (when *type-system-initialized*
    551           (handler-case (specifier-type type)
    552             (parse-unknown-type (c)
    553               (warn "Undefined type ~s declaration for ~S" (parse-unknown-type-specifier c) var))))
    554         (if spec
    555           (rplacd spec type)
    556           (push (cons var type) *nx-proclaimed-types*)))
    557       (warn "Invalid type declaration for ~S" var))))
     558    (let ((spec (assq var *nx-proclaimed-types*)))
     559      (if spec
     560        (rplacd spec type)
     561        (push (cons var type) *nx-proclaimed-types*)))))
    558562
    559563(defun proclaim-ftype (ftype &rest names)
    560564  (declare (dynamic-extent names))
     565  (unless (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) names)
     566    (bad-proclaim-spec `(ftype ,ftype ,@names)))
    561567  (unless *nx-proclaimed-ftypes*
    562568    (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq)))
     569  ;; Check the type.  This will signal program-error's in case of invalid types, let it.
     570  ;; TODO: should also check it for being a function type.
     571  (handler-case (specifier-type ftype)
     572    (parse-unknown-type (c)
     573      (warn "Undefined type ~s in declaration specifier ~s"
     574            (parse-unknown-type-specifier c) `(ftype ,ftype ,@names))))
    563575  (dolist (name names)
    564     (setf (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*) ftype)))
     576    (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype)))
    565577
    566578
     
    573585(defun proclaim-special (&rest vars)
    574586  (declare (dynamic-extent vars))
     587  (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars)))
    575588  (dolist (sym vars) (%proclaim-special sym)))
    576589
     
    578591(defun proclaim-notspecial (&rest vars)
    579592  (declare (dynamic-extent vars))
     593  (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars)))
    580594  (dolist (sym vars) (%proclaim-notspecial sym)))
    581595
     
    585599  ;;first arg...
    586600  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
     601  (unless (loop for v in names always (or (symbolp v) (setf-function-name-p v)))
     602    (bad-proclaim-spec `(,(if t-or-nil 'inline 'notinline) ,@names)))
    587603  (dolist (name names)
    588     (setq name (ensure-valid-function-name name))
     604    (setq name (maybe-setf-function-name name))
    589605    (if (listp *nx-proclaimed-inline*)
    590606      (setq *nx-proclaimed-inline*
    591607          (alist-adjoin name
    592608                        (or t-or-nil (if (compiler-special-form-p name) t))
    593                         *nx-proclaimed-inline*))     
     609                        *nx-proclaimed-inline*))
    594610      (setf (gethash name *nx-proclaimed-inline*)
    595611            (or t-or-nil (if (compiler-special-form-p name) t))))))
     
    597613(defun proclaim-declaration (&rest syms)
    598614  (declare (dynamic-extent syms))
     615  (unless (every #'symbolp syms) (bad-proclaim-spec `(declaration ,@syms)))
    599616  (dolist (sym syms)
    600617    (when (type-specifier-p sym)
     
    614631  ;;first arg...
    615632  (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil)))
     633  (unless (every #'symbolp syms) (bad-proclaim-spec `(,(if t-or-nil 'ignore 'unignore) ,@syms)))
    616634  (dolist (sym syms)
    617635    (setq *nx-proclaimed-ignore*
  • trunk/source/lib/nfcomp.lisp

    r12045 r12069  
    765765
    766766(defun fcomp-proclaim-type (type syms env)
    767   (dolist (sym syms)
    768     (if (symbolp sym)
    769       (progn
    770         (specifier-type-if-known type env :whine t)
    771         (push (cons sym type) *nx-compile-time-types*))
    772       (nx-bad-decls `(type ,type ,sym)))))
     767  (if (every #'symbolp syms)
     768    (progn
     769      (specifier-type-if-known type env :whine t)
     770      (dolist (sym syms)
     771        (push (cons sym type) *nx-compile-time-types*)))
     772    (nx-bad-decls `(,type ,@syms))))
    773773
    774774(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
     
    780780         (fcomp-proclaim-type (car spec) (cdr spec) env))
    781781        (special
    782          (dolist (sym spec)
    783            (push (cons (require-type sym 'symbol) nil) (defenv.specials defenv))))
     782         (if (every #'symbolp spec)
     783           (dolist (sym spec)
     784             (push (cons sym nil) (defenv.specials defenv)))
     785           (nx-bad-decls `(,sym ,@spec))))
    784786        (notspecial
    785          (let ((specials (defenv.specials defenv)))
    786            (dolist (sym spec (setf (defenv.specials defenv) specials))
    787              (let ((pair (assq sym specials)))
    788                (when pair (setq specials (nremove pair specials)))))))
     787         (if (every #'symbolp spec)
     788           (let ((specials (defenv.specials defenv)))
     789             (dolist (sym spec (setf (defenv.specials defenv) specials))
     790               (let ((pair (assq sym specials)))
     791                 (when pair (setq specials (nremove pair specials))))))
     792           (nx-bad-decls `(,sym ,@spec))))
    789793        (optimize
    790          (%proclaim-optimize spec))
     794           (handler-case (%proclaim-optimize spec)
     795             (program-error () (nx-bad-decls `(,sym ,@spec)))))
    791796        (inline
    792          (dolist (sym spec)
    793            (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv))))
     797         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
     798           (dolist (sym spec)
     799             (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv)))
     800           (nx-bad-decls `(,sym ,@spec))))
    794801        (notinline
    795          (dolist (sym spec)
    796            (unless (compiler-special-form-p sym)
    797              (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv)))))
     802         (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec)
     803           (dolist (sym spec)
     804             (unless (compiler-special-form-p sym)
     805               (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv))))
     806           (nx-bad-decls `(,sym ,@spec))))
    798807        (declaration
    799          (dolist (sym spec)
    800            (pushnew (require-type sym 'symbol) *nx-known-declarations*)))
     808         (if (every #'symbolp spec)
     809           (dolist (sym spec)
     810             (pushnew sym *nx-known-declarations*))
     811           (nx-bad-decls `(,sym ,@spec))))
    801812        (ignore
    802          (dolist (sym spec)
    803            (push (cons (require-type sym 'symbol) t) *nx-proclaimed-ignore*)))
     813         (if (every #'symbolp spec)
     814           (dolist (sym spec)
     815             (push (cons sym t) *nx-proclaimed-ignore*))
     816           (nx-bad-decls `(,sym ,@spec))))
    804817        (unignore
    805          (dolist (sym spec)
    806            (push (cons (require-type sym 'symbol) nil) *nx-proclaimed-ignore*)))
     818         (if (every #'symbolp spec)
     819           (dolist (sym spec)
     820             (push (cons sym nil) *nx-proclaimed-ignore*))
     821           (nx-bad-decls `(,sym ,@spec))))
    807822        (ftype
    808823         (let ((ftype (car spec))
    809824               (fnames (cdr spec)))
    810            ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
    811            (if (and (consp ftype)
    812                     (consp fnames)
    813                     (eq (%car ftype) 'function))
    814              (dolist (fname fnames)
    815                (note-function-info fname nil env)))
    816            (dolist (fname fnames)
    817              (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))))
     825           (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) fnames)
     826             (when (specifier-type-if-known ftype env :whine t)
     827               ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
     828               (if (and (consp ftype)
     829                        (consp fnames)
     830                        (eq (%car ftype) 'function))
     831                 (dolist (fname fnames)
     832                   (note-function-info fname nil env)))
     833               (dolist (fname fnames)
     834                 (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv))))
     835             (nx-bad-decls `(ftype ,@spec)))))
    818836        (otherwise
    819837         (unless (memq sym *nx-known-declarations*)
     
    821839           (if (symbolp sym)
    822840             (fcomp-proclaim-type sym spec env)
    823              (nx-bad-decls `(,sym ,spec)))))))))
     841             (nx-bad-decls `(,sym ,@spec)))))))))
    824842
    825843(defun fcomp-load-%defun (form env)
Note: See TracChangeset for help on using the changeset viewer.