1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         ibmrs-nk-spec.sl
4% Title:        misc functions for IBM RS 6000 nonkernel
5% Author:       Winfried Neun
6% Created:      27 February 1989
7% Status:       Experimental
8% Mode:         Lisp
9% Package:      Kernel
10%
11% (c) Copyright 1989, Konrad-Zuse-Zentrum Berlin, all rights reserved.
12%
13%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
14
15(compiletime
16  (flag '(halfwordsequal vectorequal wordsequal intern-equal
17          bothzero floateqn pairequal fast-wordsequal )
18                   'internalfunction))
19
20(remd 'eqn)
21
22(de eqn (u v)
23  % Eq or numeric equality.
24      (case (tag u)
25        ((posint-tag)   (or (weq u v) (and (eq 0 u) (bothzero u v))))
26        ((negint-tag)   (weq u v))
27        ((floatnum-tag) (floateqn u v))
28        ((fixnum-tag)
29                (and (fixnp v) (weq (fixval (fixinf u)) (fixval (fixinf v)))))
30        ((bignum-tag)   (and (bigp v) (wordsequal u v)))
31        (nil nil)))
32
33(de floateqn (u v)
34      (or (and (floatp v)
35               (weq (floathighorder (fltinf u)) (floathighorder (fltinf v)))
36               (weq (floatloworder (fltinf u))  (floatloworder (fltinf v))))
37          (bothzero u v)))
38
39(de bothzero (u v) (and (zerop u) (zerop v)))
40
41(remd 'equal)
42
43(de equal (u v)
44  % Structural equality
45      (case (tag u)
46        ((posint-tag)    (or (weq u v) (and (eq u 0) (eqn u v))))
47        ((negint-tag code-tag id-tag unbound-tag forward-tag 16 17 18 19)
48                         (weq u v))  % to fool &comcase
49        ((evector-tag)   (or (weq u v) (evectorequal u v)))
50        ((vector-tag)    (and (vectorp v) (vectorequal u v)))
51        ((string-tag)    (and (stringp v) (stringequal u v)))
52        ((bytes-tag)     (and (bytesp v)  (stringequal u v)))
53        ((pair-tag)      (and (pairp v)   (pairequal u v)))
54        ((floatnum-tag)  (eqn u v))
55        ((fixnum-tag)    (eqn u v))
56        ((bignum-tag)    (and (bigp v)    (wordsequal u v)))
57        ((words-tag)     (and (wrdsp v)   (wordsequal u v)))
58        ((halfwords-tag) (and (halfwordsp v) (halfwordsequal u v)))
59        ((hbytes-tag hhalfwords-tag hwords-tag hvect-tag sgd-tag)
60          (weq u v)) %just to fool &comcase
61        (nil nil)))
62
63(de intern-equal (u v)
64  % Structural equality
65      (case (tag u)
66        ((posint-tag)    (or (weq u v) (and (eq u 0) (eqn u v))))
67        ((negint-tag code-tag id-tag unbound-tag forward-tag 16 17 18 19)
68                         (weq u v))  % to fool &comcase
69        ((evector-tag)   (or (weq u v) (evectorequal u v)))
70        ((vector-tag)    (and (vectorp v) (vectorequal u v)))
71        ((string-tag)    (and (stringp v) (stringequal u v)))
72        ((bytes-tag)     (and (bytesp v)  (stringequal u v)))
73        ((pair-tag)      (and (pairp v)   (pairequal u v)))
74        ((floatnum-tag)  (eqn u v))
75        ((fixnum-tag)    (eqn u v))
76        ((bignum-tag)    (and (bigp v)    (wordsequal u v)))
77        ((words-tag)     (and (wrdsp v)   (wordsequal u v)))
78        ((halfwords-tag) (and (halfwordsp v) (halfwordsequal u v)))
79        ((hbytes-tag hhalfwords-tag hwords-tag hvect-tag sgd-tag)
80          (weq u v)) %just to fool &comcase
81        (nil nil)))
82
83
84(de pairequal (u v)
85     (cond ((eq u v) t)
86           ((intern-equal (car u) (car v)) (intern-equal (cdr u) (cdr v)))
87           (T nil)))
88
89(remd 'wordsequal)
90
91(de wordsequal (u v)
92  (prog (s1 i)
93        (setq u (wrdinf u))
94        (setq v (wrdinf v))
95        (unless (weq (setq s1 (wrdlen u)) (wrdlen v)) (return nil))
96        (setq i 0)
97   loop
98        (when (wgreaterp i s1)    (return t))
99        (unless (weq (wrditm u i) (wrditm v i))  (return nil))
100        (setq i (wplus2 i 1))
101        (go loop)))
102
103(remd 'halfwordsequal)
104
105(de halfwordsequal (u v)
106  (prog (s1 i)
107        (setq u (halfwordinf u))
108        (setq v (halfwordinf v))
109        (unless (wgreaterp (setq s1 (halfwordlen u)) (halfwordlen v))
110          (return nil))
111        (setq i 0)
112   loop
113        (when (wgreaterp i s1)        (return t))
114        (unless (weq (halfworditm u i) (halfworditm v i)) (return nil))
115        (setq i (wplus2 i 1))
116        (go loop)))
117
118
119(remd 'vectorequal)
120
121(de vectorequal (u v)
122  % Vector equality without type check
123  (prog (len i)
124        (setq u (vecinf u))
125        (setq v (vecinf v))
126        (setq len (veclen u))
127        (when (wneq len (veclen v))  (return nil))
128        (setq i 0)
129   loop
130        (when (wgreaterp i len)      (return t))
131        (unless (equal (vecitm u i) (vecitm v i))       (return nil))
132        (setq i (wplus2 i 1))
133        (go loop)))
134
135(remd 'evlis)
136
137(de evlis(u)
138      (prog (result pointer)
139           (when (not (pairp u)) (return nil))
140           (setq pointer (setq result (cons (eval (car u)) nil)))
141       loop
142           (setq u (cdr u))
143           (when (not (pairp u)) (return result))
144           (rplacd pointer (cons (eval (car u)) nil))
145           (setq pointer (cdr pointer))
146           (go loop)))
147
148%(copyd 'eval-aux 'eval)
149
150% a simple case (alloc free) dispatch for eval
151
152%(remd 'eval)
153
154(de eeeeeval (u)
155   (prog (v)
156     (case (tag u)
157        ((id-tag) (if (or (null u)
158			(not (eq unbound-tag (tag (setq v (symval (inf u)))))))
159                             (return v)
160                             (return (eval-aux u))))
161        ((pair-tag) (return (eval-aux u)))
162        ((0 1 2 3 4 5 6 7 8 10 11 12 13 14 15 16 17 18 19 20 21 22 23
163          24 25 26 27 28 29 31)   (return u))  % not id or atom
164) ))
165(de > (x y) (greaterp x y))
166(de fast-plus (x y) (wplus2 x y))
167 (lap '((*entry !*!*hu!*!* expr 0) (*move 16#74 (reg r0))
168(*mkitem (reg r0) 30) (*exit 0)))))
169(!*!*hu!*!*)
170 (put '!' 'lispreadmacro (function channelreadquotedexpression))
171 (put '!( 'lispreadmacro (function channelreadlistordottedpair))
172 (put '!) 'lispreadmacro (function channelreadrightparen))
173 (put '![ 'lispreadmacro (function channelreadvector))
174(put (mkid 4) 'lispreadmacro (function channelreadeof))
175(compiletime (on pcmac))
176(compiletime (off pcmac))
177
178
179