[Openmcl-devel] with-package

[Taoufik Dachraoui]

hi

the previous version of mb contains a lot of errors (sorry)

I found the solution to the issue encountered in with-package, I do not use
any hacking around
the lisp reader, the solution is simple and safe (i hope)

Here is an explanation of the issue and the solution:

? (with-package (calculus) (share 3))

1. at read time the symbol SHARE is created by the reader
2. at execution time the use of calculus will unintern SHARE and create a
new one; this was the problem,
when I unintern the symbol, the symbol created by the reader will have no
package (symbol-package is nil)

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

Kind regards
Taoufik


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

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

(defun %symbol-value (s &optional package)
  (let ((r
 (if (null package)
     (symbol-value (find-symbol s))
     (symbol-value (find-symbol s package)))))
    (format t "%symbol-vale ~S = ~S~%" s r) r))

(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 (not (null ss))
        (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-HASH-HIDDEN-SYMBOLS**")))
          (%set-symbol ss s)) ;; do not unintern/import; it creates an
issue when using with-package
(import s))))

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

(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-HASH-HIDDEN-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-HASH-HIDDEN-SYMBOLS**" (symbol-package name)))
    (%new-symbol "**MB-HASH-HIDDEN-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))))

(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 (progn , at body)))
         (unuse ,@(reverse names))
         (if (null ,e)
             (values-list ,r)
             (error (format nil "~S" ,e)))))))






On Sun, Jan 13, 2013 at 10:39 AM, Pascal J. Bourguignon <
pjb at informatimago.com> wrote:

> Taoufik Dachraoui <dachraoui.taoufik at gmail.com> writes:
>
> > replace with-package by the following:
>
> 1- can't access lexical bindings:
>
> cl-user> (let ((hello 'world))
>            (mb:with-package (MB)
>              (print hello)))
>
> ;Compiler warnings :
> ;   In an anonymous lambda form: Unused lexical variable hello
> > Debug: #<unbound-variable #x302001E4CDBD>
>
>
> 2- the error messages are not printed nicely (after "Debug: ").
>    Compare with:
>
> cl-user> (let ((hello 'world))
>            (print whatchamacalit))
> ;Compiler warnings :
> ;   In an anonymous lambda form: Undeclared free variable whatchamacalit
> ;   In an anonymous lambda form: Unused lexical variable hello
> > Debug: Unbound variable: whatchamacalit
>
>
> --
> __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/20130113/a2000421/attachment.htm>