<div dir="ltr">Hi<div><br></div><div>I hope this time it is ok, I rewrote the simple system package, and tested for all the cases you bring up</div><div><br></div><div>I wrote a dispatch macro reader to get rid of #: from at run time</div>
<div><br></div><div>what happens is that at run time the (use calculus) will unintern the share symbol created by the reader, </div><div>because of this the symbol share interned by the reader is now #:SHAR; the solution is to read the body of </div>
<div>with-package and get rid of #: using a dispatch macro reader (see with-package definition)</div><div><br></div><div><div>? (defun share (x) (1+ x))</div><div>SHARE</div><div>? (share 3)</div><div>4</div><div>? (with-package (calculus) (share 3))</div>
<div>.3 boxes:(NIL)</div><div>.r:3</div><div>3</div><div>? (share 3)</div><div>4</div></div><div><br></div><div><div>? (defvar *fun*)</div><div>*FUN*</div><div>? (with-package (calculus) (setf *fun* 'share))</div><div>
#:SHARE</div><div>? (funcall *fun* 3)</div><div>.3 boxes:(NIL)</div><div>.r:3</div><div>3</div><div>? (share 3)</div><div>4</div></div><div><br></div><div><div>? (with-package (calculus) (defun foo (x) (share x)))</div><div>
FOO</div><div>? (foo 4)</div><div>.4 boxes:(NIL)</div><div>.r:4</div><div>4</div><div>? (share 4)</div><div>5</div><div>? (unintern 'share)</div><div>T</div><div>? (foo 4)</div><div>.4 boxes:(NIL)</div><div>.r:4</div>
<div>4</div></div><div><br></div><div>Regards</div><div>Taoufik</div><div><br></div><div><div>(defpackage "MB" (:export "USE" "UNUSE" "WITH-PACKAGE"))</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>  (if (null package)</div>
<div>      (symbol-value (find-symbol s))</div><div>      (symbol-value (find-symbol s package))))</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 (null ss)</div><div><span class="" style="white-space:pre">    </span>(setf (gethash (symbol-name s) (%symbol-value "**MB-IMPORTED-SYMBOLS**")) nil)</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-IMPORTED-SYMBOLS**")))</div>
<div>          (unintern ss)))</div><div>    (import s)))</div><div><br></div><div>(defun %unimport (s)</div><div>  (unintern (find-symbol (symbol-name s)))</div><div>  (let ((asym (pop (gethash (symbol-name s) </div><div>
<span class="" style="white-space:pre">                       </span>    (%symbol-value "**MB-IMPORTED-SYMBOLS**")))))</div><div>    (if (null asym)</div><div><span class="" style="white-space:pre">      </span>(remhash (symbol-name s)</div>
<div>                 (%symbol-value "**MB-IMPORTED-SYMBOLS**"))</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><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-IMPORTED-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-IMPORTED-SYMBOLS**" (symbol-package name)))</div>
<div><span class="" style="white-space:pre">    </span>    (%new-symbol "**MB-IMPORTED-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>(defun homeless-symbol-reader (stream char1 char2)</div><div>"unread #:"</div><div>  (declare (ignore stream char1 char2))</div><div>  (let ((name (read stream nil nil t)))</div><div>    (block :return</div>
<div>      (maphash #'(lambda (k v) </div><div><span class="" style="white-space:pre">          </span>   (declare (ignore v))</div><div><span class="" style="white-space:pre">            </span>   (if (string= (string name) k)</div><div>
<span class="" style="white-space:pre">               </span>       (return-from :return name)))</div><div><span class="" style="white-space:pre">        </span>       (%symbol-value "**MB-IMPORTED-SYMBOLS**"))</div><div>      (intern (format nil "#:~A" name)))))</div>
<div>  </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 </div><div><span class="" style="white-space:pre">   </span>      (eval (let ((*readtable* (copy-readtable)))</div><div><span class="" style="white-space:pre">          </span>      (set-dispatch-macro-character #\# #\: #'homeless-symbol-reader)</div>
<div><span class="" style="white-space:pre">            </span>      (read-from-string<span class="" style="white-space:pre">   </span>(format nil "(progn ~{~S ~})" ',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><div><br></div></div><div class="gmail_extra"><br><br><div class="gmail_quote">
On Sun, Jan 13, 2013 at 9:54 PM, 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>
> The solution is to not unintern symbols, instead I use a function<br>
> %set-symbol as follows:<br>
><br>
> (defun %set-symbol (s1 s2)<br>
>   (setf (symbol-plist s1) (symbol-plist s2))<br>
>   (if (boundp s2)<br>
>       (setf (symbol-value s1) (symbol-value s2))<br>
>       (makunbound s1))<br>
>   (if (fboundp s2)<br>
>       (if (null (macro-function s2))<br>
>           (setf (symbol-function s1) (symbol-function s2))<br>
>           (setf (macro-function s1) (macro-function s2)))<br>
>       (fmakunbound s1)))<br>
><br>
> Check the function %import to see when %set-symbol is called.<br>
><br>
> This way the imported symbol from calculus will bound/fbound the<br>
> symbol created by the reader<br>
<br>
</div>Then the following will fail:<br>
<br>
    (defvar *fun*)<br>
<br>
    (with-package (calculus)<br>
       (setf *fun* 'share))<br>
<br>
    (funcall *fun*)<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>