home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / o / ops5.zip / OPS-UTIL.LIS < prev    next >
Lisp/Scheme  |  1992-05-31  |  7KB  |  243 lines
  1. ;
  2. ;************************************************************************
  3. ;
  4. ;    VPS2 -- Interpreter for OPS5
  5. ;
  6. ;
  7. ;
  8. ; This Common Lisp version of OPS5 is in the public domain.  It is based
  9. ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
  10. ; at Carnegie-Mellon University, which was placed in the public domain by
  11. ; the author in accordance with CMU policies.  This version has been
  12. ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
  13. ; and Dan Kuokka.
  14. ;
  15. ; This code is made available is, and without warranty of any kind by the
  16. ; authors or by Carnegie-Mellon University.
  17. ;
  18.  
  19. ;;;; This file contains utility definitions that are needed by other ops
  20. ;;;; modules.  This must be loaded first so commonlisp systems that
  21. ;;;; expand macros early have them available.
  22.  
  23. (unless (find-package "OPS") (make-package "OPS"))
  24.  
  25. (in-package "OPS")
  26.  
  27. ;;; Assq is included in some Common Lisp implementations (like Spice Lisp and
  28. ;;; the Zetalisp CLCP) as an extension.  We'll use ASSOC if it's not there.
  29. ;;; DK- turned assq into a function so it can be 'applied'
  30.  
  31. (eval-when (compile load eval)
  32.   (unless (fboundp 'assq)
  33.     (defmacro assq (i l)
  34.       `(assoc ,i ,l))))
  35.  
  36. ;;; Ditto for DELQ.
  37.  
  38. (eval-when (compile load eval)
  39.   (unless (fboundp 'delq)
  40.     (defmacro delq (i l)
  41.       `(delete ,i ,l :test #'eq))))
  42.  
  43. ;
  44. ; Spdelete "special delete" is a function which deletes every occurence
  45. ; of element from list. This function was defined because common lisp's
  46. ; delete function only deletes top level elements from a list, not lists
  47. ; from lists. 
  48. ;
  49. (defun spdelete (element list)
  50.   
  51.   (cond ((null list) nil)
  52.     ((equal element (car list)) (spdelete element (cdr list)))
  53.     (t (cons (car list) (spdelete element (cdr list))))))
  54.  
  55.  
  56. ;;; Functions that were revised so that they would compile efficiently
  57.  
  58. (eval-when (compile eval load)
  59.        
  60. ;* The function == is machine dependent!
  61. ;* This function compares small integers for equality.  It uses EQ
  62. ;* so that it will be fast, and it will consequently not work on all
  63. ;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
  64. ;(system::macro == (z) `(eq ,(cadr z) ,(caddr z)))
  65. ;;;
  66. ;;; Dario Giuse - made a macro. This is going to be faster than anything else.
  67. ;;;
  68. ;;; Skef Wholey - The = function in Common Lisp will compile into good code
  69. ;;; (in all implementations that I know of) when given the right declarations.
  70. ;;; In this case, we know both numbers are fixnums, so we use that information.
  71.  
  72. (defmacro == (x y)
  73.   `(= (the fixnum ,x) (the fixnum ,y)))
  74.  
  75. ;;; =ALG returns T if A and B are algebraically equal.
  76. ;;; This corresponds to equalp - Dario Giuse
  77. ;;; But equalp uses eql for comparison if the things are numbers - Skef Wholey
  78. ;;;
  79. (defmacro =alg (a b)
  80.   `(eql ,a ,b))
  81.  
  82.        
  83. (defmacro fast-symeval (&body z)
  84.   `(symbol-value ,(car z)))
  85.  
  86. ; getvector and putvector are fast routines for using ONE-DIMENSIONAL
  87. ; arrays.  these routines do no checking; they assume
  88. ;    1. the array is a vector with 0 being the index of the first
  89. ;       element
  90. ;    2. the vector holds arbitrary list values
  91.  
  92. ; Example call: (putvector array index value)
  93. ;;; Dario Giuse - 6/20/84
  94.  
  95. (defmacro putvector (array index value)
  96.   `(setf (aref ,array ,index) ,value))
  97.  
  98. ;;; Example call: (getvector name index)
  99. ;;;
  100. (defmacro getvector (array index)
  101.   `(aref ,array ,index))
  102.  
  103.  
  104. ;;; Dario Giuse  6/21/84
  105. (defmacro putprop (atom value property)
  106.   `(setf (get ,atom ,property) ,value))
  107.  
  108. ) ;eval-when
  109.  
  110.  
  111. (defun ce-gelm (x k)
  112.   (declare (fixnum k))
  113.   (declare (optimize (speed 3) (safety 0)))
  114.   (prog nil
  115.     loop (and (== k 1.) (return (car x)))
  116.     (setq k (1- k))
  117.     (setq x (cdr x))
  118.     (go loop))) 
  119.  
  120. (defconstant encode-pair-shift 14)
  121.  
  122. ; The loops in gelm were unwound so that fewer calls on DIFFERENCE
  123. ; would be needed
  124.  
  125. (defun gelm (x k)
  126.   (declare (optimize speed (safety 0)) (fixnum k))
  127.   (prog ((ce (ash k (- encode-pair-shift)))
  128.      (sub (ldb (byte 14 0) k)))
  129.     (declare (fixnum ce sub))
  130.     celoop (and (eql ce 0.) (go ph2))
  131.     (setq x (cdr x))
  132.     (and (eql ce 1.) (go ph2))
  133.     (setq x (cdr x))
  134.     (and (eql ce 2.) (go ph2))
  135.     (setq x (cdr x))
  136.     (and (eql ce 3.) (go ph2))
  137.     (setq x (cdr x))
  138.     (and (eql ce 4.) (go ph2))
  139.     (setq ce (- ce 4.))
  140.     (go celoop)
  141.     ph2  (setq x (car x))
  142.     subloop (and (eql sub 0.) (go finis))
  143.     (setq x (cdr x))
  144.     (and (eql sub 1.) (go finis))
  145.     (setq x (cdr x))
  146.     (and (eql sub 2.) (go finis))
  147.     (setq x (cdr x))
  148.     (and (eql sub 3.) (go finis))
  149.     (setq x (cdr x))
  150.     (and (eql sub 4.) (go finis))
  151.     (setq x (cdr x))
  152.     (and (eql sub 5.) (go finis))
  153.     (setq x (cdr x))
  154.     (and (eql sub 6.) (go finis))
  155.     (setq x (cdr x))
  156.     (and (eql sub 7.) (go finis))
  157.     (setq x (cdr x))
  158.     (and (eql sub 8.) (go finis))
  159.     (setq sub (- sub 8.))
  160.     (go subloop)
  161.     finis (return (car x))) ) ;  )      ;end prog,< locally >, defun
  162.  
  163.  
  164.  
  165. ;;; intersect two lists using eq for the equality test
  166. (defun interq (x y)
  167.   (cond ((atom x) nil)
  168.     ((member (car x) y) (cons (car x) (interq (cdr x) y)))
  169.     (t (interq (cdr x) y)))) 
  170.  
  171.  
  172. (proclaim '(special *p-name*))
  173.  
  174. (defun %warn (what where)
  175.   (prog nil
  176.     (terpri)
  177.     (princ '?)
  178.     (and *p-name* (princ *p-name*))
  179.     (princ '|..|)
  180.     (princ where)
  181.     (princ '|..|)
  182.     (princ what)
  183.     (return where))) 
  184.  
  185. (defun %error (what where)
  186.   (%warn what where)
  187.   (throw '!error! '!error!))     ;jgk quoted arguments
  188.  
  189. ;@@@(defun round (x) (fix (+ 0.5 x)))         ;"plus" changed to "+" by gdw
  190. ;@@@ removed; calls converted to native clisp (round)
  191.  
  192. (defun top-levels-eq (la lb)
  193.   (prog nil
  194.     lx   (cond ((eq la lb) (return t))
  195.            ((null la) (return nil))
  196.            ((null lb) (return nil))
  197.            ((not (eq (car la) (car lb))) (return nil)))
  198.     (setq la (cdr la))
  199.     (setq lb (cdr lb))
  200.     (go lx))) 
  201.  
  202.  
  203. ;(defun dtpr  (x) (consp x))    ;dtpr\consp gdw
  204.  
  205.  
  206. (defun fix (x)(floor x))
  207.  
  208.  
  209. (eval-when (compile load eval)
  210. (defmacro ncons (x) `(cons ,x nil))
  211. );eval-when
  212.  
  213.  
  214. ;@@@ revision suggested by sf/inc. by gdw
  215. (defun variablep (x)
  216.   (and (symbolp x)
  217.        (let ((name (symbol-name x)))
  218.      (and (>= (length name) 1)
  219.           (char= (char name 0) #\<)))))
  220.  
  221.  
  222.  
  223. ;@@@   this is a mistake: it must either go before = is called for 
  224. ;non-numeric args, or such calls replaced with eq, equal, etc.
  225. ;(defun = 
  226. ;(x y) (equal x y))
  227.  
  228.  
  229.  
  230. #|
  231. Commented out - Dario Giuse.
  232. This is unnecessary in Spice Lisp
  233.  
  234. ; break mechanism:
  235. (proclaim '(special erm *break-character*))
  236.  
  237. (defun setbreak nil (setq *break-flag* t))
  238. (setq *break-character* #\control-D)
  239. (bind-keyboard-function *break-character* #'setbreak)
  240. (princ "*** use control-d for ops break, or setq *break-character asciival***")
  241.  
  242. |#
  243.