Changeset 12069 for trunk/source/level-1


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

merge r12050

Location:
trunk/source/level-1
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • 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*
Note: See TracChangeset for help on using the changeset viewer.