Ignore:
Timestamp:
03/01/13 11:26:24 (8 years ago)
Author:
rschlatte
Message:

Support package-local nicknames

  • Same API as SBCL (see manual)
  • fasl version increased because arglist of %defpackage changed
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/defpackage.lisp

    r11391 r14405  
    6565(defmacro defpackage (package &rest options)
    6666  (let ((nicknames nil)
    67   (size nil)
    68   (shadows nil)
    69   (shadowing-imports nil)
    70   (use nil)
    71   (use-p nil)
    72   (imports nil)
    73   (interns nil)
    74   (exports nil)
    75   (doc nil))
     67        (size nil)
     68        (shadows nil)
     69        (shadowing-imports nil)
     70        (use nil)
     71        (use-p nil)
     72        (imports nil)
     73        (interns nil)
     74        (exports nil)
     75        (local-nicknames nil)
     76        (doc nil))
    7677    (dolist (option options)
    7778      (unless (consp option)
    78   (error 'program-error "bad DEFPACKAGE option: ~S" option))
     79        (error 'program-error "bad DEFPACKAGE option: ~S" option))
    7980      (case (car option)
    80   (:nicknames
    81    (setq nicknames (stringify-names (cdr option))))
    82   (:size
    83    (cond (size
    84     (error 'program-error "can't specify :SIZE twice"))
    85          ((and (consp (cdr option))
    86          (typep (second option) 'unsigned-byte))
    87     (setq size (second option)))
    88          (t
    89     (error 'program-error
    90      "bad :SIZE, must be a positive integer: ~S"
    91      (second option)))))
    92   (:shadow
    93    (let ((new (stringify-names (cdr option))))
    94      (setq shadows (append shadows new))))
    95   (:shadowing-import-from
    96    (let ((package-name (designated-package-name (cadr option)))
    97          (symbol-names (stringify-names (cddr option))))
    98      (let ((assoc (assoc package-name shadowing-imports
    99              :test #'string=)))
    100        (if assoc
    101      (setf (cdr assoc) (append (cdr assoc) symbol-names))
    102      (setq shadowing-imports
    103            (acons package-name symbol-names shadowing-imports))))))
    104   (:use
    105    (let ((new (mapcar #'designated-package-name (cdr option))))
    106      (setq use (delete-duplicates (nconc use new) :test #'string=))
    107      (setq use-p t)))
    108   (:import-from
    109    (let ((package-name (designated-package-name (cadr option)))
    110          (symbol-names (stringify-names (cddr option))))
    111      (let ((assoc (assoc package-name imports
    112              :test #'string=)))
    113        (if assoc
    114      (setf (cdr assoc) (append (cdr assoc) symbol-names))
    115      (setq imports (acons package-name symbol-names imports))))))
    116   (:intern
    117    (let ((new (stringify-names (cdr option))))
    118      (setq interns (append interns new))))
    119   (:export
    120    (let ((new (stringify-names (cdr option))))
    121      (setq exports (append exports new))))
    122   (:documentation
    123    (when doc
    124      (error 'program-error "can't specify :DOCUMENTATION twice"))
    125    (setq doc (coerce (cadr option) 'simple-string)))
    126   (t
    127    (error 'program-error "bad DEFPACKAGE option: ~S" option))))
     81        (:nicknames
     82         (setq nicknames (stringify-names (cdr option))))
     83        (:size
     84         (cond (size
     85                (error 'program-error "can't specify :SIZE twice"))
     86               ((and (consp (cdr option))
     87                     (typep (second option) 'unsigned-byte))
     88                (setq size (second option)))
     89               (t
     90                (error 'program-error
     91                       "bad :SIZE, must be a positive integer: ~S"
     92                       (second option)))))
     93        (:shadow
     94         (let ((new (stringify-names (cdr option))))
     95           (setq shadows (append shadows new))))
     96        (:shadowing-import-from
     97         (let ((package-name (designated-package-name (cadr option)))
     98               (symbol-names (stringify-names (cddr option))))
     99           (let ((assoc (assoc package-name shadowing-imports
     100                               :test #'string=)))
     101             (if assoc
     102                 (setf (cdr assoc) (append (cdr assoc) symbol-names))
     103                 (setq shadowing-imports
     104                       (acons package-name symbol-names shadowing-imports))))))
     105        (:use
     106         (let ((new (mapcar #'designated-package-name (cdr option))))
     107           (setq use (delete-duplicates (nconc use new) :test #'string=))
     108           (setq use-p t)))
     109        (:import-from
     110         (let ((package-name (designated-package-name (cadr option)))
     111               (symbol-names (stringify-names (cddr option))))
     112           (let ((assoc (assoc package-name imports
     113                               :test #'string=)))
     114             (if assoc
     115                 (setf (cdr assoc) (append (cdr assoc) symbol-names))
     116                 (setq imports (acons package-name symbol-names imports))))))
     117        (:intern
     118         (let ((new (stringify-names (cdr option))))
     119           (setq interns (append interns new))))
     120        (:export
     121         (let ((new (stringify-names (cdr option))))
     122           (setq exports (append exports new))))
     123        (:documentation
     124         (when doc
     125           (error 'program-error "can't specify :DOCUMENTATION twice"))
     126         (setq doc (coerce (cadr option) 'simple-string)))
     127        (:local-nicknames
     128         (dolist (nickdecl (cdr option))
     129           (unless (= (length nickdecl) 2)
     130             (error 'program-error "Malformed local nickname declaration ~A"
     131                    nickdecl))
     132           (let ((nickname (string (first nickdecl)))
     133                 (package-name (designated-package-name (second nickdecl))))
     134             (when (member package-name '("CL" "COMMON-LISP" "KEYWORD")
     135                           :test #'string-equal)
     136               (cerror "Continue anyway"
     137                       (format nil "Trying to define a local nickname for package ~A"
     138                               package-name)))
     139             (push (list nickname package-name) local-nicknames))))
     140        (t
     141         (error 'program-error "bad DEFPACKAGE option: ~S" option))))
    128142    (check-disjoint `(:intern ,@interns) `(:export  ,@exports))
    129143    (check-disjoint `(:intern ,@interns)
    130         `(:import-from
    131           ,@(apply #'append (mapcar #'rest imports)))
    132         `(:shadow ,@shadows)
    133         `(:shadowing-import-from
    134           ,@(apply #'append (mapcar #'rest shadowing-imports))))
     144                    `(:import-from
     145                      ,@(apply #'append (mapcar #'rest imports)))
     146                    `(:shadow ,@shadows)
     147                    `(:shadowing-import-from
     148                      ,@(apply #'append (mapcar #'rest shadowing-imports))))
    135149    `(%defpackage ,(string package) ',nicknames ',size
    136150                  ',shadows (ensure-available-symbols ',shadowing-imports)
    137151                  ',(if use-p use nil)
    138                   (ensure-available-symbols ',imports) ',interns ',exports ',doc)))
     152                  (ensure-available-symbols ',imports) ',interns ',exports
     153                  ',local-nicknames ',doc)))
Note: See TracChangeset for help on using the changeset viewer.