39 |
(si:putprop 'member 'c1member 'c1) |
(si:putprop 'member 'c1member 'c1) |
40 |
(si:putprop 'member!2 'c2member!2 'c2) |
(si:putprop 'member!2 'c2member!2 'c2) |
41 |
(si:putprop 'assoc 'c1assoc 'c1) |
(si:putprop 'assoc 'c1assoc 'c1) |
42 |
|
(si:putprop 'rassoc 'c1rassoc 'c1) |
43 |
(si:putprop 'assoc!2 'c2assoc!2 'c2) |
(si:putprop 'assoc!2 'c2assoc!2 'c2) |
44 |
(si:putprop 'get 'c1get 'c1) |
(si:putprop 'get 'c1get 'c1) |
45 |
(si:putprop 'get 'c2get 'c2) |
(si:putprop 'get 'c2get 'c2) |
139 |
|
|
140 |
(defun c2apply (funob args &aux (*vs* *vs*) loc) |
(defun c2apply (funob args &aux (*vs* *vs*) loc) |
141 |
(setq loc (save-funob funob)) |
(setq loc (save-funob funob)) |
142 |
(let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar)))) |
(let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (cs-push t t)))) |
143 |
(do ((l args (cdr l))) |
(do ((l args (cdr l))) |
144 |
((endp (cdr l)) |
((endp (cdr l)) |
145 |
(wt-nl "{object " last-arg ";") |
(wt-nl "{object " last-arg ";") |
272 |
(close-inline-blocks) |
(close-inline-blocks) |
273 |
) |
) |
274 |
|
|
|
(defun c1memq (args &aux (info (make-info))) |
|
|
(when (or (endp args) (endp (cdr args))) |
|
|
(too-few-args 'si::memq 2 (length args))) |
|
|
(unless (endp (cddr args)) |
|
|
(too-many-args 'si::memq 2 (length args))) |
|
|
(list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info))) |
|
|
|
|
|
(defun c1member (args &aux (info (make-info))) |
|
|
(when (or (endp args) (endp (cdr args))) |
|
|
(too-few-args 'member 2 (length args))) |
|
|
(cond ((endp (cddr args)) |
|
|
(list 'member!2 info 'eql (c1args args info))) |
|
|
((and (eq (caddr args) :test) |
|
|
(eql (length args) 4) |
|
|
(member (cadddr args) '('eq #'eq 'equal #'equal |
|
|
'equalp #'equalp 'eql #'eql) |
|
|
:test 'equal)) |
|
|
(list 'member!2 info (cadr (cadddr args)) |
|
|
(c1args (list (car args) (cadr args)) info))) |
|
|
(t |
|
|
(list 'call-global info 'member (c1args args info))))) |
|
|
|
|
|
(defun c2member!2 (fun args |
|
|
&aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar))) |
|
|
(setq args (inline-args args '(t t))) |
|
|
(wt-nl "{register object x= " (car args) ",V" l "= " (cadr args) ";") |
|
|
(if *safe-compile* |
|
|
(wt-nl "while(!endp(V" l "))") |
|
|
(wt-nl "while(V" l "!=Cnil)")) |
|
|
(if (eq fun 'eq) |
|
|
(wt-nl "if(x==(V" l "->c.c_car)){") |
|
|
(wt-nl "if(" (string-downcase (symbol-name fun)) |
|
|
"(x,V" l "->c.c_car)){")) |
|
|
(if (and (consp *value-to-go*) |
|
|
(or (eq (car *value-to-go*) 'JUMP-TRUE) |
|
|
(eq (car *value-to-go*) 'JUMP-FALSE))) |
|
|
(unwind-exit t 'JUMP) |
|
|
(unwind-exit (list 'CVAR l) 'JUMP)) |
|
|
(wt-nl "}else V" l "=V" l "->c.c_cdr;") |
|
|
(unwind-exit nil) |
|
|
(wt "}") |
|
|
(close-inline-blocks) |
|
|
) |
|
|
|
|
|
(defun c1assoc (args &aux (info (make-info))) |
|
|
(when (or (endp args) (endp (cdr args))) |
|
|
(too-few-args 'assoc 2 (length args))) |
|
|
(cond ((endp (cddr args)) |
|
|
(list 'assoc!2 info 'eql (c1args args info))) |
|
|
((and (eq (caddr args) ':test) |
|
|
(eql (length args) 4) |
|
|
(member (cadddr args) '('eq #'eq 'equal #'equal |
|
|
'equalp #'equalp 'eql #'eql) |
|
|
:test 'equal)) |
|
|
(list 'assoc!2 info (cadr (cadddr args)) (c1args (list (car args) (cadr args)) info))) |
|
|
(t |
|
|
(list 'call-global info 'assoc (c1args args info))))) |
|
|
|
|
|
(defun c2assoc!2 (fun args |
|
|
&aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar))name) |
|
|
(setq args (inline-args args '(t t))) |
|
|
(setq name (symbol-name fun)) |
|
|
(or (eq fun 'eq) (setq name (string-downcase name))) |
|
|
(wt-nl "{register object x= " (car args) ",V" al "= " (cadr args) ";") |
|
|
(cond (*safe-compile* |
|
|
(wt-nl "while(!endp(V" al "))") |
|
|
(wt-nl "if(type_of(V"al"->c.c_car)==t_cons &&" |
|
|
name "(x,V" al "->c.c_car->c.c_car)){")) |
|
|
(t |
|
|
(wt-nl "while(V" al "!=Cnil)") |
|
|
(wt-nl "if(" name "(x,V" al "->c.c_car->c.c_car) &&" |
|
|
"V"al"->c.c_car != Cnil){"))) |
|
|
(if (and (consp *value-to-go*) |
|
|
(or (eq (car *value-to-go*) 'jump-true) |
|
|
(eq (car *value-to-go*) 'jump-false))) |
|
|
(unwind-exit t 'jump) |
|
|
(unwind-exit (list 'CAR al) 'jump)) |
|
|
(wt-nl "}else V" al "=V" al "->c.c_cdr;") |
|
|
(unwind-exit nil) |
|
|
(wt "}") |
|
|
(close-inline-blocks) |
|
|
) |
|
|
|
|
275 |
|
|
276 |
|
(defconstant +ifb+ (- (car (last (multiple-value-list (si::heap-report)))))) |
277 |
|
(defconstant +ifr+ (ash (- +ifb+) -1)) |
278 |
|
(defconstant +ift+ '(integer #.(- +ifr+) #.(1- +ifr+))) |
279 |
|
|
280 |
|
(defun eql-is-eq (x) |
281 |
|
(cond ((typep x '#.+ift+)) |
282 |
|
((or (typep x 'number) (typep x 'character)) nil) |
283 |
|
(t))) |
284 |
|
|
285 |
|
(defun eql-is-eq-tp (x) |
286 |
|
(cond ((subtypep x +ift+)) |
287 |
|
((or (subtypep x 'number) (subtypep x 'character)) nil) |
288 |
|
((or (subtypep 'number x) (subtypep 'character x)) nil) |
289 |
|
(t))) |
290 |
|
|
291 |
|
(defun implicit-eq-tst (item list) |
292 |
|
(cond ((and (constantp item) (eql-is-eq item))) |
293 |
|
((and (constantp list) (consp list) (consp (cadr list)) |
294 |
|
(reduce (lambda (x y) (and (eql-is-eq x) y)) (cadr list)))) |
295 |
|
((let* ((info (make-info)) |
296 |
|
(nargs (c1args (list item list) info))) |
297 |
|
(eql-is-eq-tp (info-type (cadar nargs))))))) |
298 |
|
|
299 |
|
(defun lit-fun (x &rest r) |
300 |
|
(cond ((atom x) `(funcall ,x ,@r)) |
301 |
|
((member (car x) '(quote function)) `(,(cadr x) ,@r)) |
302 |
|
((eq (car x) 'lambda) `(,x ,@r)) |
303 |
|
((wfs-error)))) |
304 |
|
|
305 |
|
(defun do-list-srch (item list tst key k1 ret) |
306 |
|
(let* ((key-form `(,k1 ,list)) |
307 |
|
(key-form (if key (lit-fun key key-form) key-form)) |
308 |
|
(tst-form (lit-fun tst item key-form)) |
309 |
|
(tst-form (if ret `(and (,ret ,list) ,tst-form) tst-form)) |
310 |
|
(exit-form `(or (not ,list) ,tst-form)) |
311 |
|
(ret-form (if ret `(,ret ,list) list))) |
312 |
|
`(do ((,list ,list (cdr ,list))) |
313 |
|
(,exit-form ,ret-form)))) |
314 |
|
|
315 |
|
(defun fun-to-sym (x) |
316 |
|
(if (and (consp x) (or (eq (car x) 'quote) (eq (car x) 'function))) |
317 |
|
(cadr x) |
318 |
|
x)) |
319 |
|
|
320 |
|
(defun do-list-srch-eql (item list tst key k1 ret) |
321 |
|
(let ((ei (gensym)) (el (gensym))) |
322 |
|
`(let ((,ei ,item) (,el ,list)) |
323 |
|
,(if (eq (fun-to-sym tst) 'eql) |
324 |
|
`(if (eql-is-eq ,ei) |
325 |
|
,(do-list-srch ei el ''eq key k1 ret) |
326 |
|
,(do-list-srch ei el tst key k1 ret)) |
327 |
|
(do-list-srch ei el tst key k1 ret))))) |
328 |
|
|
329 |
|
(defun list-expr (item list &key key test test-not k1 ret) |
330 |
|
(when (and test test-not) |
331 |
|
(error ":test and :test-not both specified")) |
332 |
|
(let ((test (or test |
333 |
|
(and test-not `(lambda (x y) (not ,(lit-fun test-not 'x 'y)))) |
334 |
|
(if (implicit-eq-tst item list) ''eq ''eql)))) |
335 |
|
(c1expr (do-list-srch-eql item list test key k1 ret)))) |
336 |
|
|
337 |
|
(defmacro with-item-list-keys ((item list keys) args &body body) |
338 |
|
`(let ((,item (car ,args)) (,list (cadr ,args)) (,keys (cddr ,args))) |
339 |
|
(when (or (endp ,args) (endp (cdr ,args))) |
340 |
|
(too-few-args 'list-expr 2 (length ,args))) |
341 |
|
,@body)) |
342 |
|
|
343 |
|
(defun c1assoc (args) |
344 |
|
(with-item-list-keys |
345 |
|
(item list keys) args |
346 |
|
(apply 'list-expr item list :k1 'caar :ret 'car keys))) |
347 |
|
(defun c1rassoc (args) |
348 |
|
(with-item-list-keys |
349 |
|
(item list keys) args |
350 |
|
(apply 'list-expr item list :k1 'cdar :ret 'car keys))) |
351 |
|
(defun c1member (args) |
352 |
|
(with-item-list-keys |
353 |
|
(item list keys) args |
354 |
|
(apply 'list-expr item list :k1 'car keys))) |
355 |
|
(defun c1memq (args) |
356 |
|
(with-item-list-keys |
357 |
|
(item list keys) args |
358 |
|
(apply 'list-expr item list :k1 'car :test ''eq keys))) |
359 |
|
|
360 |
|
;;FIXME member-if member-if-not et.al by ;test -> :test-not |
361 |
|
|
362 |
(defun boole3 (a b c) (boole a b c)) |
(defun boole3 (a b c) (boole a b c)) |
363 |
(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) |
(si:putprop 'boole '(c1boole-condition . c1boole3) 'c1conditional) |
465 |
(defun c2get (args) |
(defun c2get (args) |
466 |
(if *safe-compile* |
(if *safe-compile* |
467 |
(c2call-global 'get args nil t) |
(c2call-global 'get args nil t) |
468 |
(let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar))) |
(let ((*vs* *vs*) (*inline-blocks* 0) (pl (cs-push t t))) |
469 |
(setq args (inline-args args (if (cddr args) '(t t t) '(t t)))) |
(setq args (inline-args args (if (cddr args) '(t t t) '(t t)))) |
470 |
(wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;") |
(wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;") |
471 |
(wt-nl " object ind= " (cadr args) ";") |
(wt-nl " object ind= " (cadr args) ";") |
933 |
(c1args (list (cadr args)) info)) |
(c1args (list (cadr args)) info)) |
934 |
(list 'call-global info 'si:list-nth (c1args args info)))) |
(list 'call-global info 'si:list-nth (c1args args info)))) |
935 |
|
|
936 |
(defun c2list-nth-immediate (index args &aux (l (next-cvar)) |
(defun c2list-nth-immediate (index args &aux (l (cs-push t t)) |
937 |
(*vs* *vs*) (*inline-blocks* 0)) |
(*vs* *vs*) (*inline-blocks* 0)) |
938 |
(setq args (inline-args args '(t t))) |
(setq args (inline-args args '(t t))) |
939 |
(wt-nl "{object V" l "= ") |
(wt-nl "{object V" l "= ") |