/[cmucl]/src/contrib/ops/ops-util.lisp
ViewVC logotype

Contents of /src/contrib/ops/ops-util.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun May 31 02:20:40 1992 UTC (21 years, 10 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +27 -24 lines
Efficiency tweaked gelm.  Fixed variablep not to choke on ||.
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 |#

  ViewVC Help
Powered by ViewVC 1.1.5