home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / COMMON.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  19KB  |  604 lines
  1. ;; functions missing that are part of common lisp, and commonly used
  2.  
  3. ;; It is assumed you are using XLISP 2.1h with all Common Lisp related options
  4. ;; (except packages) turned on before you load this file.
  5.  
  6. ;; Author either unknown or Tom Almy unless indicated.
  7.  
  8. (in-package "XLISP")
  9.  
  10. ; (unintern sym) - remove a symbol from the oblist
  11. #-:packages
  12. (defun unintern (symbol)
  13.   (let ((subhash (hash symbol (length *obarray*))))
  14.     (cond ((member symbol (aref *obarray* subhash))
  15.              (setf (aref *obarray* subhash)
  16.                    (delete symbol (aref *obarray* subhash)))
  17.              t)
  18.           (t nil))))
  19.  
  20. (export '(pairlis copy-list copy-alist copy-tree signum))
  21.  
  22. ;; pairlis does not check for lengths of keys and values being unequal
  23.  
  24. (defun pairlis (keys values &optional list)
  25.        (nconc (mapcar #'cons keys values) list))
  26.  
  27. (defun copy-list (list) (append list 'nil))
  28.  
  29. (defun copy-alist (list)
  30.     (if (null list)
  31.         'nil
  32.         (cons (if (consp (car list))
  33.           (cons (caar list) (cdar list))
  34.           (car list))
  35.           (copy-alist (cdr list)))))
  36.  
  37. (defun copy-tree (list)
  38.     (if (consp list)
  39.         (cons (copy-tree (car list)) (copy-tree (cdr list)))
  40.         list))
  41.  
  42. (defun signum (x)
  43.    (cond ((not (numberp x)) (error "~s is not a number" x))
  44.          ((zerop (abs x)) x)
  45.      (t (/ x (abs x)))))  
  46.  
  47. (export '(remf incf decf push pushnew pop))
  48.  
  49. ; Cruddy but simple versions of these functions.
  50. ; Commented out since XLISP will now expand macros once, making
  51. ; good version much preferred.
  52.  
  53. ;(defmacro incf (var &optional (delta 1))
  54. ;    `(setf ,var (+ ,var ,delta)))
  55.  
  56. ;(defmacro decf (var &optional (delta 1))
  57. ;    `(setf ,var (- ,var ,delta)))
  58.  
  59. ;(defmacro push (v l)
  60. ;    `(setf ,l (cons ,v ,l))))
  61.  
  62. ;(defmacro pushnew (a l &rest args)
  63. ;  `(unless (member ,a ,l ,@args) (push ,a ,l) nil))
  64.  
  65. ;(defmacro pop (l)
  66. ;    `(prog1 (first ,l) (setf ,l (rest ,l)))))
  67.  
  68.  
  69. ; This is what one really needs to do for incf decf and
  70. ; (in common.lsp) push and pop. The setf form must only be evaluated once.
  71. ; But is it worth all this overhead for correctness?
  72. ; (By Tom Almy)
  73.  
  74. (defun |DoForm| (form) ; returns (cons |list for let| |new form|)
  75.        (let* ((args (rest form)) ; raw form arguments
  76.           (letlist (mapcan #'(lambda (x) (when (consp x)
  77.                            (list (list (gensym) x))))
  78.                    form))
  79.           (revlist (mapcar #'(lambda (x) (cons (second x) (first x)))
  80.                    letlist))
  81.           (newform (cons (first form) (sublis revlist args))))
  82.          (cons letlist newform)))
  83.  
  84. (defun |RemProp| (l prop)
  85.        (do ((cl l (cddr cl))
  86.         (flg nil cl))
  87.        ((atom cl) nil)    ; none found 
  88.        (cond ((atom (cdr l)) 
  89.           (error "odd length property list"))
  90.          ((eq (car cl) prop) ; a match!
  91.           (if flg ; different if first in list from later 
  92.               (rplacd (cdr flg) (cddr cl))
  93.               (setq l (cddr l)))
  94.           (return (list l))))))
  95.  
  96. (defmacro remf (form prop &aux (remres (gensym)))
  97.       (if (and (consp form) (some #'consp form))
  98.           (let ((retval (|DoForm| form)))
  99.            `(let* ( ,@(car retval)
  100.                 (,remres (|RemProp| ,(cdr retval) ,prop)))
  101.               (if ,remres
  102.                   (progn (setf ,(cdr retval) (car ,remres))
  103.                      t)
  104.                   nil)))
  105.           `(let ((,remres (|RemProp| ,form ,prop)))
  106.             (if ,remres (progn (setf ,form (car ,remres)) t)
  107.             nil))))
  108.  
  109. #-:packages
  110. (unintern '|RemProp|)
  111.  
  112. (defmacro incf (form &optional (delta 1))
  113.       (if (and (consp form) (some #'consp form))
  114.           (let ((retval (|DoForm| form)))
  115.            `(let ,(car retval) 
  116.              (setf ,(cdr retval)
  117.                    (+ ,(cdr retval) ,delta))))
  118.           `(setf ,form (+ ,form ,delta))))
  119.  
  120. (defmacro decf (form &optional (delta 1))
  121.       (if (and (consp form) (some #'consp form))
  122.           (let ((retval (|DoForm| form)))
  123.            `(let ,(car retval) 
  124.              (setf ,(cdr retval)
  125.                    (- ,(cdr retval) ,delta))))
  126.           `(setf ,form (- ,form ,delta))))
  127.  
  128. (defmacro push (val form)
  129.       (if (and (consp form) (some #'consp form))
  130.           (let ((retval (|DoForm| form)))
  131.            `(let ,(car retval) 
  132.              (setf ,(cdr retval)
  133.                    (cons ,val ,(cdr retval)))))
  134.           `(setf ,form (cons ,val ,form))))
  135.  
  136. (defmacro pop (form)
  137.       (if (and (consp form) (some #'consp form))
  138.           (let ((retval (|DoForm| form)))
  139.            `(let ,(car retval) 
  140.              (prog1 (first ,(cdr retval))
  141.                 (setf ,(cdr retval)
  142.                       (rest ,(cdr retval))))))
  143.           `(prog1 (first ,form)
  144.               (setf ,form (rest ,form)))))
  145.  
  146.  
  147. (defmacro pushnew (val form &rest rest)
  148.       (if (and (consp form) (some #'consp form))
  149.           (let ((retval (|DoForm| form)))
  150.            `(let ,(car retval) 
  151.              (setf ,(cdr retval)
  152.                    (adjoin ,val ,(cdr retval) ,@rest))))
  153.           `(setf ,form (adjoin ,val ,form ,@rest))))
  154.  
  155. ; DoForm is now needed in COMMON2.LSP
  156. ; #-:packages
  157. ; (unintern '|DoForm|)
  158.  
  159. ;; Hyperbolic functions    Ken Whedbee  from CLtL
  160.  
  161. (export '(logtest cis sinh cosh tanh asinh acosh atanh))
  162.  
  163. #-:bignums (defun logtest (x y) (not (zerop (logand x y))))
  164.  
  165. (defconstant imag-one #C(0.0 1.0))
  166.  
  167. (defun cis (x) (exp (* imag-one x)))
  168.  
  169.  
  170. (defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0))
  171. (defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0))
  172. (defun tanh (x) (/ (sinh x) (cosh x)))
  173.  
  174. (defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
  175. (defun acosh (x)
  176.        (log (+ x
  177.                (* (1+ x)
  178.                     (sqrt (/ (1- x) (1+ x)))))))
  179. (defun atanh (x)
  180.        (when (or (= x 1.0) (= x -1.0))
  181.              (error "~s is a logarithmic singularity" x))
  182.        (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
  183.     
  184.  
  185.  
  186. ;; Additional Common Lisp Functions by Luke Tierney
  187. ;; from xlisp-stat
  188.  
  189. ;;
  190. ;; Defsetf and documentation functions
  191. ;; Corrected for Common Lisp compatibility (requires XLISP-PLUS 2.1e)
  192. ;;  Modified by Tom Almy, 7/92
  193. ;;  Corrected again in 6/93
  194. ;;  and again (Luke Tierney) 11/93
  195. ;;
  196.  
  197. (export '(defsetf))
  198.  
  199. (defun apply-arg-rotate (f args) 
  200.   (apply f (list 'quote (car (last args))) (butlast args)))
  201.  
  202. ; (defsetf) - define setf method
  203. (defmacro defsetf (sym first &rest rest)
  204.   (if (symbolp first)
  205.       `(progn (setf (get ',sym '*setf*) #',first)
  206.           (remprop ',sym '*setf-lambda*)
  207.           ',sym)
  208.       (let ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
  209.             (args (gensym)))
  210.         `(progn
  211.           (setf (get ',sym '*setf-lambda*) ; changed *setf* to *setf-lambda*
  212.                 #'(lambda (&rest ,args) (apply-arg-rotate ,f ,args)))
  213.       (remprop ',sym '*setf*)
  214.           ',sym))))
  215.  
  216.  
  217. ;;;;
  218. ;;;;
  219. ;;;; Modules, provide and require:  Luke Tierney, from xlisp-stat
  220. ;;;;
  221. ;;;;
  222.  
  223. ; Uncomment these if you want them. It's non-standard, and nothing else
  224. ; in this distribution  uses them, so I'm commenting them out.  Tom Almy
  225.  
  226. #|
  227. (defvar *modules*)
  228.     
  229. (defun provide (name)
  230.   (pushnew name *modules* :test #'equal))
  231.   
  232. (defun require (name &optional (path name))
  233.   (let ((name (string name))
  234.         (path (string path)))
  235.     (unless (member name *modules* :test #'equal)
  236.             (if (load path)
  237.                 t
  238.         (load (strcat *default-path* path))))))
  239. |#
  240. ;;;;
  241. ;;;;
  242. ;;;; Miscellaneous Functions:  Luke Tierney
  243. ;;;;    from xlisp-stat
  244. ;;;;
  245.  
  246. (export '(equalp y-or-n-p yes-or-no-p functionp with-input-from-string
  247.           with-output-to-string with-open-file))
  248.  
  249. ; equalp rewritten by Tom Almy to better match Common Lisp
  250. (defun equalp (x y)
  251.   (cond ((equal x y) t)
  252.       ((numberp x) (if (numberp y) (= x y) nil))
  253.       ((characterp x) (if (characterp y) (char-equal x y) nil))
  254.       ((and (or (arrayp x) (stringp x)) 
  255.             (or (arrayp y) (stringp y))
  256.             (eql (length x) (length y)))
  257.        (every #'equalp x y))))
  258.  
  259. ; Modified by TAA
  260. #-:getkey
  261. (defun y-or-n-p (&rest args)
  262.        (reset-system)
  263.        (when args (fresh-line) (apply #'format *terminal-io* args))
  264.        (do ((answer (string-trim " " (read-line))
  265.             (string-trim " " (read-line))))
  266.        ((or (string-equal answer "Y")
  267.         (string-equal answer "N"))
  268.         (string-equal answer "Y"))
  269.        (princ " Answer \"y\" or \"n\": " *terminal-io*)))
  270.  
  271. #+:getkey
  272. (defun y-or-n-p (&rest args)
  273.        (when args (fresh-line) (apply #'format *terminal-io* args))
  274.        (do ((answer (princ (int-char (get-key)))
  275.             (princ (int-char (get-key)))))
  276.        ((or (char-equal answer #\Y)
  277.         (char-equal answer #\N))
  278.         (char-equal answer #\Y))
  279.        (princ "\nAnswer \"y\" or \"n\": " *terminal-io*)))
  280.  
  281.  
  282. ; Based on y-or-n-p
  283. (defun yes-or-no-p (&rest args)
  284.        (reset-system)
  285.        (when args (fresh-line) (apply #'format *terminal-io* args))
  286.        (do ((answer (string-trim " " (read-line))
  287.             (string-trim " " (read-line))))
  288.        ((or (string-equal answer "YES")
  289.         (string-equal answer "NO"))
  290.         (string-equal answer "YES"))
  291.        (princ " Answer \"yes\" or \"no\": " *terminal-io*)))
  292.  
  293. ; Improved by TAA to match common lisp definition
  294. (defun functionp (x)
  295.     (if (typep x '(or closure subr symbol))
  296.     t
  297.         (and (consp x) (eq (car x) 'lambda))))
  298.  
  299. ;(defmacro with-input-from-string (stream-string &rest body)
  300. ;  (let ((stream (first stream-string))
  301. ;        (string (second stream-string)))
  302. ;    `(let ((,stream (make-string-input-stream ,string)))
  303. ;       (progn ,@body))))
  304.  
  305.  
  306. (defmacro with-input-from-string
  307.       (stream-string &rest body)
  308.       (let ((stream (first stream-string))
  309.         (string (second stream-string))
  310.         (start (second (member :start (cddr stream-string))))
  311.         (end (second (member :end (cddr stream-string))))
  312.         (index (second (member :index (cddr stream-string)))))
  313.            (when (null start) (setf start 0))
  314.            (if index
  315.            (let ((str (gensym)))
  316.             `(let* ((,str ,string)
  317.                 (,stream (make-string-input-stream ,str 
  318.                                    ,start 
  319.                                    ,end)))
  320.                (prog1 (progn ,@body)
  321.                   (setf ,index 
  322.                     (- (length ,str)
  323.                        (length (get-output-stream-list 
  324.                              ,stream)))))))
  325.            `(let ((,stream (make-string-input-stream ,string ,start ,end)))
  326.              (progn ,@body)))))
  327.            
  328.  
  329. (defmacro with-output-to-string (str-list &rest body)
  330.   (let ((stream (first str-list)))
  331.     `(let ((,stream (make-string-output-stream)))
  332.        (progn ,@body)
  333.        (get-output-stream-string ,stream))))
  334.  
  335. (defmacro with-open-file (stream-file-args &rest body)
  336.   (let ((stream (first stream-file-args))
  337.         (file-args (rest stream-file-args)))
  338.     `(let ((,stream (open ,@file-args)))
  339.        (unwind-protect 
  340.            (progn ,@body)
  341.          (when ,stream (close ,stream))))))
  342.  
  343. (export '(eval-when declare proclaim special))
  344. ;; Dummy function to allow importing CL code
  345. (defmacro eval-when (when &rest body)
  346.   (if (or (member 'eval when) (member 'execute when))
  347.       `(progn ,@body)))
  348. (defmacro declare (&rest args)
  349.   (if *displace-macros*
  350.       (dolist (a args)
  351.         (if (eq (first a) 'special)
  352.         (return (cerror "special ignored"
  353.                 "special declarations are not supported"))))))
  354. (defun proclaim (decl)
  355.   (if (eq (first decl) 'special)
  356.       (dolist (s (rest decl))
  357.         (mark-as-special s))))
  358.  
  359.  
  360. ;; array functions.   KCW    from  Kyoto Common Lisp
  361.  
  362. (export '(fill replace acons))
  363.  
  364. (defun fill (sequence item
  365.              &key (start 0) end)
  366.        (when (null end) (setf end (length sequence)))
  367.        (do ((i start (1+ i)))
  368.        ((>= i end) sequence)
  369.        (setf (elt sequence i) item)))
  370.  
  371.  
  372. (defun replace (sequence1 sequence2
  373.                 &key (start1 0) end1
  374.                      (start2 0) end2)
  375.     (when (null end1) (setf end1 (length sequence1)))
  376.     (when (null end2) (setf end2 (length sequence2)))
  377.     (if (and (eq sequence1 sequence2)
  378.              (> start1 start2))
  379.         (do* ((i 0 (1+ i))
  380.               (l (if (< (- end1 start1) (- end2 start2))
  381.                      (- end1 start1)
  382.                      (- end2 start2)))
  383.               (s1 (+ start1 (1- l)) (1- s1))
  384.               (s2 (+ start2 (1- l)) (1- s2)))
  385.             ((>= i l) sequence1)
  386.           (setf (elt sequence1 s1) (elt sequence2 s2)))
  387.         (do ((i 0 (1+ i))
  388.              (l (if (< (- end1 start1)(- end2 start2))
  389.                     (- end1 start1)
  390.                     (- end2 start2)))
  391.              (s1 start1 (1+ s1))
  392.              (s2 start2 (1+ s2)))
  393.             ((>= i l) sequence1)
  394.           (setf (elt sequence1 s1) (elt sequence2 s2)))))
  395.  
  396.  
  397. (defun acons (x y a)         ; from CLtL
  398.    (cons (cons x y) a))
  399.  
  400.  
  401. ;; more set functions.  KCW    from Kyoto Common Lisp
  402.  
  403. ;; Modified to pass keys to subfunctions without checking here
  404. ;; (more efficient)
  405.  
  406. ;; (Tom Almy states:) we can't get the destructive versions of union
  407. ;; intersection, and set-difference to run faster than the non-destructive
  408. ;; subrs. Therefore we will just have the destructive versions do their
  409. ;; non-destructive counterparts
  410.  
  411. (export '(nunion nintersection nset-difference
  412.       set-exclusive-or nset-exclusive-or))
  413.  
  414. (setf (symbol-function 'nunion) 
  415.       (symbol-function 'union)
  416.       (symbol-function 'nintersection) 
  417.       (symbol-function 'intersection)
  418.       (symbol-function 'nset-difference) 
  419.       (symbol-function 'set-difference))
  420.  
  421. (defun set-exclusive-or (list1 list2 &rest rest)
  422.   (append (apply #'set-difference list1 list2 rest)
  423.           (apply #'set-difference list2 list1 rest)))
  424.  
  425. (defun nset-exclusive-or (list1 list2 &rest rest)
  426.   (nconc (apply #'set-difference list1 list2 rest)
  427.          (apply #'set-difference list2 list1 rest)))
  428.  
  429.  
  430.  
  431. ;;;;;
  432. ;;;;; Symbol and Package Functions
  433. ;;;;;
  434. #+:packages
  435. (export '(defpackage do-symbols do-external-symbols do-all-symbols
  436.       apropos apropos-list))
  437.  
  438. #+:packages
  439. (defmacro do-symbol-arrays (s res a body)
  440.   (let ((arraysym (gensym))
  441.     (isym (gensym))
  442.     (asym (gensym))
  443.     (listsym (gensym)))     
  444.     `(let ((,arraysym ,a)
  445.        (,isym 0)
  446.        (,asym nil)
  447.        (,listsym nil)
  448.        (,s nil))
  449.        (block nil
  450.          (tagbody
  451.       new-array
  452.       (when (null ,arraysym)
  453.         (setf ,s nil)
  454.         (return ,res))
  455.       (setf ,asym (first ,arraysym) ,arraysym (rest ,arraysym) ,isym -1)
  456.       new-list
  457.       (setf ,isym (1+ ,isym))
  458.       (if (<= 199 ,isym) (go new-array))
  459.       (setf ,listsym (aref ,asym ,isym))
  460.       new-item
  461.       (if (null ,listsym) (go new-list))
  462.       (setf ,s (first ,listsym) ,listsym (rest ,listsym))
  463.       (tagbody ,@body)
  464.       (go new-item))))))
  465.  
  466. #+:packages
  467. (defmacro do-symbols (spr &rest body)
  468.   (let ((packsym (gensym))
  469.     (usessym (gensym))
  470.     (arraysym (gensym)))
  471.     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
  472.         (,usessym (package-use-list ,packsym))
  473.         (,arraysym (cons (package-obarray ,packsym nil)
  474.                  (mapcar #'package-obarray
  475.                      (cons ,packsym ,usessym)))))
  476.        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
  477.  
  478. #+:packages
  479. (defmacro do-external-symbols (spr &rest body)
  480.   (let ((packsym (gensym))
  481.     (arraysym (gensym)))
  482.     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
  483.         (,arraysym (list (package-obarray ,packsym))))
  484.        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
  485.  
  486. #+:packages
  487. (defmacro do-all-symbols (sr &rest body)
  488.   (let ((packsym (gensym))
  489.     (arraysym (gensym)))
  490.     `(let* ((,packsym (list-all-packages))
  491.         (,arraysym nil))
  492.        (dolist (p ,packsym)
  493.          (push (package-obarray p) ,arraysym)
  494.      (push (package-obarray p nil) ,arraysym))
  495.        (do-symbol-arrays ,(first sr) ,(second sr) ,arraysym ,body))))
  496.  
  497. #+:packages
  498. (defmacro defpackage (pname &rest options)
  499.   `(let* ((pname ',pname)
  500.       (options ',options)
  501.       (pack (find-package ',pname))
  502.       (nicknames nil))
  503.      (dolist (opt options)
  504.        (if (eq (first opt) :nicknames)
  505.        (setf nicknames (append (rest opt) nicknames))))
  506.      (if pack
  507.      (rename-package pack
  508.              pname
  509.              (mapcar #'string
  510.                  (append nicknames (package-nicknames pack))))
  511.          (setf pack (make-package pname :nicknames 
  512.                   (mapcar #'string nicknames))))
  513.      (dolist (opt options)
  514.        (case (first opt)
  515.          (:shadow (shadow (mapcar #'string (rest opt)) pack))
  516.      (:shadowing-import-from
  517.       (let ((from-pack (find-package (second opt))))
  518.         (dolist (sname (rest (rest opt)))
  519.           (multiple-value-bind (sym found)
  520.                    (find-symbol (string sname) from-pack)
  521.             (if found
  522.             (shadowing-import sym pack)
  523.             (error "no symbol named ~s in package ~s"
  524.                (string sname)
  525.                from-pack))))))))
  526.      (dolist (opt options)
  527.        (if (eq (first opt) :use)
  528.        (use-package (mapcar #'string (rest opt)) pack)))
  529.      (dolist (opt options)
  530.        (case (first opt)
  531.          (:intern
  532.       (dolist (sname (rest opt)) (intern (string sname) pack)))
  533.      (:import-from
  534.       (let ((from-pack (find-package (second opt))))
  535.         (dolist (sname (rest (rest opt)))
  536.           (multiple-value-bind (sym found)
  537.                    (find-symbol (string sname) from-pack)
  538.             (if found
  539.             (import sym pack)
  540.             (error "no symbol named ~s in package ~s"
  541.                (string sname)
  542.                from-pack))))))))
  543.      (dolist (opt options)
  544.        (if (eq (first opt) :export)
  545.        (dolist (sname (rest opt))
  546.          (export (intern (string sname) pack) pack))))
  547.      pack))
  548.  
  549. #+:packages
  550. (defun apropos2 (s)
  551.        (format t "~&~s" s)
  552.        (when (fboundp s) (format t "  Function"))
  553.        (if (constantp s)
  554.        (format t "  Constant=~s" (symbol-value s))
  555.        (when (boundp s) (format t "  Value=~s" (symbol-value s)))))
  556.        
  557. #+:packages
  558. (defun apropos (x &optional package)
  559.        (if package
  560.        (do-symbols (s package)
  561.                (if (search x (string s) :test #'char-equal)
  562.                (apropos2 s)))
  563.        (do-all-symbols (s)
  564.                (if (search x (string s) :test #'char-equal)
  565.                    (apropos2 s))))
  566.        (values))
  567.  
  568. #+:packages
  569. (defun apropos-list (x &optional package)
  570.        (let ((res nil))
  571.         (if package
  572.         (do-symbols (s package res)
  573.                 (if (search x (string s) :test #'char-equal)
  574.                 (push s res)))
  575.         (do-all-symbols (s res)
  576.                 (if (search x (string s) :test #'char-equal)
  577.                     (push s res))))))
  578.  
  579.  
  580. ;;;;;
  581. ;;;;; Additional Multipla Value Functions and Macros
  582. ;;;;;
  583.  
  584. (export
  585.  '(values-list multiple-value-list multiple-value-bind multiple-value-setq))
  586.  
  587. (defun values-list (x) (apply #'values x))
  588.  
  589. (defmacro multiple-value-list (form)
  590.   `(multiple-value-call #'list ,form))
  591.  
  592. (defmacro multiple-value-bind (vars form &rest body)
  593.   `(multiple-value-call #'(lambda (&optional ,@vars &rest ,(gensym)) ,@body)
  594.             ,form))
  595.  
  596. (defmacro multiple-value-setq (variables form)
  597.   (let* ((tvars (mapcar #'(lambda (x) (gensym "V")) variables))
  598.      (pairs nil))
  599.     (mapc #'(lambda (x y) (push y pairs) (push x pairs)) variables tvars)
  600.     (if (null tvars) (push (gensym) tvars))
  601.     `(multiple-value-bind ,tvars ,form (setq ,@pairs) ,(first tvars))))
  602.  
  603. (push :common *features*)
  604.