- (let ((symbols (gensym)))
- `(progn
- (setf ,',kind ,next-kind)
- (setf ,',counter nil)
- ,(case next-kind
- (:internal
- `(let ((,symbols (package-internal-symbols
- (car ,',packages))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector (package-hashtable-hash ,symbols)))))
- (:external
- `(let ((,symbols (package-external-symbols
- (car ,',packages))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))
- (:inherited
- `(let ((,symbols (and ,',package-use-list
- (package-external-symbols
- (car ,',package-use-list)))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))))))
- (,end-test-macro (this-kind)
- `,(let ((next-kind (cadr (member this-kind
- ',ordered-types))))
- (if next-kind
- `(,',init-macro ,next-kind)
- `(if (endp (setf ,',packages (cdr ,',packages)))
- (return-from ,',BLOCK)
- (,',init-macro ,(car ',ordered-types)))))))
- (when ,packages
- ,(when (null symbol-types)
- (error 'program-error
- :format-control
- "Must supply at least one of :internal, :external, or ~
- :inherited."))
- ,(dolist (symbol symbol-types)
- (unless (member symbol '(:internal :external :inherited))
- (error 'program-error
- :format-control
- "~S is not one of :internal, :external, or :inherited."
- :format-argument symbol)))
- (,init-macro ,(car ordered-types))
- (flet ((,real-symbol-p (number)
- (> number 1)))
- (macrolet ((,mname ()
- `(block ,',BLOCK
- (loop
- (case ,',kind
- ,@(when (member :internal ',ordered-types)
- `((:internal
- (setf ,',counter
- (position-if #',',real-symbol-p ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (if ,',counter
- (return-from ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages)))
- (,',end-test-macro :internal)))))
- ,@(when (member :external ',ordered-types)
- `((:external
- (setf ,',counter
- (position-if #',',real-symbol-p ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (if ,',counter
- (return-from ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages)))
- (,',end-test-macro :external)))))
- ,@(when (member :inherited ',ordered-types)
- `((:inherited
- (flet ((,',inherited-symbol-p (number)
- (when (,',real-symbol-p number)
- (let* ((p (position
- number ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (s (svref ,',vector p)))
- (eql (nth-value
- 1 (find-symbol
- (symbol-name s)
- (car ,',packages)))
- :inherited)))))
- (setf ,',counter
- (position-if #',',inherited-symbol-p
- ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0))))
- (cond (,',counter
- (return-from
- ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages))
- ))
- (t
- (setf ,',package-use-list
- (cdr ,',package-use-list))
- (cond ((endp ,',package-use-list)
- (setf ,',packages (cdr ,',packages))
- (when (endp ,',packages)
- (return-from ,',BLOCK))
- (setf ,',package-use-list
- (package-%use-list
- (car ,',packages)))
- (,',init-macro ,(car
- ',ordered-types)))
- (t (,',init-macro :inherited)
- (setf ,',counter nil)))))))))))))
- ,@body)))))))
+ (declare (optimize (inhibit-warnings 3)))
+ (let ((symbols (gensym)))
+ `(progn
+ (setf ,',kind ,next-kind)
+ (setf ,',counter nil)
+ ,(case next-kind
+ (:internal
+ `(let ((,symbols (package-internal-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:external
+ `(let ((,symbols (package-external-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:inherited
+ `(let ((,symbols (and ,',package-use-list
+ (package-external-symbols
+ (car ,',package-use-list)))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))))))
+ (,end-test-macro (this-kind)
+ `,(let ((next-kind (cadr (member this-kind
+ ',ordered-types))))
+ (if next-kind
+ `(,',init-macro ,next-kind)
+ `(if (endp (setf ,',packages (cdr ,',packages)))
+ (return-from ,',BLOCK)
+ (,',init-macro ,(car ',ordered-types)))))))
+ (when ,packages
+ ,(when (null symbol-types)
+ (error 'simple-program-error
+ :format-control
+ "At least one of :INTERNAL, :EXTERNAL, or ~
+ :INHERITED must be supplied."))
+ ,(dolist (symbol symbol-types)
+ (unless (member symbol '(:internal :external :inherited))
+ (error 'program-error
+ :format-control
+ "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
+ :format-argument symbol)))
+ (,init-macro ,(car ordered-types))
+ (flet ((,real-symbol-p (number)
+ (> number 1)))
+ (macrolet ((,mname ()
+ (declare (optimize (inhibit-warnings 3)))
+ `(block ,',BLOCK
+ (loop
+ (case ,',kind
+ ,@(when (member :internal ',ordered-types)
+ `((:internal
+ (setf ,',counter
+ (position-if #',',real-symbol-p
+ (the hash-vector ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :internal)))))
+ ,@(when (member :external ',ordered-types)
+ `((:external
+ (setf ,',counter
+ (position-if #',',real-symbol-p
+ (the hash-vector ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :external)))))
+ ,@(when (member :inherited ',ordered-types)
+ `((:inherited
+ (flet ((,',inherited-symbol-p (number)
+ (when (,',real-symbol-p number)
+ (let* ((p (position
+ number
+ (the hash-vector
+ ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (s (svref ,',vector p)))
+ (eql (nth-value
+ 1 (find-symbol
+ (symbol-name s)
+ (car ,',packages)))
+ :inherited)))))
+ (setf ,',counter
+ (when ,',hash-vector
+ (position-if #',',inherited-symbol-p
+ (the hash-vector
+ ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))))
+ (cond (,',counter
+ (return-from
+ ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages))
+ ))
+ (t
+ (setf ,',package-use-list
+ (cdr ,',package-use-list))
+ (cond ((endp ,',package-use-list)
+ (setf ,',packages (cdr ,',packages))
+ (when (endp ,',packages)
+ (return-from ,',BLOCK))
+ (setf ,',package-use-list
+ (package-%use-list
+ (car ,',packages)))
+ (,',init-macro ,(car
+ ',ordered-types)))
+ (t (,',init-macro :inherited)
+ (setf ,',counter nil)))))))))))))
+ ,@body)))))))