mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-01 15:20:36 -08:00
New definition for SI:DESTRUCTURE uses SI::PROCESS-LAMBDA-LIST to parse
the destructuring list, for both DEFMACRO and DESTRUCTURING-BIND forms. This results in smaller code.
This commit is contained in:
jjgarcia
parent
b68c2036f6
commit
d20cde0cd9
3 changed files with 83 additions and 108 deletions
|
|
@ -1069,8 +1069,12 @@ ECL 0.8
|
|||
delimiting char is used instead.
|
||||
|
||||
- Two separate functions SI::PROCESS-LAMBDA & SI::PROCESS-LAMBDA-LIST to
|
||||
parse functions and general lambda lists. The code has been improved and
|
||||
it is now smaller.
|
||||
parse functions and general lambda lists. The code has been improved,
|
||||
it is now smaller, and it is also used in DESTRUCTURING-BIND and
|
||||
DEFMACRO (defmacro.lsp).
|
||||
|
||||
- DO and DO* have now different macroexpansions, with less gotos;
|
||||
which leads to smaller C code.
|
||||
|
||||
* Visible changes:
|
||||
|
||||
|
|
|
|||
|
|
@ -1947,10 +1947,11 @@ compile_body(cl_object body) {
|
|||
|
||||
#define push(v,l) l = CONS(v, l)
|
||||
#define push_var(v, list) \
|
||||
check_symbol(v); \
|
||||
if (v->symbol.stype == stp_constant) \
|
||||
FEillegal_variable_name(v); \
|
||||
push(v, list);
|
||||
if (context == @'function') { \
|
||||
assert_type_symbol(v); \
|
||||
if (v->symbol.stype == stp_constant) \
|
||||
FEillegal_variable_name(v); } \
|
||||
push(v, list)
|
||||
|
||||
/*
|
||||
Handles special declarations, removes declarations from body
|
||||
|
|
@ -1982,7 +1983,7 @@ compile_body(cl_object body) {
|
|||
if (CAR(sentence) == @'special')
|
||||
for (vars = CDR(sentence); !endp(vars); vars = CDR(vars)) {
|
||||
v = CAR(vars);
|
||||
check_symbol(v);
|
||||
assert_type_symbol(v);
|
||||
push(v,specials);
|
||||
}
|
||||
}
|
||||
|
|
@ -2030,14 +2031,19 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context)
|
|||
int nreq = 0, nopt = 0, nkey = 0, naux = 0, stage = 0;
|
||||
cl_object allow_other_keys = Cnil;
|
||||
|
||||
if (!CONSP(lambda_list) && lambda_list != Cnil)
|
||||
goto ILLEGAL_LAMBDA;
|
||||
LOOP:
|
||||
if (ATOM(lambda_list)) {
|
||||
if (lambda_list == Cnil)
|
||||
goto OUTPUT;
|
||||
else if (context == @'function')
|
||||
goto ILLEGAL_LAMBDA;
|
||||
else
|
||||
else {
|
||||
v = lambda_list;
|
||||
lambda_list = Cnil;
|
||||
goto REST;
|
||||
}
|
||||
}
|
||||
v = CAR(lambda_list);
|
||||
lambda_list = CDR(lambda_list);
|
||||
|
|
@ -2048,9 +2054,14 @@ LOOP:
|
|||
goto LOOP;
|
||||
}
|
||||
if (v == @'&rest' || (v == @'&body' && context != @'function')) {
|
||||
if (ATOM(lambda_list))
|
||||
goto ILLEGAL_LAMBDA;
|
||||
v = CAR(lambda_list);
|
||||
lambda_list = CDR(lambda_list);
|
||||
REST: if (stage >= AT_REST)
|
||||
goto ILLEGAL_LAMBDA;
|
||||
stage = AT_REST;
|
||||
push_var(v, rest);
|
||||
goto LOOP;
|
||||
}
|
||||
if (v == @'&key') {
|
||||
|
|
@ -2102,12 +2113,9 @@ REST: if (stage >= AT_REST)
|
|||
}
|
||||
break;
|
||||
case AT_REST:
|
||||
if (rest == Cnil) {
|
||||
push_var(v, rest);
|
||||
} else {
|
||||
goto ILLEGAL_LAMBDA;
|
||||
}
|
||||
break;
|
||||
/* If we get here, the user has declared more than one
|
||||
* &rest variable, as in (lambda (&rest x y) ...) */
|
||||
goto ILLEGAL_LAMBDA;
|
||||
case AT_KEYS:
|
||||
init = Cnil;
|
||||
spp = Cnil;
|
||||
|
|
@ -2128,11 +2136,11 @@ REST: if (stage >= AT_REST)
|
|||
if (endp(CDR(v)) || !endp(CDDR(v)))
|
||||
goto ILLEGAL_LAMBDA;
|
||||
v = CADR(v);
|
||||
check_symbol(v);
|
||||
check_symbol(key);
|
||||
assert_type_symbol(v);
|
||||
assert_type_symbol(key);
|
||||
} else {
|
||||
int intern_flag;
|
||||
check_symbol(v);
|
||||
assert_type_symbol(v);
|
||||
key = intern(v->symbol.name, keyword_package, &intern_flag);
|
||||
}
|
||||
nkey++;
|
||||
|
|
|
|||
|
|
@ -98,97 +98,57 @@
|
|||
(declare (si::c-local))
|
||||
(error "Too many arguments are supplied to defmacro-lambda-list."))
|
||||
|
||||
(defun sys::destructure (vl whole macro &aux (*dl* nil) (*key-check* nil) (*arg-check* nil))
|
||||
(defun sys::destructure (vl whole macro)
|
||||
(declare (si::c-local))
|
||||
(labels ((dm-vl (vl whole top &aux v allow-other-keys-p)
|
||||
(do*((optionalp) (restp) (keyp)
|
||||
(allow-other-keys-p) (auxp)
|
||||
(rest) (allow-other-keys) (keys) (no-check)
|
||||
(n (if top 1 0)) (ppn 0) (v))
|
||||
((not (consp vl))
|
||||
(when vl
|
||||
(when restp (dm-bad-key '&rest))
|
||||
(push (list vl (dm-nth-cdr n whole)) *dl*)
|
||||
(setq no-check t))
|
||||
(when (and rest (not allow-other-keys))
|
||||
(push (cons rest keys) *key-check*))
|
||||
(unless no-check (push (cons whole n) *arg-check*))
|
||||
ppn)
|
||||
(declare (fixnum n ppn))
|
||||
(setq v (car vl))
|
||||
(cond
|
||||
((eq v '&optional)
|
||||
(when optionalp (dm-bad-key '&optional))
|
||||
(setq optionalp t)
|
||||
(pop vl))
|
||||
((and macro (eq v '&body))
|
||||
(when restp (dm-bad-key v))
|
||||
(dm-v (second vl) (dm-nth-cdr n whole))
|
||||
(setq restp t optionalp t no-check t)
|
||||
(setq vl (cddr vl))
|
||||
(setq ppn (if top (1- n) n)))
|
||||
((or (eq v '&rest) (eq v '&body))
|
||||
(when restp (dm-bad-key v))
|
||||
(dm-v (second vl) (dm-nth-cdr n whole))
|
||||
(setq restp t optionalp t no-check t)
|
||||
(setq vl (cddr vl)))
|
||||
((eq v '&key)
|
||||
(when keyp (dm-bad-key '&key))
|
||||
(setq rest (gensym))
|
||||
(push (list rest (dm-nth-cdr n whole)) *dl*)
|
||||
(setq keyp t restp t optionalp t no-check t)
|
||||
(pop vl))
|
||||
((eq v '&allow-other-keys)
|
||||
(when (or (not keyp) allow-other-keys-p)
|
||||
(dm-bad-key '&allow-other-keys))
|
||||
(setq allow-other-keys-p t)
|
||||
(setq allow-other-keys t)
|
||||
(pop vl))
|
||||
((eq v '&aux)
|
||||
(when auxp (dm-bad-key '&aux))
|
||||
(setq auxp t allow-other-keys-p t keyp t restp t optionalp t)
|
||||
(pop vl))
|
||||
(auxp
|
||||
(let (x (init nil))
|
||||
(cond ((symbolp v) (setq x v))
|
||||
(t (setq x (car v))
|
||||
(unless (endp (cdr v)) (setq init (second v)))))
|
||||
(dm-v x init))
|
||||
(pop vl))
|
||||
(keyp
|
||||
(let ((temp (gensym)) x k (init nil) (sv nil))
|
||||
(cond ((symbolp v) (setq x v
|
||||
k (intern (string v) 'keyword)))
|
||||
(t (if (symbolp (car v))
|
||||
(setq x (car v)
|
||||
k (intern (string (car v)) 'keyword))
|
||||
(setq x (cadar v) k (caar v)))
|
||||
(unless (endp (cdr v))
|
||||
(setq init (second v))
|
||||
(unless (endp (cddr v))
|
||||
(setq sv (caddr v))))))
|
||||
(dm-v temp `(search-keyword ,rest ',k))
|
||||
(dm-v x `(if (eq ,temp 'failed) ,init ,temp))
|
||||
(when sv (dm-v sv `(not (eq ,temp 'failed))))
|
||||
(push k keys))
|
||||
(pop vl))
|
||||
(optionalp
|
||||
(let (x (init nil) (sv nil))
|
||||
(cond ((symbolp v) (setq x v))
|
||||
(t (setq x (car v))
|
||||
(unless (endp (cdr v))
|
||||
(setq init (second v))
|
||||
(unless (endp (cddr v))
|
||||
(setq sv (caddr v))))))
|
||||
(dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init))
|
||||
(when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole))))))
|
||||
(incf n)
|
||||
(pop vl))
|
||||
(t (dm-v v `(if ,(dm-nth-cdr n whole)
|
||||
,(dm-nth n whole)
|
||||
(dm-too-few-arguments)))
|
||||
(incf n)
|
||||
(pop vl)))))
|
||||
(labels ((dm-vl (vl whole macro)
|
||||
(let ((n (if macro 1 0))
|
||||
(ppn 0)
|
||||
(no-check nil)
|
||||
all-keywords)
|
||||
(multiple-value-bind (reqs opts rest allow-other-keys keys auxs)
|
||||
(si::process-lambda-list vl (if macro 'macro 'destructuring-bind))
|
||||
(dolist (v (cdr reqs))
|
||||
(dm-v v `(if ,(dm-nth-cdr n whole)
|
||||
,(dm-nth n whole)
|
||||
(dm-too-few-arguments)))
|
||||
(incf n))
|
||||
(dotimes (i (pop opts))
|
||||
(let* ((x (first opts))
|
||||
(init (second opts))
|
||||
(sv (third opts)))
|
||||
(setq opts (cdddr opts))
|
||||
(dm-v x `(if ,(dm-nth-cdr n whole) ,(dm-nth n whole) ,init))
|
||||
(when sv (dm-v sv `(not (null ,(dm-nth-cdr n whole)))))
|
||||
(incf n)))
|
||||
(when rest
|
||||
(dm-v (setq rest (first rest)) (dm-nth-cdr n whole))
|
||||
(setq no-check t
|
||||
rest nil)
|
||||
(when (and (null (last vl 0)) (member '&body vl))
|
||||
(setq ppn (if macro (1- n) n))))
|
||||
(dotimes (i (pop keys))
|
||||
(unless rest
|
||||
(setq rest (gensym))
|
||||
(dm-v rest (dm-nth-cdr n whole))
|
||||
(setq no-check t))
|
||||
(let* ((temp (gensym))
|
||||
(k (first keys))
|
||||
(v (second keys))
|
||||
(init (third keys))
|
||||
(sv (fourth keys)))
|
||||
(setq keys (cddddr keys))
|
||||
(dm-v temp `(search-keyword ,rest ',k))
|
||||
(dm-v v `(if (eq ,temp 'failed) ,init ,temp))
|
||||
(when sv (dm-v sv `(not (eq ,temp 'failed))))
|
||||
(push k all-keywords)))
|
||||
(do ((l auxs (cddr l))) ((endp l))
|
||||
(let ((v (first l))
|
||||
(init (second l)))
|
||||
(dm-v v init)))
|
||||
(when (and rest (not allow-other-keys))
|
||||
(push (cons rest all-keywords) *key-check*))
|
||||
(unless no-check (push (cons whole n) *arg-check*)))
|
||||
ppn))
|
||||
|
||||
(dm-v (v init)
|
||||
(cond ((symbolp v)
|
||||
|
|
@ -229,7 +189,10 @@
|
|||
(cond ((listp vl))
|
||||
((symbolp vl) (setq vl (list '&rest vl)))
|
||||
(t (error "The destructuring-lambda-list ~s is not a list." vl)))
|
||||
(let ((ppn (dm-vl vl whole macro)))
|
||||
(let* ((*dl* nil)
|
||||
(*key-check* nil)
|
||||
(*arg-check* nil)
|
||||
(ppn (dm-vl vl whole macro)))
|
||||
(values ppn (nreverse *dl*) *key-check* *arg-check*))))
|
||||
|
||||
;;; valid lambda-list to DEFMACRO is:
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue