src/lsp/common.lsp

   1 ;;;;
   2 ;;;; Additional Common Lisp Functions for XLISP-STAT 2.0
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (in-package "XLISP")
  10
  11 ;**** This hack is necessary for the moment because X is one of the
  12 ;**** plot symbols. This should be dropped one the statistics stuff is
  13 ;**** properly assigned to packages.
  14 (export 'x)
  15
  16 (export '(fifth sixth seventh eighth ninth tenth))
  17
  18 (defun fifth (x) (nth 4 x))
  19 (defun sixth (x) (nth 5 x))
  20 (defun seventh (x) (nth 6 x))
  21 (defun eighth (x) (nth 7 x))
  22 (defun ninth (x) (nth 8 x))
  23 (defun tenth (x) (nth 9 x))
  24
  25
  26 ;;;;
  27 ;;;; Compiler symbols
  28 ;;;;
  29
  30 (export '(compile compile-file))
  31
  32 (defvar *cmp-setf*)
  33
  34 ;;;;
  35 ;;;; Other symbols
  36 ;;;;
  37
  38 (export 'step)
  39
  40
  41 ;;;;
  42 ;;;; Simplified DEFTYPE and some additional types
  43 ;;;;
  44
  45 (export '(deftype flonum short-float single-float double-float long-float real
  46           sequence))
  47
  48 (defun deftype-arglist-fix (args)
  49   (let ((optpos (position '&optional args)))
  50     (if optpos
  51         (let* ((start (+ optpos 1))
  52                (nkey (position-if #'(lambda (x)
  53                                       (member x lambda-list-keywords))
  54                                 args
  55                                 :start start))
  56                (end (if nkey nkey (length args)))
  57                (nargs (copy-list args)))
  58           (do ((i start (+ i 1)))
  59               ((<= end i) nargs)
  60               (let ((v (nth i nargs)))
  61                 (if (symbolp v) (setf (nth i nargs) `(,v '*))))))
  62         args)))
  63
  64 (defmacro deftype (type args &rest forms)
  65   (let ((fargs (deftype-arglist-fix args)))
  66     `(progn (setf (get ',type '*type-spec*) #'(lambda ,fargs ,@forms))
  67             ',type)))
  68
  69 (deftype flonum () 'float)
  70 (deftype short-float () 'float)
  71 (deftype single-float () 'float)
  72 (deftype double-float () 'float)
  73 (deftype long-float () 'float)
  74
  75 (deftype real () '(or integer ratio float))
  76 (deftype rational () '(or integer ratio))
  77
  78 ;;**** keyword type?
  79
  80 (deftype sequence () '(satisfies sequencep))
  81
  82
  83 ;;;;
  84 ;;;; EVAL-WHEN
  85 ;;;;
  86
  87 (export '(eval-when))
  88
  89 (defmacro eval-when (when &rest body)
  90   (if (or (member 'eval when) (member :execute when))
  91       `(progn ,@body)))
  92
  93
  94 ;;;;
  95 ;;;; Defsetf and documentation functions
  96 ;;;; Corrected for Common Lisp compatibility (requires XLISP-PLUS 2.1e)
  97 ;;;;  Modified by Tom Almy, 7/92
  98 ;;;;  Corrected again in 6/93
  99 ;;;;  and again (Luke Tierney) 11/93
 100 ;;;;
 101
 102 (export '(defsetf documentation))
 103
 104 (defun apply-arg-rotate (f args)
 105   (apply f (car (last args)) (butlast args)))
 106
 107 ; (defsetf) - define setf method
 108 (defmacro defsetf (sym first &rest rest)
 109   (if (symbolp first)
 110       `(progn (setf (get ',sym '*setf*) ',first)
 111               (remprop ',sym '*setf-lambda*)
 112               (eval-when (:compile-toplevel)
 113                          (push (list ',sym '*setf* ',first) *cmp-setf*))
 114               ',sym)
 115       (let* ((f `#'(lambda ,(append (car rest) first) ,@(cdr rest)))
 116              (args (gensym))
 117              (ff `#'(lambda (&rest ,args) (apply-arg-rotate ,f ,args))))
 118         `(progn
 119           (setf (get ',sym '*setf-lambda*) ; changed *setf* to *setf-lambda*
 120                 ,ff)
 121           (eval-when (:compile-toplevel)
 122                      (push (list ',sym '*setf-lambda* ,ff) *cmp-setf*))
 123           (remprop ',sym '*setf*)
 124           ',sym))))
 125
 126 ;; (load-help) - read in file positions fo accessing help info.
 127 (defun load-help ()
 128   (when
 129    (and (null *help-loaded*) (streamp *help-stream*))
 130    (princ "loading in help file information - this will take a minute ...")
 131    (force-output)
 132    (setq *help-loaded* t)
 133    (file-position *help-stream* 0)
 134    (do ((item (read *help-stream* nil '*eof*)
 135               (read *help-stream* nil '*eof*)))
 136        ((eq item '*eof*))
 137        (cond
 138         ((and item
 139               (symbolp item)
 140               (null (get item 'function-documentation)))
 141          (setf (get item 'function-documentation)
 142                (file-position *help-stream*)))
 143         ((consp item)
 144          (case (cadr item)
 145                (function (if (null (get (car item) 'function-documentation))
 146                              (setf (get (car item) 'function-documentation)
 147                                    (file-position *help-stream*))))
 148                (variable (if (null (get (car item) 'variable-documentation))
 149                              (setf (get (car item) 'variable-documentation)
 150                                    (file-position *help-stream*))))
 151                (type (if (null (get (car item) 'type-documentation))
 152                          (setf (get (car item) 'type-documentation)
 153                                (file-position *help-stream*))))
 154                (object
 155                 (if (and (boundp (car item))
 156                          (objectp (symbol-value (car item)))
 157                          (null (send (symbol-value (car item))
 158                                      :internal-doc
 159                                      (caddr item))))
 160                     (send (symbol-value (car item))
 161                           :documentation
 162                           (caddr item)
 163                           (file-position *help-stream*))))))))
 164    (princ "done")
 165    (terpri)))
 166
 167 (defun documentation (symbol doc-type)
 168   (load-help)
 169   (let ((doc  (case doc-type
 170                 (function (get symbol 'function-documentation))
 171                 (variable (get symbol 'variable-documentation))
 172                 (type     (get symbol 'type-documentation))
 173                 (setf     (get symbol 'setf-documentation)))))
 174     (when (and (numberp doc) (streamp *help-stream*))
 175           (file-position *help-stream* doc)
 176           (setq doc (read *help-stream*)))
 177     (if (stringp doc) doc)))
 178
 179 (defsetf documentation (symbol doc-type) (value)
 180   `(case ,doc-type
 181      (function (setf (get ,symbol 'function-documentation) ,value))
 182      (variable (setf (get ,symbol 'variable-documentation) ,value))
 183      (type     (setf (get ,symbol 'type-documentation) ,value))
 184      (setf     (setf (get ,symbol 'setf-documentation) ,value))))
 185
 186 (defsetf first (x) (v) `(setf (car ,x) ,v))
 187 (defsetf second (x) (v) `(setf (nth 1 ,x) ,v))
 188 (defsetf third (x) (v) `(setf (nth 2 ,x) ,v))
 189 (defsetf fourth (x) (v) `(setf (nth 3 ,x) ,v))
 190 (defsetf fifth (x) (v) `(setf (nth 4 ,x) ,v))
 191 (defsetf sixth (x) (v) `(setf (nth 5 ,x) ,v))
 192 (defsetf seventh (x) (v) `(setf (nth 6 ,x) ,v))
 193 (defsetf eighth (x) (v) `(setf (nth 7 ,x) ,v))
 194 (defsetf ninth (x) (v) `(setf (nth 8 ,x) ,v))
 195 (defsetf tenth (x) (v) `(setf (nth 9 ,x) ,v))
 196
 197 (defsetf rest (x) (v) `(setf (cdr ,x) ,v))
 198
 199 (defsetf %struct-ref (x i) (v) `(%struct-set ,x ,i ,v))
 200
 201 (defun %set-rm-aref (x i v) (setf (aref (compound-data-seq x) i) v))
 202 (defsetf row-major-aref %set-rm-aref)
 203
 204 ;; Defsetf's for forms handled by the internal version.  These need to
 205 ;; appear before any redefinition of setf for bootstrapping purposes.
 206 (defsetf get %set-get)
 207 (defsetf symbol-value %set-symbol-value)
 208 (defsetf symbol-function %set-symbol-function)
 209 (defsetf symbol-plist %set-symbol-plist)
 210 (defsetf car %set-car)
 211 (defsetf cdr %set-cdr)
 212 (defsetf aref %set-aref)
 213 (defsetf gethash %set-gethash)
 214
 215 (defsetf select set-select)
 216 (defsetf slot-value slot-value)
 217
 218 (defsetf nth %set-nth)
 219 (defsetf elt %set-elt)
 220 (defsetf svref %set-svref)
 221
 222
 223 ;;;;
 224 ;;;;
 225 ;;;; Modules, provide and require
 226 ;;;;
 227 ;;;;
 228
 229 (export '(*modules* provide require probe-file))
 230
 231 (defvar *modules* nil)
 232
 233 (defun provide (name)
 234   (pushnew name *modules* :test #'equal))
 235
 236 (export '(system::*module-path* system::create-module-path)
 237         "SYSTEM")
 238
 239 (defvar *module-path* nil)
 240
 241 (defun require (name &optional (path (string name)))
 242   (let ((name (string name))
 243         (pathlist (if (listp path) path (list path))))
 244     (unless (member name *modules* :test #'equal)
 245             (dolist (pathname pathlist)
 246               (let ((rpath (find-require-file pathname)))
 247                 (if rpath
 248                     (load rpath)
 249                   (load pathname :if-does-not-exist nil)))))))
 250
 251 (defun find-require-file (path)
 252   (let ((type (pathname-type path)))
 253     (dolist (dir *module-path*)
 254       (let ((p (merge-pathnames path dir)))
 255         (cond
 256          ((eq (system::file-type p) :directory)
 257           (let* ((dl (append (pathname-directory p) (list (pathname-name p))))
 258                  (d (make-pathname :directory dl
 259                                    :device (pathname-device p)
 260                                    :host (pathname-host p)))
 261                  (ap (merge-pathnames "_autoidx" d)))
 262             (when (or (probe-file (merge-pathnames ap ".lsp"))
 263                       (probe-file (merge-pathnames ap ".fsl")))
 264                   (return ap))))
 265          (type (when (probe-file p) (return p)))
 266          ((or (probe-file (merge-pathnames p ".lsp"))
 267               (probe-file (merge-pathnames p ".fsl")))
 268           (return p))
 269          ((probe-file p) (return p)))))))
 270
 271 (defun create-module-path ()
 272   (list (make-pathname :directory '(:relative))
 273         *default-path*
 274         (merge-pathnames (make-pathname :directory '(:relative "Examples"))
 275                          *default-path*)))
 276
 277 (defun probe-file (f)
 278   (when (open f :direction :probe)
 279         (truename f)))
 280
 281
 282 ;;;;
 283 ;;;;
 284 ;;;; Miscellaneous Functions
 285 ;;;;
 286 ;;;;
 287
 288 (export '(matrixp equalp y-or-n-p yes-or-no-p
 289           incf decf push pop pushnew remf rotatef
 290           with-input-from-string with-output-to-string
 291           with-open-file with-open-stream read-from-string
 292           realp typecase))
 293
 294 (defun matrixp (x) (and (arrayp x) (= (array-rank x) 2)))
 295
 296 ; equalp rewritten by Tom Almy to better match Common Lisp
 297 (defun equalp (x y)
 298   (cond ((equal x y) t)
 299         ((numberp x) (if (numberp y) (= x y) nil))
 300         ((characterp x) (if (characterp y) (char-equal x y) nil))
 301         ((listp x)
 302          (and (listp y) (= (length x) (length y)) (every #'equalp x y)))
 303         ((and (or (arrayp x) (stringp x))
 304               (or (arrayp y) (stringp y))
 305               (eql (length x) (length y)))
 306          (every #'equalp x y))))
 307
 308 ; Modified by TAA
 309 (defun y-or-n-p (&rest args)
 310        (reset-system)
 311        (when args (fresh-line) (apply #'format *terminal-io* args))
 312        (do ((answer (string-trim " " (read-line))
 313                     (string-trim " " (read-line))))
 314            ((or (string-equal answer "Y")
 315                 (string-equal answer "N"))
 316             (string-equal answer "Y"))
 317            (princ " Answer \"y\" or \"n\": " *terminal-io*)))
 318
 319 ; Based on y-or-n-p
 320 (defun yes-or-no-p (&rest args)
 321        (reset-system)
 322        (when args (fresh-line) (apply #'format *terminal-io* args))
 323        (do ((answer (string-trim " " (read-line))
 324                     (string-trim " " (read-line))))
 325            ((or (string-equal answer "YES")
 326                 (string-equal answer "NO"))
 327             (string-equal answer "YES"))
 328            (princ " Answer \"yes\" or \"no\": " *terminal-io*)))
 329
 330 ;***** modified version with keywords?
 331 (defmacro with-input-from-string (stream-string &rest body)
 332   (let ((stream (first stream-string))
 333         (string (second stream-string))
 334         (start (second (member :start (cddr stream-string))))
 335         (end (second (member :end (cddr stream-string))))
 336         (index (second (member :index (cddr stream-string)))))
 337     (when (null start) (setf start 0))
 338     (if index
 339         (let ((str (gensym)))
 340           `(let* ((,str ,string)
 341                   (,stream (make-string-input-stream ,str ,start ,end)))
 342              (prog1 (progn ,@body)
 343                (setf ,index
 344                      (- (length ,str)
 345                         (length (get-output-stream-list ,stream)))))))
 346         `(let ((,stream (make-string-input-stream ,string ,start ,end)))
 347            (progn ,@body)))))
 348
 349 (defmacro with-output-to-string (str-list &rest body)
 350   (let ((stream (first str-list)))
 351     `(let ((,stream (make-string-output-stream)))
 352        (progn ,@body)
 353        (get-output-stream-string ,stream))))
 354
 355 (defmacro with-open-file (stream-file-args &rest body)
 356   (let ((stream (first stream-file-args))
 357         (file-args (rest stream-file-args)))
 358     `(let ((,stream (open ,@file-args)))
 359        (unwind-protect
 360            (progn ,@body)
 361          (when ,stream (close ,stream))))))
 362
 363 (defmacro with-open-stream (stream-args &rest body)
 364   `(let ((,(first stream-args) ,(second stream-args)))
 365      (unwind-protect
 366          (progn ,@body)
 367        (when ,(first stream-args) (close ,(first stream-args))))))
 368
 369 (defun read-from-string (string &optional (eof-error-p t) eof-value
 370                                 &key (start 0) end preserve-whitespace)
 371   (read (make-string-input-stream string start end) eof-error-p eof-value))
 372
 373 (defun realp (x) (or (rationalp x) (floatp x)))
 374
 375 (defmacro typecase (x &rest forms)
 376   (let ((varsym (gensym "VAR")))
 377     (flet ((fix-clause (f) (cons `(typep ,varsym ',(first f)) (rest f))))
 378       `(let ((,varsym ,x))
 379          (cond
 380           ,@(if (member (first (first (last forms))) '(t otherwise))
 381                 (append (mapcar #'fix-clause (butlast forms))
 382                         (list (cons t (rest (first (last forms))))))
 383                 (mapcar #'fix-clause forms)))))))
 384
 385 ;;
 386 ;; from xlisp-2.1f
 387 ;;
 388
 389 (export '(pairlis copy-alist copy-tree signum))
 390
 391 ;; pairlis does not check for lengths of keys and values being unequal
 392 (defun pairlis (keys values &optional list)
 393   (nconc (mapcar #'cons keys values) list))
 394
 395 (defun copy-alist (list)
 396   (if (null list)
 397       'nil
 398       (cons (if (consp (car list))
 399                 (cons (caar list) (cdar list))
 400                 (car list))
 401             (copy-alist (cdr list)))))
 402
 403 (defun copy-tree (list)
 404   (if (consp list)
 405       (cons (copy-tree (car list)) (copy-tree (cdr list)))
 406       list))
 407
 408 (defun signum (x)
 409   (if (numberp x)
 410       (if (zerop x) x (/ x (abs x)))
 411       (map-elements #'signum x)))
 412
 413 ;; Hyperbolic functions    Ken Whedbee  from CLtL
 414
 415 (export '(logtest cis sinh cosh tanh asinh acosh atanh))
 416
 417 (defun logtest (x y) (not (zerop (logand x y))))
 418
 419 (defun cis (x) (exp (* #c(0.0 1.0) x)))
 420
 421 (defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0))
 422 (defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0))
 423 (defun tanh (x) (/ (sinh x) (cosh x)))
 424
 425 (defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
 426 (defun acosh (x) (log (+ x (* (1+ x) (sqrt (/ (1- x) (1+ x)))))))
 427 (defun atanh (x) (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
 428
 429 ;; array functions.   KCW    from  Kyoto Common Lisp
 430
 431 (export '(fill acons))
 432
 433 (defun fill (sequence item &key (start 0) end)
 434   (when (null end) (setf end (length sequence)))
 435   (do ((i start (1+ i)))
 436       ((>= i end) sequence)
 437       (setf (elt sequence i) item)))
 438
 439 (defun acons (x y a)         ; from CLtL
 440   (cons (cons x y) a))
 441
 442
 443 ;; more set functions.  KCW    from Kyoto Common Lisp
 444
 445 ;; Modified to pass keys to subfunctions without checking here
 446 ;; (more efficient)
 447
 448 ;; (Tom Almy states:) we can't get the destructive versions of union
 449 ;; intersection, and set-difference to run faster than the non-destructive
 450 ;; subrs. Therefore we will just have the destructive versions do their
 451 ;; non-destructive counterparts
 452
 453 (export
 454  '(nunion nintersection nset-difference set-exclusive-or nset-exclusive-or))
 455
 456 (setf (symbol-function 'nunion)
 457       (symbol-function 'union)
 458       (symbol-function 'nintersection)
 459       (symbol-function 'intersection)
 460       (symbol-function 'nset-difference)
 461       (symbol-function 'set-difference))
 462
 463 (defun set-exclusive-or (list1 list2 &rest rest)
 464   (append (apply #'set-difference list1 list2 rest)
 465           (apply #'set-difference list2 list1 rest)))
 466
 467 (defun nset-exclusive-or (list1 list2 &rest rest)
 468   (nconc (apply #'set-difference list1 list2 rest)
 469          (apply #'set-difference list2 list1 rest)))
 470
 471
 472 ;;;;
 473 ;;;;
 474 ;;;; Additional Common Lisp Functions for Xlisp 2.0
 475 ;;;; From the init.lsp file supplied in the Xlisp distribution
 476 ;;;;
 477 ;;;;
 478
 479 (export '(set-macro-character get-macro-character))
 480
 481 ; (set-macro-character ch fun [ tflag [ rtab ] ])
 482 (defun set-macro-character (ch fun &optional tflag (rtab *readtable*))
 483     (setf (aref rtab (char-int ch))
 484           (cons (if tflag :tmacro :nmacro) fun))
 485     t)
 486
 487 ; (get-macro-character ch [ rtab ])
 488 (defun get-macro-character (ch &optional (rtab *readtable*))
 489   (if (consp (aref rtab (char-int ch)))
 490     (cdr (aref *readtable* (char-int ch)))
 491     nil))
 492
 493 ;;;;
 494 ;;;;
 495 ;;;; Additional Readtable Functions
 496 ;;;;
 497 ;;;;
 498 ;;**** need to be fixed once proper readtables are available
 499
 500 (export '(copy-readtable readtablep set-syntax-from-char))
 501
 502 (defconstant *common-lisp-readtable* (copy-array *readtable*))
 503
 504 (defun copy-readtable (&optional (rt *readtable*) (dest (make-array 256)))
 505   (let ((source (if rt rt *common-lisp-readtable*)))
 506     (replace dest source)))
 507
 508 (defun readtablep (rt) (and (vectorp rt) (= (length rt) 256)))
 509
 510 (defun set-syntax-from-char (to from &optional (dest *readtable*) src)
 511   (let ((source (if src src *common-lisp-readtable*)))
 512     (setf (aref dest (char-int to)) (aref source (char-int from)))
 513     t))
 514
 515
 516 ;;;;
 517 ;;;;
 518 ;;;; Additional System Functions for Xlisp 2.0
 519 ;;;; From the init.lsp file supplied in the Xlisp distribution
 520 ;;;;
 521 ;;;;
 522
 523 (export '(savefun debug nodebug))
 524
 525 ; (savefun fun) - save a function definition to a file
 526 (defmacro savefun (fun)
 527   `(let* ((fname (concatenate 'string (symbol-name ',fun) ".lsp"))
 528           (fval (function-lambda-expression (symbol-function ',fun)))
 529           (fp (open fname :direction :output)))
 530      (cond (fp (print (cons (if (eq (car fval) 'lambda)
 531                                 'defun
 532                                 'defmacro)
 533                             (cons ',fun (cdr fval))) fp)
 534                (close fp)
 535                fname)
 536            (t nil))))
 537
 538 ; (debug) - enable debug breaks
 539 (defun debug ()
 540   (setq *breakenable* t))
 541
 542 ; (nodebug) - disable debug breaks
 543 (defun nodebug ()
 544   (setq *breakenable* nil))
 545
 546
 547 ;;;;;
 548 ;;;;; Symbol and Package Functions
 549 ;;;;;
 550
 551 (export '(defpackage do-symbols do-external-symbols do-all-symbols
 552           apropos apropos-list))
 553
 554 (defmacro do-symbol-arrays (s res a body)
 555   (let ((arraysym (gensym))
 556         (isym (gensym))
 557         (asym (gensym))
 558         (listsym (gensym)))
 559     `(let ((,arraysym ,a)
 560            (,isym 0)
 561            (,asym nil)
 562            (,listsym nil)
 563            (,s nil))
 564        (block nil
 565          (tagbody
 566           new-array
 567           (when (null ,arraysym)
 568                 (setf ,s nil)
 569                 (return ,res))
 570           (setf ,asym (first ,arraysym) ,arraysym (rest ,arraysym) ,isym -1)
 571           new-list
 572           (setf ,isym (1+ ,isym))
 573           (if (<= 199 ,isym) (go new-array))
 574           (setf ,listsym (aref ,asym ,isym))
 575           new-item
 576           (if (null ,listsym) (go new-list))
 577           (setf ,s (first ,listsym) ,listsym (rest ,listsym))
 578           (tagbody ,@body)
 579           (go new-item))))))
 580
 581 (defmacro do-symbols (spr &rest body)
 582   (let ((packsym (gensym))
 583         (usessym (gensym))
 584         (arraysym (gensym)))
 585     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
 586             (,usessym (package-use-list ,packsym))
 587             (,arraysym (cons (package-obarray ,packsym nil)
 588                              (mapcar #'package-obarray
 589                                      (cons ,packsym ,usessym)))))
 590        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
 591
 592 (defmacro do-external-symbols (spr &rest body)
 593   (let ((packsym (gensym))
 594         (arraysym (gensym)))
 595     `(let* ((,packsym ,(if (second spr) (second spr) '*package*))
 596             (,arraysym (list (package-obarray ,packsym))))
 597        (do-symbol-arrays ,(first spr) ,(third spr) ,arraysym ,body))))
 598
 599 (defmacro do-all-symbols (sr &rest body)
 600   (let ((packsym (gensym))
 601         (arraysym (gensym)))
 602     `(let* ((,packsym (list-all-packages))
 603             (,arraysym nil))
 604        (dolist (p ,packsym)
 605          (push (package-obarray p) ,arraysym)
 606          (push (package-obarray p nil) ,arraysym))
 607        (do-symbol-arrays ,(first sr) ,(second sr) ,arraysym ,body))))
 608
 609 #|
 610 ;;**** this overflows in compilation
 611 (defmacro defpackage (pname &rest options)
 612   `(eval-when (:compile-toplevel :load-toplevel :execute)
 613      (let* ((pname ',pname)
 614             (options ',options)
 615             (pack (find-package ',pname))
 616             (nicknames nil))
 617        (dolist (opt options)
 618          (if (eq (first opt) :nicknames)
 619              (setf nicknames (append (rest opt) nicknames))))
 620        (if pack
 621            (rename-package pack
 622                            pname
 623                            (mapcar #'string
 624                                    (append nicknames
 625                                            (package-nicknames pack))))
 626            (setf pack (make-package pname :nicknames
 627                                     (mapcar #'string nicknames))))
 628        (dolist (opt options)
 629          (case (first opt)
 630            (:shadow (shadow (mapcar #'string (rest opt)) pack))
 631            (:shadowing-import-from
 632             (let ((from-pack (find-package (second opt))))
 633               (dolist (sname (rest (rest opt)))
 634                 (multiple-value-bind (sym found)
 635                                      (find-symbol (string sname) from-pack)
 636                   (if found
 637                       (shadowing-import sym pack)
 638                       (error "no symbol named ~s in package ~s"
 639                              (string sname)
 640                              from-pack))))))))
 641        (dolist (opt options)
 642          (if (eq (first opt) :use)
 643              (use-package (mapcar #'string (rest opt)) pack)))
 644        (dolist (opt options)
 645          (case (first opt)
 646            (:intern
 647             (dolist (sname (rest opt)) (intern (string sname) pack)))
 648            (:import-from
 649             (let ((from-pack (find-package (second opt))))
 650               (dolist (sname (rest (rest opt)))
 651                 (multiple-value-bind (sym found)
 652                                      (find-symbol (string sname) from-pack)
 653                   (if found
 654                       (import sym pack)
 655                       (error "no symbol named ~s in package ~s"
 656                              (string sname)
 657                              from-pack))))))))
 658        (dolist (opt options)
 659          (if (eq (first opt) :export)
 660              (dolist (sname (rest opt))
 661                (export (intern (string sname) pack) pack))))
 662        pack)))
 663 |#
 664 (defmacro defpackage (pname &rest options)
 665   `(eval-when (:compile-toplevel :load-toplevel :execute)
 666               (do-defpackage ',pname ',options)))
 667
 668 (defun do-defpackage (pname options)
 669   (let ((pack (find-package pname))
 670         (nicknames nil))
 671     (dolist (opt options)
 672       (if (eq (first opt) :nicknames)
 673           (setf nicknames (append (rest opt) nicknames))))
 674     (if pack
 675         (rename-package pack
 676                         pname
 677                         (remove-duplicates
 678                          (mapcar #'string
 679                                  (append nicknames (package-nicknames pack)))
 680                          :test #'string=))
 681         (setf pack (make-package pname :nicknames
 682                                  (remove-duplicates
 683                                   (mapcar #'string nicknames)
 684                                   :test #'string=))))
 685     (dolist (opt options)
 686       (case (first opt)
 687         (:shadow (shadow (mapcar #'string (rest opt)) pack))
 688         (:shadowing-import-from
 689          (let ((from-pack (find-package (second opt))))
 690            (dolist (sname (rest (rest opt)))
 691              (multiple-value-bind (sym found)
 692                                   (find-symbol (string sname) from-pack)
 693                (if found
 694                    (shadowing-import sym pack)
 695                    (error "no symbol named ~s in package ~s"
 696                           (string sname)
 697                           from-pack))))))))
 698     (dolist (opt options)
 699       (if (eq (first opt) :use)
 700           (use-package (mapcar #'string (rest opt)) pack)))
 701     (dolist (opt options)
 702       (case (first opt)
 703         (:intern
 704          (dolist (sname (rest opt)) (intern (string sname) pack)))
 705         (:import-from
 706          (let ((from-pack (find-package (second opt))))
 707            (dolist (sname (rest (rest opt)))
 708              (multiple-value-bind (sym found)
 709                                   (find-symbol (string sname) from-pack)
 710                (if found
 711                    (import sym pack)
 712                    (error "no symbol named ~s in package ~s"
 713                           (string sname)
 714                           from-pack))))))))
 715     (dolist (opt options)
 716       (if (eq (first opt) :export)
 717           (dolist (sname (rest opt))
 718                   (export (intern (string sname) pack) pack))))
 719     pack))
 720
 721 (defun apropos (x &optional package)
 722   (if package
 723       (do-symbols (s package)
 724         (if (string-search x s) (format t "~s~%" s)))
 725       (do-all-symbols (s)
 726         (if (string-search x s) (format t "~s~%" s))))
 727   (values))
 728
 729 (defun apropos-list (x &optional package)
 730   (let ((res nil))
 731     (if package
 732         (do-symbols (s package res)
 733           (if (string-search x s) (push s res)))
 734         (do-all-symbols (s res)
 735           (if (string-search x s) (push s res))))))
 736
 737
 738 ;;;;;
 739 ;;;;; Additional Multiple Value Functions and Macros
 740 ;;;;;
 741
 742 (export
 743  '(values-list multiple-value-list multiple-value-bind multiple-value-setq))
 744
 745 (defun values-list (x) (apply #'values x))
 746
 747 (defmacro multiple-value-list (form)
 748   `(multiple-value-call #'list ,form))
 749
 750 (defmacro multiple-value-bind (vars form &rest body)
 751   (let ((rsym (gensym)))
 752     `(multiple-value-call #'(lambda (&optional ,@vars &rest ,rsym)
 753                               (declare (ignore ,rsym))
 754                               ,@body)
 755                         ,form)))
 756
 757 (defmacro multiple-value-setq (variables form)
 758   (let* ((tvars (mapcar #'(lambda (x) (gensym "V")) variables))
 759          (pairs nil))
 760     (mapc #'(lambda (x y) (push y pairs) (push x pairs)) variables tvars)
 761     (if (null tvars) (push (gensym) tvars))
 762     `(multiple-value-bind ,tvars ,form (setq ,@pairs) ,(first tvars))))
 763
 764
 765 ;;;;
 766 ;;;; Fixup some functions
 767 ;;;;
 768
 769 (if (find-symbol "SAVE") (unexport 'save))
 770 (if (find-symbol "RESTORE") (unexport 'restore))
 771
 772 (export '(save-workspace add-exit-function))
 773
 774 (defun save-workspace (name)
 775   (loop
 776    (unless (consp system::*exit-functions*) (return))
 777    (let ((func (pop system::*exit-functions*)))
 778      (ignore-errors (funcall func))))
 779   (dolist (h (copy-list *hardware-objects*))
 780     (send (third h) :remove))
 781   (save name)
 782   (exit))
 783
 784 (defun add-exit-function (fun)
 785   (push fun system::*exit-functions*))
 786
 787
 788 ;;;;
 789 ;;;; DECLARE and PROCLAIM
 790 ;;;;
 791
 792 (export '(declare proclaim special))
 793
 794 (defmacro declare (&rest args)
 795   (if *displace-macros*
 796       (dolist (a args)
 797         (if (eq (first a) 'special)
 798             (return (warn "special declarations are not supported"))))))
 799
 800 (defun proclaim (decl)
 801   (if (eq (first decl) 'special)
 802       (dolist (s (rest decl))
 803         (mark-as-special s))))
 804
 805 ;;;;
 806 ;;;; More printing stuff
 807 ;;;;
 808
 809 (export '(write write-string write-line finish-output clear-output
 810           *print-pretty* *print-circle* *print-radix* *print-base*
 811           *print-array* *read-base*
 812           write-to-string prin1-to-string princ-to-string))
 813
 814 (defparameter *print-pretty* nil)
 815 (defparameter *print-circle* nil)
 816 (defparameter *print-radix* nil)
 817 (defparameter *print-base* 10.)
 818 (defparameter *print-array* t)
 819
 820 (defparameter *read-base* 10.)
 821
 822 (defun write (x &key
 823                 ((:escape *print-escape*) *print-escape*)
 824                 ((:gensym *print-gensym*) *print-gensym*)
 825                 ((:readably *print-readably*) *print-readably*)
 826                 ((:length *print-length*) *print-length*)
 827                 ((:level *print-level*) *print-level*)
 828                 ((:case *print-case*) *print-case*)
 829                 ((:circle *print-circle*) *print-circle*)
 830                 ((:radix *print-radix*) *print-radix*)
 831                 ((:base *print-base*) *print-base*)
 832                 ((:array *print-array*) *print-array*)
 833                 ((:pretty *print-pretty*) *print-pretty*)
 834                 (stream *standard-output*))
 835   (format stream (if *print-escape* "~s" "~a") x)
 836   x)
 837
 838 (defun write-string (string &optional (stream *standard-output*)
 839                             &key (start 0) end)
 840   (format stream "~a" (subseq string start end))
 841   string)
 842
 843 (defun write-line (string &optional (stream *standard-output*)
 844                             &key (start 0) end)
 845   (format stream "~a~%" (subseq string start end))
 846   string)
 847
 848 (defun finish-output (&optional (s *standard-output*)) (force-output s))
 849
 850 (defun clear-output (&optional (s *standard-output*)) (force-output s))
 851
 852 (defun write-to-string (x &rest args)
 853   (with-output-to-string (s) (apply #'write x :stream s args)))
 854
 855 (defun prin1-to-string (arg) (format nil "~s" arg))
 856 (defun princ-to-string (arg) (format nil "~a" arg))
 857
 858
 859 ;;;;
 860 ;;;; Miscellaneous
 861 ;;;;
 862
 863 (export '(keywordp schar nreconc))
 864
 865 (defsetf char (x i) (v) `(setf (aref ,x ,i) ,v))
 866
 867 (defun keywordp (x)
 868   (and (symbolp x) (eq (symbol-package x) (find-package "KEYWORD"))))
 869
 870 (setf (symbol-function 'schar) #'char)
 871
 872 (defun nreconc (x y) (nconc (nreverse x) y))
 873
 874
 875 (export '(describe svref lambda-list-keywords get-properties))
 876
 877 (defun describe (x &optional (stream t))
 878   (format stream "~&~s - ~a~%" x (type-of x)))
 879
 880 (setf (symbol-function 'svref) #'aref)
 881
 882 (defconstant lambda-list-keywords
 883   '(&optional &rest &key &allow-other-keys &aux &whole &environment &body))
 884
 885 (defun get-properties (place ilist)
 886   (let ((dflt (cons nil nil)))
 887     (dolist (i ilist (values nil nil nil))
 888       (let ((v (getf place i)))
 889         (unless (eq v dflt) (return (values i v t)))))))
 890
 891 (export '(parse-integer compiled-function-p packagep gentemp bit-vector-p))
 892
 893 (defun parse-integer (s &key (start 0) end radix junk-allowed)
 894   (read-from-string (subseq s start end)))
 895
 896 ;**** need to rule out macros
 897 (defun compiled-function-p (f)
 898   (typep f '(or subr byte-code-closure)))
 899
 900 (defun packagep (x) (typep x 'package))
 901
 902 (defvar *gentemp-counter* -1)
 903
 904 (defun gentemp (&optional (prefix "T") (package *package*))
 905   (loop
 906    (incf *gentemp-counter*)
 907    (let ((name (format nil "~a~d" prefix *gentemp-counter*)))
 908      (unless (find-symbol name package) (return (intern name package))))))
 909
 910 (defun bit-vector-p (x) nil)
 911
 912 ;;;;
 913 ;;;; DESTRUCTURING-BIND
 914 ;;;; Simple implementation that only allows destructuring required arguents.
 915 ;;;; Nothing is done with declarations at this point.
 916 ;;;;
 917
 918 (export 'destructuring-bind)
 919
 920 ;;**** This can probably be made more efficient with little extra work.
 921 ;;**** If the compiler optimizes out the apply calls, this work may
 922 ;;**** not be worth it. Very complex code could produce deep recursions,
 923 ;;**** but most of the time there are only one or two destructuring arguments.
 924 #|
 925 (defun do-destructure (ll al body)
 926   (cond
 927    ((null ll) `(progn (destructure-check-arg ,al t) ,@body))
 928    ((and (eq (first ll) '&rest) (null (rest (rest ll))))
 929     `(let ((,(second ll) ,al)) ,@body))
 930    ((member (first ll) lambda-list-keywords)
 931     `(apply #'(lambda ,ll ,@body) ,al))
 932    ((consp (first ll))
 933     (let ((als (gensym)))
 934       `(let ((,als ,al))
 935          (destructuring-bind ,(first ll) (first ,als)
 936                              ,(do-destructure (rest ll) `(rest ,als) body)))))
 937    ((and (symbolp (first ll)) (not (null (first ll))))
 938     (let ((als (gensym)))
 939       `(let* ((,als (destructure-check-arg ,al nil))
 940               (,(first ll) (first ,als)))
 941          ,(do-destructure (rest ll) `(rest ,als) body))))
 942    (t (error "bad formal argument list"))))
 943 |#
 944
 945 (defun destructuring-arglist-p (x)
 946   (consp
 947    (find-if #'(lambda (x) (or (member x lambda-list-keywords) (consp x))) x)))
 948
 949 (defun do-destructure (ll al body)
 950   (let* ((args (destructure-fix-arglist ll))
 951          (farg (first args)))
 952     (cond
 953      ((null args) `(progn (destructure-check-arg ,al t) ,@body))
 954      ((not (destructuring-arglist-p args))
 955       `(apply #'(lambda ,args ,@body) ,al))
 956      ((consp farg)
 957       (let ((asym (gensym)))
 958         `(let ((,asym ,al))
 959            ,(do-destructure farg
 960                             `(first ,asym)
 961                             (list (do-destructure (rest args)
 962                                                   `(rest ,asym)
 963                                                   body))))))
 964      ((and (symbolp farg) (not (null farg)))
 965       (let ((asym (gensym)))
 966         `(let* ((,asym ,al)
 967                 (,farg (progn (destructure-check-arg ,asym nil)
 968                               (first ,asym))))
 969            ,(do-destructure (rest args) `(rest ,asym) body))))
 970      (t (error "bad formal argument list")))))
 971
 972 (defun destructure-check-arg (x toomany)
 973   (if toomany
 974       (unless (null x) (error "too many arguments"))
 975       (unless (consp x) (error "too few arguments")))
 976   x)
 977
 978 (defun destructure-fix-arglist (ll)
 979   (setf ll (copy-list ll))
 980   (let ((last (last ll)))
 981     (unless (null (cdr last))
 982             (rplacd last (list '&rest (cdr last)))))
 983   (let ((p (position '&body ll)))
 984     (if p (setf (nth p ll) '&rest)))
 985   ll)
 986
 987 (defmacro destructuring-bind (args vals &rest body)
 988   (do-destructure (destructure-fix-arglist args) vals body))
 989
 990 (defmacro destructuring-bind (args vals &rest body)
 991   (do-destructure args vals body))
 992
 993
 994 ;;;;
 995 ;;;; SPECIAL-FORM-P
 996 ;;;;
 997
 998 (export '(special-form-p))
 999
1000 (defun special-form-p (x)
1001   (and (symbolp x) (fboundp x) (typep (symbol-function x) 'fsubr)))
1002
1003
1004 ;;;;
1005 ;;;; COMPLEMENT
1006 ;;;;
1007
1008 (export 'complement)
1009
1010 (defun complement (f) #'(lambda (&rest args) (not (apply f args))))
1011
1012
1013 ;;;
1014 ;;; COPY-STRUCTURE and COPY-SYMBOL
1015 ;;;
1016
1017 (export '(copy-structure copy-symbol))
1018
1019 (defun copy-structure (struct) (xlisp::%copy-struct struct))
1020
1021 (defun copy-symbol (sym &optional props)
1022   (let ((newsym (make-symbol (copy-seq (symbol-name sym)))))
1023     (when props
1024           (when (boundp sym)
1025                 (setf (symbol-value newsym) (symbol-value sym)))
1026           (when (fboundp sym)
1027                 (setf (symbol-function newsym) (symbol-function sym)))
1028           (setf (symbol-plist newsym) (copy-list (symbol-plist sym))))
1029     newsym))
1030
1031
1032 ;;;;
1033 ;;;; TAILP and LDIFF
1034 ;;;;
1035 ;;;; Definitions taken from HyperSpec.
1036
1037 (export '(tailp ldiff))
1038
1039 (defun tailp (object list)
1040   (do ((list list (cdr list)))
1041       ((atom list) (eql list object))
1042       (if (eql object list)
1043           (return t))))
1044
1045 (defun ldiff (list object)
1046   (do ((list list (cdr list))
1047        (r '() (cons (car list) r)))
1048       ((atom list)
1049        (if (eql list object) (nreverse r) (nreconc r list)))
1050       (when (eql object list)
1051             (return (nreverse r)))))
1052
1053 ;;;;
1054 ;;;; MEMBER-IF
1055 ;;;;
1056
1057 (export 'member-if)
1058
1059 (defun member-if (pred list &key key)
1060   (loop
1061    (when (null list) (return nil))
1062    (when (funcall pred (if key (funcall key (car list)) (car list)))
1063          (return list))
1064    (pop list)))
1065
1066 ;;;;
1067 ;;;; ISQRT
1068 ;;;;
1069
1070 (export 'isqrt)
1071
1072 ;;**** ckeck this; look into vectorization
1073 (defun isqrt (x)
1074   (if (and (typep x 'integer) (not (minusp x)))
1075       (do* ((est (ash 1 (truncate (integer-length x) 2))
1076                  (truncate (+ est est2) 2))
1077             (est2 (truncate x est) (truncate x est)))
1078            ((> 2 (abs (- est est2))) (min est est2)))
1079     (floor (sqrt x))))