/[gcl]/gcl/cmpnew/gcl_cmpfun.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpfun.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by camm, Fri Jan 7 17:58:33 2005 UTC revision 1.8 by camm, Wed Jun 29 04:16:35 2005 UTC
# Line 39  Line 39 
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)
# Line 138  Line 139 
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 ";")
# Line 271  Line 272 
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)
# Line 463  Line 465 
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) ";")
# Line 931  Line 933 
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 "= ")

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26