<div dir="ltr">I managed to write a correct version of with-package macro, this is due to the valuable hints and discussions, I learned a lot by being a member of ccl thank you a lot for all your helps<div><br></div><div>here is the whole code of the mb simple file system (some bugs may be found sorry i did not test thoroughly)</div>
<div><br></div><div>Now I would like to see why this design is wrong by showing me examples where the system can fail</div><div><br></div><div>Thank you again</div><div><br></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 %import (s)</div><div> (let ((ss (find-symbol (symbol-name s))))</div><div> (if (not (null ss))</div><div><span class="" style="white-space:pre"> </span>(progn</div><div><span class="" style="white-space:pre"> </span> (push </div>
<div><span class="" style="white-space:pre"> </span> (if (eq (symbol-package ss) *package*)</div><div><span class="" style="white-space:pre"> </span> (copy-symbol ss t)</div><div><span class="" style="white-space:pre"> </span> (cons (symbol-name ss) (symbol-package ss)))</div>
<div><span class="" style="white-space:pre"> </span> (gethash (symbol-name s) (%symbol-value "**MB-HASH-HIDDEN-SYMBOLS**")))</div><div><span class="" style="white-space:pre"> </span> (unintern ss)))</div><div>
(import s)))</div><div><br></div><div>(defun %unimport (s)</div><div> (if (not (eq (symbol-package s) </div><div><span class="" style="white-space:pre"> </span> (symbol-package (find-symbol (symbol-name s)))))</div>
<div> (remhash (symbol-name s) </div><div><span class="" style="white-space:pre"> </span> (gethash (symbol-name s)</div><div><span class="" style="white-space:pre"> </span>(%symbol-value "**MB-HASH-HIDDEN-SYMBOLS**")))</div>
<div> (progn</div><div><span class="" style="white-space:pre"> </span>(unintern (find-symbol (symbol-name s)))</div><div><span class="" style="white-space:pre"> </span>(let ((asym (pop (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> (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> (setf (symbol-plist sym) (symbol-plist asym))</div>
<div><span class="" style="white-space:pre"> </span> (if (boundp asym) (setf (symbol-value sym) (symbol-value asym)))</div><div><span class="" style="white-space:pre"> </span> (if (fboundp asym)</div><div><span class="" style="white-space:pre"> </span>(if (null (macro-function asym))</div>
<div><span class="" style="white-space:pre"> </span> (setf (symbol-function sym) (symbol-function asym))</div><div><span class="" style="white-space:pre"> </span> (setf (macro-function sym) (macro-function 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-HASH-HIDDEN-SYMBOLS**" *package* (make-hash-table))</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</div><div> (eval (read-from-string</div><div><span class="" style="white-space:pre"> </span> (format nil "(progn ~{~A ~})" </div>
<div><span class="" style="white-space:pre"> </span> (let ((*readtable* (copy-readtable)))</div><div><span class="" style="white-space:pre"> </span> (set-macro-character #\(</div><div><span class="" style="white-space:pre"> </span> (lambda (stream char)</div>
<div><span class="" style="white-space:pre"> </span> (declare (ignore char))</div><div><span class="" style="white-space:pre"> </span> (let ((str "") (n 0))</div><div><span class="" style="white-space:pre"> </span>(do ((c (read-char stream) (read-char stream nil 'the-end)))</div>
<div><span class="" style="white-space:pre"> </span> ((and (= n 0) (eq c #\))))</div><div><span class="" style="white-space:pre"> </span> (if (eq c #\() (incf n) (if (eq c #\)) (decf n)))</div><div><span class="" style="white-space:pre"> </span> (setf str (format nil "~A~A" str c)))</div>
<div><span class="" style="white-space:pre"> </span>str)))</div><div><span class="" style="white-space:pre"> </span> ',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 Sat, Jan 12, 2013 at 8:58 PM, Robert Goldman <span dir="ltr"><<a href="mailto:rpgoldman@sift.info" target="_blank">rpgoldman@sift.info</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">On 1/12/13 Jan 12 -9:30 AM, Taoufik Dachraoui wrote:<br>
> I am wrote a very simple package system that I am using for all my<br>
> developments, I wanted to add<br>
> the macro with-package so that I can use a package temporarily and then<br>
> revert to previous context<br>
> just before using the package.<br>
<br>
</div>I won't presume to dictate your personal programming style. However, I<br>
feel free to *suggest* that this may not work out well.<br>
<br>
The package is effectively a big, invisible global variable, and having<br>
the correctness of your code depend on it can make its behavior<br>
unpredictable and difficult to understand.<br>
<br>
This is related to the discussion of DEFPACKAGE in the spec:<br>
<br>
"It is recommended that the entire package definition is put in a single<br>
place, and that all the package definitions of a program are in a single<br>
file. This file can be loaded before loading or compiling anything else<br>
that depends on those packages. Such a file can be read in the<br>
COMMON-LISP-USER package, avoiding any initial state issues."<br>
<br>
Reading between the lines, I suggest that this recommendation is<br>
intended to provide a transparent, easy-to-understand interpretation of<br>
the packages, so that the set of accessible names, and their<br>
interpretations is easy for the reader of code to predict. Pushing and<br>
popping available symbols tends to work against this. It also, as has<br>
been pointed out, can involve the need to understand issues of<br>
compile-time, load-time, and execute-time evaluation.<br>
<br>
I offer an additional heuristic: if something you are doing requires<br>
attention to the subtleties of evaluation time, consider a different<br>
method. This is only a heuristic, because there are important tasks<br>
that can be done well by exploiting, e.g., compile-time execution<br>
subtleties. Nevertheless, it's useful to consider alternatives when coding.<br>
<br>
The principle is the same as when writing expository prose: avoid<br>
complex constructions when they are unnecessary, since making the reader<br>
spend a lot of effort to understand incurs a risk of misunderstanding.<br>
<br>
Again, it's your code; do what you like with it, but simpler<br>
constructions may serve you better in the long run.<br>
<br>
Cheers,<br>
r<br>
<br>
<br>
</blockquote></div><br></div>