mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-13 12:52:08 -08:00
Code Issues Projects Releases Packages Wiki Activity

Move ASSOC from a C1 OPTIMIZED form to a compiler macro

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-05-13 23:03:53 +02:00
parent 34233787c6
commit 5f1b459879
2 changed files with 0 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/cmp/cmpform.lsp
View file

@ -62,9 +62,7 @@
(COMPILER-LET symbols values body)
(FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
(C2PRINC object-string-or-char stream-var stream-c1form :side-effects)
(RPLACA (dest-c1form value-c1form) :side-effects)
(RPLACD (dest-c1form value-c1form) :side-effects)
(ASSOC!2 fun-symbol args-c1form-list :pure)
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)

51
src/cmp/cmpfun.lsp
View file

@ -87,23 +87,6 @@
(t
(c1funcall (list* '#'APPLY args))))))
(defun c1rplaca (args)
(check-args-number 'RPLACA args 2 2)
(make-c1form* 'RPLACA :args (c1args* args)))
(defun c2rplaca (args)
(let* ((*inline-blocks* 0)
(*temp* *temp*)
(args (coerce-locs (inline-args args)))
(x (first args))
(y (second args)))
(when (safe-compile)
(wt-nl "if (ecl_unlikely(ATOM(" x ")))"
"FEtype_error_cons(" x ");"))
(wt-nl "ECL_CONS_CAR(" x ") = " y ";")
(unwind-exit x)
(close-inline-blocks)))
(defun c1rplacd (args)
(check-args-number 'RPLACD args 2 2)
(make-c1form* 'RPLACD :args (c1args* args)))
@ -121,35 +104,6 @@
(unwind-exit x)
(close-inline-blocks)))
(defun c1assoc (args)
(check-args-number 'ASSOC args 2)
(cond ((endp (cddr args))
(make-c1form* 'ASSOC!2 :args 'EQL (c1args* args)))
((and (eq (third args) ':TEST)
(= (length args) 4) ; Beppe
(member (fourth args) '('EQ #'EQ 'EQUAL #'EQUAL
'EQUALP #'EQUALP 'EQL #'EQL)
:test 'EQUAL))
(make-c1form* 'ASSOC!2 :args (second (fourth args))
(c1args* (list (car args) (second args)))))
(t
(c1call-global 'ASSOC args))))
(defun c2assoc!2 (fun args)
(let* ((*inline-blocks* 0)
(*temp* *temp*))
(unwind-exit
(produce-inline-loc (inline-args args) '(T T) '(:object)
(case fun
(eq "ecl_assq(#0,#1)")
(eql "ecl_assql(#0,#1)")
(equal "ecl_assoc(#0,#1)")
(equalp "ecl_assqlp(#0,#1)"))
nil ; side effects?
t
))
(close-inline-blocks)))
(defun co1nth (args)
(and (not (endp args))
(not (endp (cdr args)))
@ -279,14 +233,9 @@
(put-sysprop 'apply 'C1 'c1apply)
;(put-sysprop 'rplaca 'C1 'c1rplaca)
;(put-sysprop 'rplaca 'C2 'c2rplaca)
(put-sysprop 'rplacd 'C1 'c1rplacd)
(put-sysprop 'rplacd 'C2 'c2rplacd)
(put-sysprop 'assoc 'C1 'c1assoc)
(put-sysprop 'assoc!2 'C2 'c2assoc!2)
(put-sysprop 'nth 'C1CONDITIONAL 'co1nth)
(put-sysprop 'nthcdr 'C1CONDITIONAL 'co1nthcdr)