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