Changeset 10340


Ignore:
Timestamp:
Aug 5, 2008, 8:49:37 AM (11 years ago)
Author:
gb
Message:

Runtime support for package-ref stuff.

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/nfasload.lisp

    r10282 r10340  
    4242  (assert (= 80 numfaslops)))
    4343
     44
     45
     46
     47
    4448(defvar *fasl-dispatch-table* #80(%bad-fasl))
     49
     50
     51
     52
    4553
    4654(defun %bad-fasl (s)
     
    238246        (%epushval s symbol)))))
    239247
     248(defvar *package-refs*)
     249(setq *package-refs* (make-hash-table :test #'equal))
     250
     251(defun register-package-ref (name)
     252  (or (gethash name *package-refs*)
     253      (setf (gethash name *package-refs*) (make-package-ref name))))
     254
     255(dolist (p %all-packages%)
     256  (dolist (name (pkg.names p))
     257    (setf (package-ref.pkg (register-package-ref name)) p)))
     258
     259
    240260(defun find-package (name)
    241   (if (packagep name)
     261  (if (typep  name 'package)
    242262    name
    243263    (%find-pkg (string name))))
     264
     265(defun %pkg-ref-find-package (ref)
     266  (package-ref.pkg ref))
    244267
    245268(defun set-package (name &aux (pkg (find-package name)))
     
    338361         (size-of-code (%fasl-read-count s))
    339362         (vector (%alloc-misc size-in-elements target::subtag-function))
    340          (function (function-vector-to-function vector)))
     363         (function (%function-vector-to-function vector)))
    341364    (declare (fixnum size-in-elements size-of-code))
    342365    (%epushval s function)
     
    494517               (and (symbolp f)
    495518                    (functionp (fboundp f)))))
    496       (apply (%car form) (%cdr form))
     519      (do* ((tail (%cdr form) (%cdr tail)))
     520           ((null tail) (apply (%car form) (%cdr form)))
     521        (let* ((head (car tail)))
     522          (when (and (consp head) (eq (car head) 'quote))
     523            (setf (car tail) (cadr head)))))
    497524      (error "Can't eval yet: ~s" form))))
    498525
     
    689716(deffaslop $fasl-istruct-cell (s)
    690717  (%epushval s (register-istruct-cell (%fasl-expr-preserve-epush s))))
     718
     719
     720
    691721
    692722;;; The loader itself
  • trunk/source/level-1/l1-reader.lisp

    r9879 r10340  
    2424  (defmacro readtable-case-keywords () `',readtable-case-keywords))
    2525
    26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     27
     28(defmethod make-load-form ((ref package-ref) &optional env)
     29  (declare (ignore env))
     30  `(register-package-ref ',(package-ref.name ref)))
     31
     32(defmethod print-object ((ref package-ref) stream)
     33  (print-unreadable-object (ref stream :type t :identity t)
     34    (format stream "for ~s [~s]" (package-ref.name ref) (package-ref.pkg ref))))
    2735
    2836;;; Maps character names to characters
  • trunk/source/level-1/l1-symhash.lisp

    r9879 r10340  
    141141    (let* ((names (pkg.names package)))
    142142      (declare (type cons names))
     143      (dolist (n names)
     144        (let* ((ref (register-package-ref n)))
     145          (setf (package-ref.pkg ref) nil)))
    143146      (rplaca names (new-package-name new-name package))
     147      (let* ((ref (register-package-ref (car names))))
     148        (setf (package-ref.pkg ref) package))
    144149      (rplacd names nil))
    145150    (%add-nicknames new-nicknames package)))
     
    193198                      (make-read-write-lock)
    194199                      nil)))
    195       (use-package use pkg)
    196       (%add-nicknames nicknames pkg)
    197       (with-package-list-write-lock
    198           (push pkg %all-packages%))
    199       pkg))
     200    (let* ((ref (register-package-ref name)))
     201      (setf (package-ref.pkg ref) pkg))
     202    (use-package use pkg)
     203    (%add-nicknames nicknames pkg)
     204    (with-package-list-write-lock
     205        (push pkg %all-packages%))
     206    pkg))
    200207
    201208(defun new-package-name (name &optional package)
     
    254261    (dolist (name nicknames package)
    255262      (let* ((ok-name (new-package-nickname name package)))
    256         (if ok-name (push ok-name (cdr names)))))))
     263        (when ok-name
     264          (let* ((ref (register-package-ref ok-name)))
     265            (setf (package-ref.pkg ref) package)
     266            (push ok-name (cdr names))))))))
    257267
    258268(defun find-symbol (string &optional package)
     
    262272  are NIL."
    263273  (multiple-value-bind (sym flag)
    264                        (%findsym (ensure-simple-string string) (pkg-arg (or package *package*)))
     274      (%findsym (ensure-simple-string string) (pkg-arg (or package *package*)))
    265275    (values sym flag)))
    266276
     277(defun %pkg-ref-find-symbol (string ref)
     278  (multiple-value-bind (sym flag)
     279      (%findsym (ensure-simple-string string)
     280                (or (package-ref.pkg ref)
     281                    (setf (package-ref.pkg ref)
     282                          (%find-pkg (package-ref.name ref)))))
     283    (values sym flag)))
     284   
    267285;;; Somewhat saner interface to %find-symbol
    268286(defun %findsym (string package)
    269287  (%find-symbol string (length string) package))
    270288
    271 (defun intern (str &optional (package *package*))
    272   "Return a symbol in PACKAGE having the specified NAME, creating it
    273   if necessary."
    274   (setq package (pkg-arg package))
     289(eval-when (:compile-toplevel)
     290  (declaim (inline %intern)))
     291
     292(defun %intern (str package)
    275293  (setq str (ensure-simple-string str))
    276294  (with-package-lock (package)
     
    280298       (values symbol where)
    281299       (values (%add-symbol str package internal-offset external-offset) nil)))))
     300
     301
     302(defun intern (str &optional (package *package*))
     303  "Return a symbol in PACKAGE having the specified NAME, creating it
     304  if necessary."
     305  (%intern str (pkg-arg package)))
     306
     307(defun %pkg-ref-intern (str ref)
     308  (%intern str (or (package-ref.pkg ref)
     309                   (setf (package-ref.pkg ref)
     310                         (%find-pkg (package-ref.name ref))))))
    282311
    283312(defun unintern (symbol &optional (package *package*))
     
    613642  (setf (pkg.shadowed package) nil)
    614643  (setq %all-packages% (nremove package %all-packages%))
     644  (dolist (n (pkg.names package))
     645    (let* ((ref (register-package-ref n)))
     646      (setf (package-ref.pkg ref) nil)))
    615647  (setf (pkg.names package) nil)
    616648  (let* ((ivec (car (pkg.itab package)))
     
    691723  (let* ((pkg (find-package name)))
    692724    (if pkg
    693       ; Restarts could offer several ways of fixing this.
     725      ;; Restarts could offer several ways of fixing this.
    694726      (unless (string= (package-name pkg) name)
    695727        (cerror "Redefine ~*~S"
Note: See TracChangeset for help on using the changeset viewer.