<div dir="ltr">hi<div><br></div><div>the previous version of mb contains a lot of errors (sorry)</div><div><br></div><div>I found the solution to the issue encountered in with-package, I do not use any hacking around </div>
<div>the lisp reader, the solution is simple and safe (i hope)</div><div><br></div><div>Here is an explanation of the issue and the solution:</div><div><br></div><div>? (with-package (calculus) (share 3))</div><div><br></div>
<div>1. at read time the symbol SHARE is created by the reader</div><div>2. at execution time the use of calculus will unintern SHARE and create a new one; this was the problem,</div><div>when I unintern the symbol, the symbol created by the reader will have no package (symbol-package is nil)</div>
<div><br></div><div>The solution is to not unintern symbols, instead I use a function %set-symbol as follows:</div><div><br></div><div><div>(defun %set-symbol (s1 s2)</div><div>  (setf (symbol-plist s1) (symbol-plist s2))</div>
<div>  (if (boundp s2)</div><div>      (setf (symbol-value s1) (symbol-value s2))</div><div>      (makunbound s1))</div><div>  (if (fboundp s2)</div><div>      (if (null (macro-function s2))</div><div>          (setf (symbol-function s1) (symbol-function s2))</div>
<div>          (setf (macro-function s1) (macro-function s2)))</div><div>      (fmakunbound s1)))</div></div><div><br></div><div>Check the function %import to see when %set-symbol is called.</div><div><br></div><div>This way the imported symbol from calculus will bound/fbound the symbol created by the reader</div>
<div><br></div><div>Kind regards</div><div>Taoufik</div><div><br></div><div><br></div><div><div>(defpackage "MB" (:export "USE" "UNUSE" "WITH-PACKAGE" "%SET-SYMBOL"))</div>
<div>(in-package "MB")</div><div><br></div><div>(defun %new-symbol (s package &optional v)</div><div>  (setf (symbol-value (intern s package)) v))</div><div><br></div><div>(defun %symbol-value (s &optional package)</div>
<div>  (let ((r</div><div><span class="" style="white-space:pre">   </span> (if (null package)</div><div><span class="" style="white-space:pre">        </span>     (symbol-value (find-symbol s))</div><div><span class="" style="white-space:pre">        </span>     (symbol-value (find-symbol s package)))))</div>
<div>    (format t "%symbol-vale ~S = ~S~%" s r) r))</div><div><br></div><div>(defun (setf %symbol-value) (v s &optional package)</div><div>  (if (null package)</div><div>      (setf (symbol-value (find-symbol s)) v)</div>
<div>      (setf (symbol-value (find-symbol s package)) v)))</div><div><br></div><div>(defun %set-symbol (s1 s2)</div><div>  (setf (symbol-plist s1) (symbol-plist s2))</div><div>  (if (boundp s2) </div><div>      (setf (symbol-value s1) (symbol-value s2))</div>
<div>      (makunbound s1))</div><div>  (if (fboundp s2)</div><div>      (if (null (macro-function s2))</div><div><span class="" style="white-space:pre">   </span>  (setf (symbol-function s1) (symbol-function s2))</div><div>
<span class="" style="white-space:pre">       </span>  (setf (macro-function s1) (macro-function s2)))</div><div>      (fmakunbound s1)))</div><div><br></div><div>(defun %import (s)</div><div>  (let ((ss (find-symbol (symbol-name s))))</div>
<div>    (if (not (null ss))</div><div>        (progn</div><div>          (push</div><div>           (if (eq (symbol-package ss) *package*)</div><div>               (copy-symbol ss t)</div><div>               (cons (symbol-name ss) (symbol-package ss)))</div>
<div>           (gethash (symbol-name s) (%symbol-value "**MB-HASH-HIDDEN-SYMBOLS**")))</div><div>          (%set-symbol ss s)) ;; do not unintern/import; it creates an issue when using with-package</div><div><span class="" style="white-space:pre">      </span>(import s))))</div>
<div><br></div><div>(defun %unimport (s)</div><div>  (let ((asym (pop (gethash (symbol-name s) </div><div><span class="" style="white-space:pre">                     </span>    (%symbol-value "**MB-HASH-HIDDEN-SYMBOLS**")))))</div>
<div>    (if (not (null asym))</div><div><span class="" style="white-space:pre">    </span>(if (consp asym)</div><div><span class="" style="white-space:pre">   </span>    (%import (find-symbol (car asym) (cdr asym)))</div><div>
<span class="" style="white-space:pre">       </span>    (let ((sym (intern (symbol-name s))))</div><div><span class="" style="white-space:pre">  </span>      (%set-symbol sym asym)))</div><div><span class="" style="white-space:pre">     </span>(unintern (find-symbol (symbol-name s))))</div>
<div>    (if (null (gethash (symbol-name s)</div><div><span class="" style="white-space:pre">               </span>       (%symbol-value "**MB-HASH-HIDDEN-SYMBOLS**")))</div><div><span class="" style="white-space:pre">    </span>(remhash (symbol-name s)</div>
<div><span class="" style="white-space:pre">            </span> (%symbol-value "**MB-HASH-HIDDEN-SYMBOLS**")))))</div><div><br></div><div>(defun %make-package (file nickname)</div><div>  (if (null (file-write-date file))</div>
<div>      (error (format nil "file not found (~S)" file))</div><div>      (let ((*package* </div><div><span class="" style="white-space:pre">        </span>     (if (null (find-package nickname))</div><div><span class="" style="white-space:pre">            </span> (make-package file</div>
<div><span class="" style="white-space:pre">                    </span>       :use '("CCL" "COMMON-LISP" "MB")</div><div><span class="" style="white-space:pre">                  </span>       :nicknames `(,nickname))</div>
<div><span class="" style="white-space:pre">            </span> (find-package nickname))))</div><div><span class="" style="white-space:pre">        </span>(%new-symbol "**MB-PACKAGE-TIMESTAMP**" *package* (file-write-date file))</div>
<div><span class="" style="white-space:pre">    </span>(%new-symbol "**MB-HASH-HIDDEN-SYMBOLS**" *package* (make-hash-table :test 'equal))</div><div><span class="" style="white-space:pre">  </span>(load file))))</div>
<div><br></div><div>(defun %use (name)</div><div>  (if (and (not (eq (find-package name) *package*))</div><div><span class="" style="white-space:pre">        </span>   (or (null (%symbol-value "**MB-USED-PACKAGES**"))</div>
<div><span class="" style="white-space:pre">    </span>       (not (eq (find-package name) (car (%symbol-value "**MB-USED-PACKAGES**"))))))</div><div>      (progn</div><div><span class="" style="white-space:pre">  </span>(if (null (find-package name))</div>
<div><span class="" style="white-space:pre">    </span>    (%make-package (format nil "~A/~A.LISP" (ccl::current-directory-name) (string name)) name)</div><div><span class="" style="white-space:pre">   </span>    (if (and (not (null (find-symbol "**MB-PACKAGE-TIMESTAMP**" (find-package name))))</div>
<div><span class="" style="white-space:pre">            </span>     (> (file-write-date (package-name (find-package name)))</div><div><span class="" style="white-space:pre">                    </span>(%symbol-value "**MB-PACKAGE-TIMESTAMP**" (find-package name))))</div>
<div><span class="" style="white-space:pre">            </span>(%make-package (package-name (find-package name)) name)))</div><div><span class="" style="white-space:pre">  </span>(if (null (find-symbol "**MB-HASH-HIDDEN-SYMBOLS**" (symbol-package name)))</div>
<div><span class="" style="white-space:pre">    </span>    (%new-symbol "**MB-HASH-HIDDEN-SYMBOLS**" *package* (make-hash-table)))</div><div><span class="" style="white-space:pre">      </span>(do-external-symbols (s (find-package name)) (%import s))</div>
<div><span class="" style="white-space:pre">    </span>(push (find-package name) (%symbol-value "**MB-USED-PACKAGES**")))))</div><div><br></div><div><br></div><div>(defun %unuse (name)</div><div>"only unuse the last used package"</div>
<div>  (if (not (null (find-package name)))</div><div>      (if (eq (find-package name) (car (%symbol-value "**MB-USED-PACKAGES**")))</div><div><span class="" style="white-space:pre">       </span>  (let ((pkg (pop (%symbol-value "**MB-USED-PACKAGES**"))))</div>
<div><span class="" style="white-space:pre">    </span>    (do-external-symbols (s pkg) (%unimport s))</div><div><span class="" style="white-space:pre">    </span>    (if (not (null (find-symbol "**MB-PACKAGE-TIMESTAMP**" pkg)))</div>
<div><span class="" style="white-space:pre">            </span>(delete-package pkg)))</div><div><span class="" style="white-space:pre">     </span>  (error "cannot unuse package ~S~%" (find-package name)))))</div><div><br></div>
<div>(defmacro use (&rest names)</div><div>  `(progn</div><div>     (if (null (find-symbol "**MB-USED-PACKAGES**")) (%new-symbol "**MB-USED-PACKAGES**" *package*))</div><div>     (dolist (name ',names) (%use name))))</div>
<div><br></div><div>(defmacro unuse (&rest names)</div><div>  (if (null names)</div><div>      `(%unuse (car (%symbol-value "**MB-USED-PACKAGES**")))</div><div>      `(dolist (name ',names) (%unuse name))))</div>
<div><br></div><div>(defmacro with-package ((&rest names) &body body)</div><div>  (let ((r (gensym)) (e (gensym)))</div><div>    `(progn</div><div>       (use ,@names)</div><div>       (multiple-value-bind (,r ,e)</div>
<div>           (ignore-errors</div><div>             (multiple-value-list (progn ,@body)))</div><div>         (unuse ,@(reverse names))</div><div>         (if (null ,e)</div><div>             (values-list ,r)</div><div>             (error (format nil "~S" ,e)))))))</div>
<div><br></div></div><div><br></div><div><br></div><div><br></div></div><div class="gmail_extra"><br><br><div class="gmail_quote">On Sun, Jan 13, 2013 at 10:39 AM, Pascal J. Bourguignon <span dir="ltr"><<a href="mailto:pjb@informatimago.com" target="_blank">pjb@informatimago.com</a>></span> wrote:<br>
<blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex"><div class="im">Taoufik Dachraoui <<a href="mailto:dachraoui.taoufik@gmail.com">dachraoui.taoufik@gmail.com</a>> writes:<br>

<br>
> replace with-package by the following:<br>
<br>
</div>1- can't access lexical bindings:<br>
<br>
cl-user> (let ((hello 'world))<br>
           (mb:with-package (MB)<br>
             (print hello)))<br>
<br>
;Compiler warnings :<br>
;   In an anonymous lambda form: Unused lexical variable hello<br>
> Debug: #<unbound-variable #x302001E4CDBD><br>
<br>
<br>
2- the error messages are not printed nicely (after "Debug: ").<br>
   Compare with:<br>
<br>
cl-user> (let ((hello 'world))<br>
           (print whatchamacalit))<br>
;Compiler warnings :<br>
;   In an anonymous lambda form: Undeclared free variable whatchamacalit<br>
;   In an anonymous lambda form: Unused lexical variable hello<br>
> Debug: Unbound variable: whatchamacalit<br>
<div class="HOEnZb"><div class="h5"><br>
<br>
--<br>
__Pascal Bourguignon__                     <a href="http://www.informatimago.com/" target="_blank">http://www.informatimago.com/</a><br>
A bad day in () is better than a good day in {}.<br>
<br>
_______________________________________________<br>
Openmcl-devel mailing list<br>
<a href="mailto:Openmcl-devel@clozure.com">Openmcl-devel@clozure.com</a><br>
<a href="http://clozure.com/mailman/listinfo/openmcl-devel" target="_blank">http://clozure.com/mailman/listinfo/openmcl-devel</a><br>
</div></div></blockquote></div><br></div>