[Openmcl-devel] with-package

[Taoufik Dachraoui]

Hi

I hope this time it is ok, I rewrote the simple system package, and tested
for all the cases you bring up

I wrote a dispatch macro reader to get rid of #: from at run time

what happens is that at run time the (use calculus) will unintern the share
symbol created by the reader,
because of this the symbol share interned by the reader is now #:SHAR; the
solution is to read the body of
with-package and get rid of #: using a dispatch macro reader (see
with-package definition)

? (defun share (x) (1+ x))
SHARE
? (share 3)
4
? (with-package (calculus) (share 3))
.3 boxes:(NIL)
.r:3
3
? (share 3)
4

? (defvar *fun*)
*FUN*
? (with-package (calculus) (setf *fun* 'share))
#:SHARE
? (funcall *fun* 3)
.3 boxes:(NIL)
.r:3
3
? (share 3)
4

? (with-package (calculus) (defun foo (x) (share x)))
FOO
? (foo 4)
.4 boxes:(NIL)
.r:4
4
? (share 4)
5
? (unintern 'share)
T
? (foo 4)
.4 boxes:(NIL)
.r:4
4

Regards
Taoufik

(defpackage "MB" (:export "USE" "UNUSE" "WITH-PACKAGE"))
(in-package "MB")

(defun %new-symbol (s package &optional v)
  (setf (symbol-value (intern s package)) v))

(defun %symbol-value (s &optional package)
  (if (null package)
      (symbol-value (find-symbol s))
      (symbol-value (find-symbol s package))))

(defun (setf %symbol-value) (v s &optional package)
  (if (null package)
      (setf (symbol-value (find-symbol s)) v)
      (setf (symbol-value (find-symbol s package)) v)))

(defun %set-symbol (s1 s2)
  (setf (symbol-plist s1) (symbol-plist s2))
  (if (boundp s2)
      (setf (symbol-value s1) (symbol-value s2))
      (makunbound s1))
  (if (fboundp s2)
      (if (null (macro-function s2))
  (setf (symbol-function s1) (symbol-function s2))
  (setf (macro-function s1) (macro-function s2)))
      (fmakunbound s1)))

(defun %import (s)
  (let ((ss (find-symbol (symbol-name s))))
    (if (null ss)
(setf (gethash (symbol-name s) (%symbol-value "**MB-IMPORTED-SYMBOLS**"))
nil)
        (progn
          (push
           (if (eq (symbol-package ss) *package*)
               (copy-symbol ss t)
               (cons (symbol-name ss) (symbol-package ss)))
           (gethash (symbol-name s) (%symbol-value
"**MB-IMPORTED-SYMBOLS**")))
          (unintern ss)))
    (import s)))

(defun %unimport (s)
  (unintern (find-symbol (symbol-name s)))
  (let ((asym (pop (gethash (symbol-name s)
    (%symbol-value "**MB-IMPORTED-SYMBOLS**")))))
    (if (null asym)
(remhash (symbol-name s)
                 (%symbol-value "**MB-IMPORTED-SYMBOLS**"))
(if (consp asym)
    (import (find-symbol (car asym) (cdr asym)))
    (let ((sym (intern (symbol-name s))))
      (%set-symbol sym asym))))))

(defun %make-package (file nickname)
  (if (null (file-write-date file))
      (error (format nil "file not found (~S)" file))
      (let ((*package*
     (if (null (find-package nickname))
 (make-package file
       :use '("CCL" "COMMON-LISP" "MB")
       :nicknames `(,nickname))
 (find-package nickname))))
(%new-symbol "**MB-PACKAGE-TIMESTAMP**" *package* (file-write-date file))
(%new-symbol "**MB-IMPORTED-SYMBOLS**" *package* (make-hash-table :test
'equal))
(load file))))

(defun %use (name)
  (if (and (not (eq (find-package name) *package*))
   (or (null (%symbol-value "**MB-USED-PACKAGES**"))
       (not (eq (find-package name) (car (%symbol-value
"**MB-USED-PACKAGES**"))))))
      (progn
(if (null (find-package name))
    (%make-package (format nil "~A/~A.LISP" (ccl::current-directory-name)
(string name)) name)
    (if (and (not (null (find-symbol "**MB-PACKAGE-TIMESTAMP**"
(find-package name))))
     (> (file-write-date (package-name (find-package name)))
(%symbol-value "**MB-PACKAGE-TIMESTAMP**" (find-package name))))
(%make-package (package-name (find-package name)) name)))
(if (null (find-symbol "**MB-IMPORTED-SYMBOLS**" (symbol-package name)))
    (%new-symbol "**MB-IMPORTED-SYMBOLS**" *package* (make-hash-table)))
(do-external-symbols (s (find-package name)) (%import s))
(push (find-package name) (%symbol-value "**MB-USED-PACKAGES**")))))


(defun %unuse (name)
"only unuse the last used package"
  (if (not (null (find-package name)))
      (if (eq (find-package name) (car (%symbol-value
"**MB-USED-PACKAGES**")))
  (let ((pkg (pop (%symbol-value "**MB-USED-PACKAGES**"))))
    (do-external-symbols (s pkg) (%unimport s))
    (if (not (null (find-symbol "**MB-PACKAGE-TIMESTAMP**" pkg)))
(delete-package pkg)))
  (error "cannot unuse package ~S~%" (find-package name)))))

(defmacro use (&rest names)
  `(progn
     (if (null (find-symbol "**MB-USED-PACKAGES**")) (%new-symbol
"**MB-USED-PACKAGES**" *package*))
     (dolist (name ',names) (%use name))))

(defmacro unuse (&rest names)
  (if (null names)
      `(%unuse (car (%symbol-value "**MB-USED-PACKAGES**")))
      `(dolist (name ',names) (%unuse name))))

(defun homeless-symbol-reader (stream char1 char2)
"unread #:"
  (declare (ignore stream char1 char2))
  (let ((name (read stream nil nil t)))
    (block :return
      (maphash #'(lambda (k v)
   (declare (ignore v))
   (if (string= (string name) k)
       (return-from :return name)))
       (%symbol-value "**MB-IMPORTED-SYMBOLS**"))
      (intern (format nil "#:~A" name)))))

(defmacro with-package ((&rest names) &body body)
  (let ((r (gensym)) (e (gensym)))
    `(progn
       (use , at names)
       (multiple-value-bind (,r ,e)
           (ignore-errors
             (multiple-value-list
      (eval (let ((*readtable* (copy-readtable)))
      (set-dispatch-macro-character #\# #\: #'homeless-symbol-reader)
      (read-from-string (format nil "(progn ~{~S ~})" ',body))))))
         (unuse ,@(reverse names))
         (if (null ,e)
             (values-list ,r)
             (error (format nil "~S" ,e)))))))



On Sun, Jan 13, 2013 at 9:54 PM, Pascal J. Bourguignon <
pjb at informatimago.com> wrote:

> Taoufik Dachraoui <dachraoui.taoufik at gmail.com> writes:
>
> > The solution is to not unintern symbols, instead I use a function
> > %set-symbol as follows:
> >
> > (defun %set-symbol (s1 s2)
> >   (setf (symbol-plist s1) (symbol-plist s2))
> >   (if (boundp s2)
> >       (setf (symbol-value s1) (symbol-value s2))
> >       (makunbound s1))
> >   (if (fboundp s2)
> >       (if (null (macro-function s2))
> >           (setf (symbol-function s1) (symbol-function s2))
> >           (setf (macro-function s1) (macro-function s2)))
> >       (fmakunbound s1)))
> >
> > Check the function %import to see when %set-symbol is called.
> >
> > This way the imported symbol from calculus will bound/fbound the
> > symbol created by the reader
>
> Then the following will fail:
>
>     (defvar *fun*)
>
>     (with-package (calculus)
>        (setf *fun* 'share))
>
>     (funcall *fun*)
>
>
> --
> __Pascal Bourguignon__                     http://www.informatimago.com/
> A bad day in () is better than a good day in {}.
>
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20130114/71ee7438/attachment.htm>