home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / COMMON2.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  18KB  |  526 lines
  1. ; Fill in "missing" Common Lisp definitions
  2. ; However, those that concern features of Common Lisp not implemented in
  3. ; XLISP (such as the compiler, arrays, bignums...) are not implemented here.
  4. ; Unlike functions in COMMON.LSP, these are not documented in the manual.
  5.  
  6. ; You might want to only include those functions your application needs.
  7.  
  8. ; Tom Almy, 7/93
  9.  
  10. #-:common (load "common")  ; We need these always!
  11.  
  12. (in-package "XLISP")
  13.  
  14. (export '(char-code-limit array-in-bounds-p assert assoc-if assoc-if-not
  15.           ccase char-name character check-type copy-seq copy-symbol
  16.       ctypecase delete-duplicates ecase etypecase fifth sixth
  17.       seventh eighth ninth tenth float-sign hash-table-p isqrt
  18.       keywordp packagep ldiff make-list make-string make-sequence
  19.       member-if member-if-not merge mismatch nbutlast nreconc
  20.       prin1-to-string princ-to-string probe-file rassoc
  21.       rassoc-if rassoc-if-not read-from-string realp
  22.       revappend tailp typecase sleep with-open-stream
  23.       byte byte-size byte-position ldb ldb-test mask-field
  24.       dpb deposit-field))
  25.  
  26. (defconstant char-code-limit 127)
  27.  
  28. ;; Byte functions Added by Tom Almy, 4/95
  29.  
  30. ;; "alias" these to common list functions
  31. (setf (symbol-function 'byte) (symbol-function 'cons))
  32. (setf (symbol-function 'byte-size) (symbol-function 'car))
  33. (setf (symbol-function 'byte-position) (symbol-function 'cdr))
  34.  
  35. (defmacro bytetest (x)
  36.        `(unless (and
  37.          (consp ,x)
  38.          (typep (byte-size ,x) 'fixnum)
  39.          (typep (byte-position ,x) 'fixnum)
  40.          (>= (byte-size ,x) 0)
  41.          (>= (byte-position ,x) 0))
  42.         (error "arguments must be non-negative fixnums")))
  43.  
  44. (defun ldb (byte x)
  45.        (bytetest byte)
  46.        (logand (ash x (- (byte-position byte)))
  47.            (lognot (ash -1 (byte-size byte)))))
  48. (defun ldb-test (byte x)
  49.        (bytetest byte)
  50.        (not (zerop (ldb byte x))))
  51. (defun mask-field (byte x)
  52.        (bytetest byte)
  53.        (logand (ash (lognot (ash -1 (byte-size byte))) (byte-position byte))
  54.            x))
  55. (defun dpb (new byte x)
  56.        (bytetest byte)
  57.        (let ((mask (lognot (ash -1 (byte-size byte)))))
  58.         (logior (logand x
  59.                 (lognot (ash mask (byte-position byte))))
  60.             (ash (logand new mask) (byte-position byte)))))
  61. (defun deposit-field (new byte x)
  62.        (bytetest byte)
  63.        (logxor x
  64.            (logand (ash (lognot (ash -1 (byte-size byte)))
  65.                 (byte-position byte))
  66.                (logxor x new))))
  67.  
  68.  
  69. (defsetf ldb (byte x) (new)
  70.      (let ((nbyte (gensym)) (nnew (gensym)))
  71.           (if (and (consp x) (some #'consp x))
  72.           (let ((retval (|DoForm| x)))
  73.                `(let ((,nbyte ,byte) ,@(car retval) (,nnew ,new))
  74.                  (setf ,(cdr retval)
  75.                    (dpb ,nnew ,nbyte ,(cdr retval)))
  76.                  ,nnew))
  77.           `(let ((,nbyte ,byte)(,nnew ,new))
  78.             (setf ,x (dpb ,nnew ,nbyte ,x)) ,nnew))))
  79.  
  80.  
  81.  
  82. (defsetf mask-field (byte x) (new)
  83.      (let ((nbyte (gensym)) (nnew (gensym)))
  84.           (if (and (consp x) (some #'consp x))
  85.           (let ((retval (|DoForm| x)))
  86.                `(let ((,nbyte ,byte) ,@(car retval) (,nnew ,new))
  87.                  (setf ,(cdr retval)
  88.                    (deposit-field ,nnew ,nbyte ,(cdr retval)))
  89.                  ,nnew))
  90.           `(let ((,nbyte ,byte)(,nnew ,new))
  91.             (setf ,x (deposit-field ,nnew ,nbyte ,x)) ,nnew))))
  92.  
  93. ; Simplistic versions, probably goodenuf, the problem is that they
  94. ; do multiple evaluations
  95. ; (defsetf ldb (byte x) (new)
  96. ;     `(progn (setf ,x (dpb ,new ,byte ,x)) ,new))
  97. ;(defsetf mask-field (byte x) (new)
  98. ;     `(progn (setf ,x (deposit-field ,new ,byte ,x)) , new))
  99.  
  100. ;; Apropos function contributed by Jan Kok, kok@cs.ColoState.edu
  101.  
  102. #-:packages
  103. (defun apropos-list (string)
  104.        (let ((str (string string)) ; convert to string, if symbol is passed
  105.          (result nil))
  106.         (dotimes (i (length *obarray*) result)
  107.              (dolist (sym (elt *obarray* i))
  108.                  (if (search str (string sym) :test #'char-equal)
  109.                  (push sym result))))))
  110. #-:packages
  111. (defun apropos (string) 
  112.        (mapcar #'(lambda (x)
  113.              (format t "~&~s" x)
  114.              (when (fboundp x) (princ " (defined)"))
  115.              (when (boundp x) (format t " value: ~s" x)))
  116.            (apropos-list string))
  117. #+:mulvals   (values)
  118. #-:mulvals   nil ; CL says return "nothing" but we need to return NIL
  119. )
  120.  
  121. (defun array-in-bounds-p (a n) (and (>= n 0 (< n (length a)))))
  122.  
  123. (defmacro assert (test &optional forms &rest x &aux (loop (gensym)))
  124.       `(prog ((*print-length* 4) (*print-level* 4))
  125.          ,loop
  126.          (when ,test (return nil))
  127.          (cerror "requests new values for ~*~s"
  128.              "~a"             
  129.              ,(if (null x) "" `(format nil ,@x))
  130.              ',forms)
  131.          ,@(mapcan #'(lambda (i)
  132.                      `((format t "Enter new value for ~s:" ',i)
  133.                        (setf ,i (read))))
  134.                forms)
  135.          (go ,loop)))
  136.  
  137. (defun assoc-if (test form &key (key #'identity))
  138.        (do ()
  139.        ((endp form) nil)
  140.        (when (and (consp (car form))
  141.               (funcall test (funcall key (caar form))))
  142.          (return (car form)))
  143.        (setq form (cdr form))))
  144.  
  145. (defun assoc-if-not (test form &key (key #'identity))
  146.        (do ()
  147.        ((endp form) nil)
  148.        (when (and (consp (car form))
  149.               (not (funcall test (funcall key (caar form)))))
  150.          (return (car form)))
  151.        (setq form (cdr form))))
  152.  
  153. (defmacro ccase (keyform &rest x)
  154.       (let ((val (gensym))
  155.         (loop (gensym))
  156.         (values (mapcan #'(lambda (x)
  157.                       (if (listp (car x))
  158.                           (copy-list (car x))
  159.                           (list (car x))))
  160.                 x)))
  161.            `(prog (,val) ,loop
  162.               (setf ,val ,keyform)
  163.               (return 
  164.                (case ,val
  165.                  ,@x
  166.                  (t (cerror
  167.                  "requests new value for ~s"
  168.                  "~*~s fell through ccase expression, wanted one of ~s"
  169.                  ',keyform
  170.                  ,val
  171.                  ',values)
  172.                 (format t "New value:")
  173.                 (setf ,keyform (read))
  174.                 (go ,loop)))))))
  175.                         
  176. (defun char-name (c)
  177.        (case c
  178.          (#\Space   "Space")
  179.          (#\Newline "Newline")
  180.          (#\Rubout  "Rubout")))
  181.  
  182. (defun character (arg) (coerce arg 'character))
  183.  
  184. (defmacro check-type (place type 
  185.                 &optional (string `',type) 
  186.                 &aux (loop (gensym)))
  187.        `(prog () ,loop
  188.           (when (typep ,place ',type) (return))
  189.           (cerror "requests new value for ~s"
  190.               "the value of ~s is ~s which is not of type ~a"
  191.               ',place
  192.               ,place
  193.               ,string)
  194.           (format t "New value:")
  195.           (setf ,place (read))
  196.           (go ,loop)))
  197.           
  198.  
  199. (defun copy-seq (seq) (subseq seq 0))
  200.  
  201. (defun copy-symbol (sym &optional all)
  202.        (unless (symbolp sym) (error "~s is not a symbol" sym))
  203.        (let ((x (make-symbol (symbol-name sym))))
  204.         (when all
  205.           (when (boundp sym) (setf (symbol-value x) sym))
  206.           (when (fboundp sym) 
  207.             (setf (symbol-function x) (symbol-function sym)))
  208.           (setf (symbol-plist x) (symbol-plist sym)))
  209.         x))
  210.  
  211. (defmacro ctypecase (keyform &rest x)
  212.       (let ((val (gensym))
  213.         (loop (gensym))
  214.         (values (mapcan #'(lambda (x)
  215.                       (if (listp (car x))
  216.                           (list (copy-list (car x)))
  217.                           (list (car x))))
  218.                 x)))
  219.            `(prog (,val) ,loop
  220.               (setq ,val ,keyform)
  221.               (return 
  222.                (typecase ,val
  223.                  ,@x
  224.                  (otherwise (cerror
  225.                  "requests new value for ~s"
  226.                  "~*~s fell through ctypecase expression, wanted one of ~s"
  227.                  ',keyform
  228.                  ,val
  229.                  ',values)
  230.                 (format t "New value:")
  231.                 (setf ,keyform (read))
  232.                 (go ,loop)))))))
  233.                         
  234. (setf (symbol-function 'delete-duplicates)      ; cheat on this one
  235.       (symbol-function 'remove-duplicates))
  236.  
  237. #-:packages
  238. (defmacro do-all-symbols (arglist &rest body)
  239.       (when (not (consp arglist)) (error "Bad first argument"))
  240.       `(dolist ( ,(first arglist)
  241.              ',(mapcan #'copy-list (coerce *obarray* 'list))
  242.              ,@(rest arglist))
  243.            ,@body))
  244.  
  245. (defmacro ecase (keyform &rest x)
  246.       (let ((tmp (gensym))
  247.         (values (mapcan #'(lambda (x)
  248.                       (if (listp (car x))
  249.                           (copy-list (car x))
  250.                           (list (car x))))
  251.                 x)))
  252.            `(let ((,tmp ,keyform))
  253.              (case ,tmp ,@x 
  254.                (t (error "case ~s not one of ~s" ,tmp ',values))))))
  255.  
  256. (defmacro etypecase (keyform &rest x)
  257.       (let ((tmp (gensym))
  258.         (values (mapcan #'(lambda (x)
  259.                       (if (listp (car x))
  260.                           (list (copy-list (car x)))
  261.                           (list (car x))))
  262.                 x)))
  263.            `(let ((,tmp ,keyform))
  264.              (typecase ,tmp ,@x 
  265.                (otherwise (error "type of ~s not one of ~s" ,tmp ',values))))))
  266.  
  267. ;; These are terribly inefficient (see the awful defsetf code in common.lsp)
  268. (defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))  ; same as "car"
  269. (defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))   ; same as "cdr"
  270.  
  271. (defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  272. (defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  273. (defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  274. (defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
  275. (defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
  276. (defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
  277. (defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
  278. (defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
  279. (defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))
  280.  
  281. (defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  282. (defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
  283. (defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
  284. (defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
  285. (defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
  286. (defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
  287. (defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
  288. (defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  289. (defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
  290. (defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
  291. (defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
  292. (defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
  293. (defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
  294. (defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
  295. (defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
  296. (defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
  297. (defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
  298. (defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
  299. (defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
  300. (defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  301. (defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
  302. (defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
  303. (defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
  304. (defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
  305. (defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
  306. (defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
  307. (defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
  308. (defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))
  309.  
  310. (defun fifth (x) (nth 4 x))
  311. (defun sixth (x) (nth 5 x))
  312. (defun seventh (x) (nth 6 x))
  313. (defun eighth (x) (nth 7 x))
  314. (defun ninth (x) (nth 8 x))
  315. (defun tenth (x) (nth 9 x))
  316.  
  317. (defun float-sign (x &optional (y 1.0))
  318.        (if (minusp x) (- (abs y))
  319.        (abs y)))
  320.  
  321. (defun hash-table-p (x) (typep x 'hash-table))
  322.  
  323. #-:bignums (defun isqrt (x) (floor (sqrt x)))
  324.  
  325. #+:bignums
  326. (defun isqrt (x)
  327.        (if (and (typep x 'integer) (not (minusp x)))
  328.        (do* ((est (ash 1 (truncate (integer-length x) 2))
  329.               (truncate (+ est est2) 2))
  330.          (est2 (truncate x est) (truncate x est)))
  331.         ((> 2 (abs (- est est2))) (min est est2)))
  332.        (floor (sqrt x))))
  333.           
  334.  
  335. #+:packages
  336. (defun keywordp (x) (eq (symbol-package x) (find-package "KEYWORD")))
  337. #-:packages
  338. (defun keywordp (x) 
  339.        (and (symbolp x) (eq #\: (aref (symbol-name x) 0))))
  340.  
  341. #+:packages
  342. (defun packagep (x) (typep x 'package))
  343.  
  344. (defun ldiff (l m)
  345.        (do ((list l (cdr list)))
  346.        ((endp list) (copy-list l))
  347.        (when (eq m list) (return (butlast l (length list))))))
  348.  
  349. ; This won't make really big lists in MS-DOS environments
  350. (defun make-list (n &key initial-element &aux val)
  351.        (coerce (make-array n :initial-element initial-element) 'list))
  352.  
  353. ; This will make bigger lists, but is about 5x slower
  354. ;(defun make-list (n &key initial-element &aux val)
  355. ;       (dotimes (i n val) (push initial-element val)))
  356.  
  357. ; These won't make really big strings/sequences in MS-DOS environments, but
  358. ;  I'm not giving an alternative!
  359. (defun make-string (n &key (initial-element #\space))
  360.        (coerce (make-array n :initial-element initial-element) 'string))
  361.  
  362. (defun make-sequence (type n 
  363.                &key (initial-element
  364.                  (if (eq type 'string) #\space nil)))
  365.        (coerce (make-array n :initial-element initial-element) type))
  366.  
  367. (defun member-if (test form &key (key #'identity))
  368.        (do ()
  369.        ((endp form) nil)
  370.        (when (funcall test (funcall key (car form))) (return form))
  371.        (setq form (cdr form))))
  372.  
  373. (defun member-if-not (test form &key (key #'identity))
  374.        (do ()
  375.        ((endp form) nil)
  376.        (unless (funcall test (funcall key (car form))) (return form))
  377.        (setq form (cdr form))))
  378.  
  379. (defun merge (type s1 s2 pred &key (key #'identity))
  380.        (let* ((i1 0)
  381.           (i2 0)
  382.           (i3 0)
  383.           (l1 (length s1))
  384.           (l2 (length s2))
  385.           (l3 (+ l1 l2))
  386.           (res (make-sequence type l3)))
  387.          (loop
  388.           (when (eql i3 l3) (return res))
  389.           (setf (elt res i3)
  390.             (cond
  391.              ((eql i1 l1)
  392.               (prog1 (elt s2 i2) (incf i2)))
  393.              ((eql i2 l2)
  394.               (prog1 (elt s1 i1) (incf i1)))
  395.              ((funcall pred 
  396.                    (funcall key (elt s1 i1)) 
  397.                    (funcall key (elt s2 i2)))
  398.               (prog1 (elt s1 i1) (incf i1)))
  399.              (t
  400.               (prog1 (elt s2 i2) (incf i2)))))
  401.           (incf i3))))
  402.  
  403. (defun mismatch (sequence1 sequence2
  404.             &key 
  405.             (key #'identity) 
  406.             test test-not 
  407.             (start1 0) end1
  408.             (start2 0) end2)
  409.        (when (null end1) (setq end1 (length sequence1)))
  410.        (when (null end2) (setq end2 (length sequence2)))
  411.        (when (and test test-not)
  412.          (error "cannot specify both :test and :test-not"))
  413.        (if test-not
  414.        (setq test test-not test-not #'not)
  415.        (progn (setq test-not #'identity)
  416.           (unless test (setq test #'eql))))
  417.        (do* ((s1 start1 (1+ s1))
  418.          (s2 start2 (1+ s2)))
  419.         ((or (>= s1 end1) (>= s2 end2))
  420.          (if (and (>= s1 end1) (>= s2 end2))
  421.          nil
  422.          s1))
  423.         (unless (funcall test-not 
  424.                  (funcall test 
  425.                       (funcall key (elt sequence1 s1))
  426.                       (funcall key (elt sequence2 s2))))
  427.             (return s1))))
  428.  
  429. ; There are numerous n* functions that I'm not implementing because
  430. ; They would be slower then the builtin, non-destructive equivalents.
  431.  
  432.  
  433. (defun nbutlast (list &optional (n 1) &aux (l (length list)))
  434.        (if (< n l)
  435.        (prog2 (setf (cdr (nthcdr (1- (- l n)) list)) nil) list)
  436.        nil))
  437.  
  438. (defun nreconc (l1 l2) (nconc (nreverse l1) l2))
  439.  
  440. (defun prin1-to-string (arg) (format nil "~s" arg))
  441. (defun princ-to-string (arg) (format nil "~a" arg))
  442.  
  443. (defun probe-file (arg) (open arg :direction :probe))
  444.  
  445. (defun rassoc (i form &key (key #'identity) test test-not)
  446.        (when (and test test-not)
  447.          (error "cannot specify both :test and :test-not"))
  448.        (if test-not
  449.        (do ()
  450.            ((endp form) nil)
  451.            (when (and (consp (car form))
  452.               (not (funcall test-not i (funcall key (cdar form)))))
  453.              (return (car form)))
  454.            (setq form (cdr form)))
  455.        (progn (unless test (setq test #'eql))
  456.           (do ()
  457.               ((endp form) nil)
  458.               (when (and (consp (car form))
  459.                  (funcall test i (funcall key (cdar form))))
  460.                 (return (car form)))
  461.               (setq form (cdr form))))))
  462.        
  463. (defun rassoc-if (test form &key (key #'identity))
  464.        (do ()
  465.        ((endp form) nil)
  466.        (when (and (consp (car form))
  467.               (funcall test (funcall key (cdar form))))
  468.          (return (car form)))
  469.        (setq form (cdr form))))
  470.  
  471. (defun rassoc-if-not (test form &key (key #'identity))
  472.        (do ()
  473.        ((endp form) nil)
  474.        (when (and (consp (car form))
  475.               (not (funcall test (funcall key (cdar form)))))
  476.          (return (car form)))
  477.        (setq form (cdr form))))
  478.  
  479. #+:mulvals
  480. (defun read-from-string (arg &optional (e1 t) e2 &key (start 0) end)
  481.        (let* ((r nil)
  482.           (s (with-input-from-string (f arg :start start :end end :index r)
  483.                      (read f e1 e2))))
  484.          (values s r)))
  485.         
  486. #-:mulvals  ; Doesn't return second value (index into arg where parse stopped)
  487. (defun read-from-string (arg &optional (e1 t) e2 &key (start 0) end)
  488.        (with-input-from-string (f arg :start start :end end)
  489.                    (read f e1 e2)))
  490.         
  491.  
  492. #+:bignums (defun realp (arg) (or (rationalp arg) (floatp arg)))
  493. #-:bignums (defun realp (arg) (or (integerp arg) (floatp arg)))
  494.  
  495. (defun revappend (x y) (nconc (reverse x) y))
  496.  
  497. (defun tailp (s l)
  498.        (do ()
  499.        ((endp l) nil)
  500.        (when (eq s l) (return t))
  501.        (setq l (cdr l))))
  502.  
  503. (defmacro typecase (keyform &rest x &aux (tmp (gensym)))
  504.       `(let ((,tmp ,keyform))
  505.         (cond 
  506.               ,@(mapcar #'(lambda (x)
  507.                      (if (eq (first x) 'otherwise)
  508.                          `(t ,@(rest x))
  509.                          `((typep ,tmp ',(first x))
  510.                            ,@(rest x))))
  511.                 x))))
  512.  
  513. (defun sleep (time)
  514.        (let ((endtime (+ time (/ (get-internal-real-time)
  515.                  internal-time-units-per-second))))
  516.         (loop (when (> (/ (get-internal-real-time)
  517.                   internal-time-units-per-second)
  518.                endtime)
  519.             (return nil)))))
  520.  
  521. (defmacro with-open-stream (stream-args &rest body)
  522.       `(let ((,(first stream-args) ,(second stream-args)))
  523.         (unwind-protect
  524.          (progn ,@body)
  525.          (when ,(first stream-args) (close ,(first stream-args))))))
  526.