mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-06 04:10:47 -08:00
Implemented DOLIST/DOTIMES as macros, without magic in the interpreter.
This commit is contained in:
jjgarcia
parent
5ea5102b91
commit
5643e40059
8 changed files with 86 additions and 315 deletions
|
|
@ -71,8 +71,6 @@ static int c_case(cl_object args, int flags);
|
|||
static int c_catch(cl_object args, int flags);
|
||||
static int c_compiler_let(cl_object args, int flags);
|
||||
static int c_cond(cl_object args, int flags);
|
||||
static int c_dolist(cl_object args, int flags);
|
||||
static int c_dotimes(cl_object args, int flags);
|
||||
static int c_eval_when(cl_object args, int flags);
|
||||
static int c_flet(cl_object args, int flags);
|
||||
static int c_funcall(cl_object args, int flags);
|
||||
|
|
@ -102,6 +100,7 @@ static int c_tagbody(cl_object args, int flags);
|
|||
static int c_throw(cl_object args, int flags);
|
||||
static int c_unwind_protect(cl_object args, int flags);
|
||||
static int c_while(cl_object args, int flags);
|
||||
static int c_until(cl_object args, int flags);
|
||||
static int compile_body(cl_object args, int flags);
|
||||
static int compile_form(cl_object args, int push);
|
||||
|
||||
|
|
@ -232,8 +231,6 @@ static compiler_record database[] = {
|
|||
{@'catch', c_catch, 1},
|
||||
{@'ext::compiler-let', c_compiler_let, 0},
|
||||
{@'cond', c_cond, 1},
|
||||
{@'dolist', c_dolist, 1},
|
||||
{@'dotimes', c_dotimes, 1},
|
||||
{@'eval-when', c_eval_when, 0},
|
||||
{@'flet', c_flet, 1},
|
||||
{@'function', c_function, 1},
|
||||
|
|
@ -265,6 +262,7 @@ static compiler_record database[] = {
|
|||
{@'unwind-protect', c_unwind_protect, 1},
|
||||
{@'values', c_values, 1},
|
||||
{@'si::while', c_while, 0},
|
||||
{@'si::until', c_until, 0},
|
||||
{NULL, NULL, 1}
|
||||
};
|
||||
|
||||
|
|
@ -922,7 +920,7 @@ c_cond(cl_object args, int flags) {
|
|||
|
||||
*/
|
||||
static int
|
||||
c_while(cl_object body, int flags) {
|
||||
c_while_until(cl_object body, int flags, bool is_while) {
|
||||
cl_object test = pop(&body);
|
||||
cl_index labelt, labelb;
|
||||
|
||||
|
|
@ -938,99 +936,20 @@ c_while(cl_object body, int flags) {
|
|||
/* Compile test */
|
||||
asm_complete(OP_JMP, labelt);
|
||||
compile_form(test, FLAG_VALUES);
|
||||
asm_op(OP_JNIL);
|
||||
asm_op(is_while? OP_JT : OP_JNIL);
|
||||
asm_arg(labelb - current_pc());
|
||||
|
||||
return flags;
|
||||
}
|
||||
|
||||
/*
|
||||
The OP_DOLIST & OP_DOTIMES operators save the lexical
|
||||
environment and establishes a NIL block to execute the
|
||||
enclosed forms, which iterate over the elements in a list or
|
||||
over a range of integer numbers. At the exit of the block,
|
||||
either by means of a OP_RETFROM jump or because of normal
|
||||
termination, the lexical environment is restored, and all
|
||||
bindings undone.
|
||||
|
||||
[OP_DOTIMES/OP_DOLIST + labelz + labelo]
|
||||
... ; bindings
|
||||
OP_EXIT
|
||||
... ; body
|
||||
... ; stepping forms
|
||||
OP_EXIT
|
||||
labelo: ... ; output form
|
||||
OP_EXIT
|
||||
labelz:
|
||||
|
||||
*/
|
||||
|
||||
static int
|
||||
c_dolist_dotimes(int op, cl_object args, int flags) {
|
||||
cl_object head = pop(&args);
|
||||
cl_object var = pop(&head);
|
||||
cl_object list = pop(&head);
|
||||
cl_object specials, body;
|
||||
cl_index labelz, labelo;
|
||||
cl_object old_variables = ENV->variables;
|
||||
|
||||
body = c_process_declarations(args);
|
||||
specials = VALUES(3);
|
||||
|
||||
if (!SYMBOLP(var))
|
||||
FEillegal_variable_name(var);
|
||||
|
||||
/* Compute list and enter loop */
|
||||
compile_form(list, FLAG_VALUES);
|
||||
labelz = asm_jmp(op);
|
||||
labelo = current_pc(); asm_arg(0);
|
||||
|
||||
/* Bind block */
|
||||
c_register_block(Cnil);
|
||||
|
||||
/* Initialize the variable */
|
||||
compile_form((op == OP_DOLIST)? Cnil : MAKE_FIXNUM(0), FLAG_REG0);
|
||||
c_bind(var, specials);
|
||||
asm_op(OP_EXIT);
|
||||
|
||||
/* From here on, declarations apply */
|
||||
c_declare_specials(specials);
|
||||
|
||||
/* Variable assignment and iterated body */
|
||||
compile_setq(OP_SETQ, var);
|
||||
c_tagbody(body, 0);
|
||||
asm_op(OP_EXIT);
|
||||
|
||||
/* Output */
|
||||
asm_complete(0, labelo);
|
||||
if (head != Cnil && CDR(head) != Cnil)
|
||||
FEprogram_error("DOLIST: Too many output forms.", 0);
|
||||
flags = maybe_values(flags);
|
||||
if (Null(head)) {
|
||||
compile_body(Cnil, flags);
|
||||
} else {
|
||||
compile_setq(OP_SETQ, var);
|
||||
compile_form(pop(&head), flags);
|
||||
}
|
||||
asm_op(OP_EXIT);
|
||||
|
||||
/* Exit point for block */
|
||||
asm_complete(op, labelz);
|
||||
|
||||
ENV->variables = old_variables;
|
||||
|
||||
return flags;
|
||||
}
|
||||
|
||||
|
||||
static int
|
||||
c_dolist(cl_object args, int flags) {
|
||||
return c_dolist_dotimes(OP_DOLIST, args, flags);
|
||||
c_while(cl_object body, int flags) {
|
||||
return c_while_until(body, flags, 1);
|
||||
}
|
||||
|
||||
static int
|
||||
c_dotimes(cl_object args, int flags) {
|
||||
return c_dolist_dotimes(OP_DOTIMES, args, flags);
|
||||
c_until(cl_object body, int flags) {
|
||||
return c_while_until(body, flags, 0);
|
||||
}
|
||||
|
||||
static int
|
||||
|
|
@ -1053,7 +972,7 @@ c_eval_when(cl_object args, int flags) {
|
|||
...
|
||||
fun2
|
||||
...
|
||||
OP_EXIT
|
||||
OP_UNBIND n
|
||||
labelz:
|
||||
*/
|
||||
static cl_index
|
||||
|
|
|
|||
|
|
@ -110,70 +110,6 @@ NO_ARGS:
|
|||
|
||||
/* -------------------- DISASSEMBLER CORE -------------------- */
|
||||
|
||||
/* OP_DOLIST labelz, labelo
|
||||
... ; code to bind the local variable
|
||||
OP_EXIT
|
||||
... ; code executed on each iteration
|
||||
OP_EXIT
|
||||
labelo:
|
||||
... ; code executed at the end
|
||||
OP_EXIT
|
||||
labelz:
|
||||
|
||||
High level construct for the DOLIST iterator. The list over which
|
||||
we iterate is stored in VALUES(0).
|
||||
*/
|
||||
static cl_opcode *
|
||||
disassemble_dolist(cl_object bytecodes, cl_opcode *vector) {
|
||||
cl_opcode *exit, *output;
|
||||
cl_object lex_old = cl_env.lex_env;
|
||||
|
||||
GET_LABEL(exit, vector);
|
||||
GET_LABEL(output, vector);
|
||||
print_oparg("DOLIST\t", exit-base);
|
||||
vector = disassemble(bytecodes, vector);
|
||||
print_noarg("\t\t; dolist binding");
|
||||
vector = disassemble(bytecodes, vector);
|
||||
print_noarg("\t\t; dolist body");
|
||||
vector = disassemble(bytecodes, vector);
|
||||
print_noarg("\t\t; dolist");
|
||||
|
||||
cl_env.lex_env = lex_old;
|
||||
return vector;
|
||||
}
|
||||
|
||||
/* OP_TIMES labelz, labelo
|
||||
... ; code to bind the local variable
|
||||
OP_EXIT
|
||||
... ; code executed on each iteration
|
||||
OP_EXIT
|
||||
labelo:
|
||||
... ; code executed at the end
|
||||
OP_EXIT
|
||||
labelz:
|
||||
|
||||
High level construct for the DOTIMES iterator. The number of times
|
||||
we iterate is stored in VALUES(0).
|
||||
*/
|
||||
static cl_opcode *
|
||||
disassemble_dotimes(cl_object bytecodes, cl_opcode *vector) {
|
||||
cl_opcode *exit, *output;
|
||||
cl_object lex_old = cl_env.lex_env;
|
||||
|
||||
GET_LABEL(exit, vector);
|
||||
GET_LABEL(output, vector);
|
||||
print_oparg("DOTIMES\t", exit-base);
|
||||
vector = disassemble(bytecodes, vector);
|
||||
print_noarg("\t\t; dotimes times");
|
||||
vector = disassemble(bytecodes, vector);
|
||||
print_noarg("\t\t; dotimes body");
|
||||
vector = disassemble(bytecodes, vector);
|
||||
print_noarg("\t\t; dotimes");
|
||||
|
||||
cl_env.lex_env = lex_old;
|
||||
return vector;
|
||||
}
|
||||
|
||||
/* OP_FLET nfun{arg}
|
||||
fun1{object}
|
||||
...
|
||||
|
|
@ -474,7 +410,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) {
|
|||
case OP_CATCH: string = "CATCH\t";
|
||||
goto JMP;
|
||||
/* OP_EXIT
|
||||
Marks the end of a high level construct (DOLIST, DOTIMES...)
|
||||
Marks the end of a high level construct
|
||||
*/
|
||||
case OP_EXIT: print_noarg("EXIT");
|
||||
return vector;
|
||||
|
|
@ -655,10 +591,6 @@ disassemble(cl_object bytecodes, cl_opcode *vector) {
|
|||
*/
|
||||
case OP_NTHVAL: string = "NTHVAL\t";
|
||||
goto NOARG;
|
||||
case OP_DOLIST: vector = disassemble_dolist(bytecodes, vector);
|
||||
break;
|
||||
case OP_DOTIMES: vector = disassemble_dotimes(bytecodes, vector);
|
||||
break;
|
||||
/* OP_DO label
|
||||
... ; code executed within a NIL block
|
||||
OP_EXIT_FRAME
|
||||
|
|
|
|||
|
|
@ -446,116 +446,6 @@ interpret_funcall(cl_narg narg, cl_object fun) {
|
|||
|
||||
/* -------------------- THE INTERPRETER -------------------- */
|
||||
|
||||
/* OP_DOLIST labelz, labelo
|
||||
... ; code to bind the local variable
|
||||
OP_EXIT
|
||||
... ; code executed on each iteration
|
||||
OP_EXIT
|
||||
labelo:
|
||||
... ; code executed at the end
|
||||
OP_EXIT
|
||||
labelz:
|
||||
|
||||
High level construct for the DOLIST iterator. The list over which
|
||||
we iterate is stored in VALUES(0).
|
||||
*/
|
||||
static cl_opcode *
|
||||
interpret_dolist(cl_object bytecodes, cl_opcode *vector) {
|
||||
cl_opcode *volatile exit;
|
||||
cl_opcode *output;
|
||||
|
||||
GET_LABEL(exit, vector);
|
||||
GET_LABEL(output, vector);
|
||||
|
||||
/* 1) Set NIL block */
|
||||
CL_BLOCK_BEGIN(id) {
|
||||
cl_object list = VALUES(0);
|
||||
|
||||
bind_block(Cnil, id);
|
||||
|
||||
/* 2) Build list & bind variable*/
|
||||
vector = interpret(bytecodes, vector);
|
||||
|
||||
/* 3) Repeat until list is exahusted */
|
||||
while (!endp(list)) {
|
||||
NVALUES = 1;
|
||||
VALUES(0) = CAR(list);
|
||||
interpret(bytecodes, vector);
|
||||
list = CDR(list);
|
||||
}
|
||||
VALUES(0) = Cnil;
|
||||
NVALUES = 1;
|
||||
interpret(bytecodes, output);
|
||||
|
||||
/* 4) Restore environment */
|
||||
cl_env.lex_env = cl_env.frs_top->frs_lex;
|
||||
bds_unwind(cl_env.frs_top->frs_bds_top);
|
||||
} CL_BLOCK_END;
|
||||
return exit;
|
||||
}
|
||||
|
||||
/* OP_TIMES labelz, labelo
|
||||
... ; code to bind the local variable
|
||||
OP_EXIT
|
||||
... ; code executed on each iteration
|
||||
OP_EXIT
|
||||
labelo:
|
||||
... ; code executed at the end
|
||||
OP_EXIT
|
||||
labelz:
|
||||
|
||||
High level construct for the DOTIMES iterator. The number of times
|
||||
we iterate is stored in VALUES(0).
|
||||
*/
|
||||
static cl_opcode *
|
||||
interpret_dotimes(cl_object bytecodes, cl_opcode *vector) {
|
||||
cl_opcode *volatile exit;
|
||||
cl_opcode *output;
|
||||
|
||||
GET_LABEL(exit, vector);
|
||||
GET_LABEL(output, vector);
|
||||
|
||||
CL_BLOCK_BEGIN(id) {
|
||||
cl_object length = VALUES(0);
|
||||
|
||||
/* 1) Set up a nil block */
|
||||
bind_block(Cnil, id);
|
||||
|
||||
/* 2) Retrieve number and bind variables */
|
||||
vector = interpret(bytecodes, vector);
|
||||
|
||||
if (FIXNUMP(length)) {
|
||||
cl_fixnum i, l = fix(length);
|
||||
/* 3) Loop while needed */
|
||||
for (i = 0; i < l; i++) {
|
||||
NVALUES = 1;
|
||||
VALUES(0) = MAKE_FIXNUM(i);
|
||||
interpret(bytecodes, vector);
|
||||
}
|
||||
length = MAKE_FIXNUM(i);
|
||||
} else {
|
||||
cl_object i;
|
||||
for (i = MAKE_FIXNUM(0);
|
||||
number_compare(i, length) < 0;
|
||||
i = one_plus(i))
|
||||
{
|
||||
NVALUES = 1;
|
||||
VALUES(0) = i;
|
||||
interpret(bytecodes, vector);
|
||||
}
|
||||
length = i;
|
||||
}
|
||||
NVALUES = 1;
|
||||
VALUES(0) = length;
|
||||
interpret(bytecodes, output);
|
||||
|
||||
/* 4) Restore environment */
|
||||
cl_env.lex_env = cl_env.frs_top->frs_lex;
|
||||
bds_unwind(cl_env.frs_top->frs_bds_top);
|
||||
} CL_BLOCK_END;
|
||||
return exit;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
close_around(cl_object fun, cl_object lex) {
|
||||
cl_object v = cl_alloc_object(t_bytecodes);
|
||||
|
|
@ -569,7 +459,7 @@ close_around(cl_object fun, cl_object lex) {
|
|||
...
|
||||
funn{object}
|
||||
...
|
||||
OP_EXIT
|
||||
OP_UNBIND n
|
||||
|
||||
Executes the enclosed code in a lexical enviroment extended with
|
||||
the functions "fun1" ... "funn".
|
||||
|
|
@ -591,12 +481,12 @@ interpret_flet(cl_object bytecodes, cl_opcode *vector) {
|
|||
return vector;
|
||||
}
|
||||
|
||||
/* OP_FLET nfun{arg}
|
||||
/* OP_LABELS nfun{arg}
|
||||
fun1{object}
|
||||
...
|
||||
funn{object}
|
||||
...
|
||||
OP_EXIT
|
||||
OP_UNBIND n
|
||||
|
||||
Executes the enclosed code in a lexical enviroment extended with
|
||||
the functions "fun1" ... "funn".
|
||||
|
|
@ -1055,7 +945,7 @@ interpret(cl_object bytecodes, void *pc) {
|
|||
|
||||
/* OP_BLOCK label{arg}
|
||||
...
|
||||
OP_EXIT
|
||||
OP_EXIT_FRAME
|
||||
label:
|
||||
|
||||
Executes the enclosed code in a named block.
|
||||
|
|
@ -1114,7 +1004,7 @@ interpret(cl_object bytecodes, void *pc) {
|
|||
...
|
||||
labeln:
|
||||
...
|
||||
OP_EXIT
|
||||
OP_EXIT_TAGBODY
|
||||
|
||||
High level construct for the TAGBODY form.
|
||||
*/
|
||||
|
|
@ -1159,14 +1049,6 @@ interpret(cl_object bytecodes, void *pc) {
|
|||
VALUES(0) = reg0 = Cnil;
|
||||
NVALUES = 0;
|
||||
break;
|
||||
case OP_DOLIST:
|
||||
vector = interpret_dolist(bytecodes, vector);
|
||||
reg0 = VALUES(0);
|
||||
break;
|
||||
case OP_DOTIMES:
|
||||
vector = interpret_dotimes(bytecodes, vector);
|
||||
reg0 = VALUES(0);
|
||||
break;
|
||||
case OP_MSETQ:
|
||||
vector = interpret_msetq(bytecodes, vector);
|
||||
reg0 = VALUES(0);
|
||||
|
|
@ -1246,10 +1128,10 @@ interpret(cl_object bytecodes, void *pc) {
|
|||
}
|
||||
/* OP_PROTECT label
|
||||
... ; code to be protected and whose value is output
|
||||
OP_EXIT
|
||||
OP_PROTECT_NORMAL
|
||||
label:
|
||||
... ; code executed at exit
|
||||
OP_EXIT
|
||||
OP_PROTECT_EXIT
|
||||
|
||||
High level construct for UNWIND-PROTECT. The first piece of code is
|
||||
executed and its output value is saved. Then the second piece of code
|
||||
|
|
|
|||
|
|
@ -1524,6 +1524,7 @@ cl_symbols[] = {
|
|||
#endif
|
||||
|
||||
{SYS_ "WHILE", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "UNTIL", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "QUASIQUOTE", SI_ORDINARY, NULL, -1, OBJNULL},
|
||||
{SYS_ "*EXIT-HOOKS*", SI_SPECIAL, NULL, -1, Cnil},
|
||||
|
||||
|
|
|
|||
|
|
@ -1524,6 +1524,7 @@ cl_symbols[] = {
|
|||
#endif
|
||||
|
||||
{SYS_ "WHILE",NULL},
|
||||
{SYS_ "UNTIL",NULL},
|
||||
{SYS_ "QUASIQUOTE",NULL},
|
||||
{SYS_ "*EXIT-HOOKS*",NULL},
|
||||
|
||||
|
|
|
|||
|
|
@ -163,8 +163,6 @@ enum {
|
|||
OP_TAGBODY,
|
||||
OP_EXIT_TAGBODY,
|
||||
OP_EXIT_FRAME,
|
||||
OP_DOLIST,
|
||||
OP_DOTIMES,
|
||||
OP_PROTECT,
|
||||
OP_PROTECT_NORMAL,
|
||||
OP_PROTECT_EXIT,
|
||||
|
|
|
|||
|
|
@ -247,7 +247,8 @@ SECOND-FORM."
|
|||
(defmacro multiple-value-bind (vars form &rest body)
|
||||
`(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)) ,@body) ,form))
|
||||
|
||||
(defmacro sys::while (test &body body)
|
||||
(defun while-until (test body jmp-op)
|
||||
(declare (si::c-local))
|
||||
(let ((label (gensym))
|
||||
(exit (gensym)))
|
||||
`(TAGBODY
|
||||
|
|
@ -255,7 +256,13 @@ SECOND-FORM."
|
|||
,label
|
||||
,@body
|
||||
,exit
|
||||
(UNLESS ,test (GO ,label)))))
|
||||
(,jmp-op ,test (GO ,label)))))
|
||||
|
||||
(defmacro sys::while (test &body body)
|
||||
(while-until test body 'when))
|
||||
|
||||
(defmacro sys::until (test &body body)
|
||||
(while-until test body 'unless))
|
||||
|
||||
(defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
|
||||
(dolist (clause (reverse clauses)
|
||||
|
|
@ -276,25 +283,6 @@ SECOND-FORM."
|
|||
|
||||
(defmacro return (&optional (val nil)) `(RETURN-FROM NIL ,val))
|
||||
|
||||
(defmacro dolist ((var form &optional (val nil)) &rest body
|
||||
&aux (temp (gensym)) decl)
|
||||
(multiple-value-setq (decl body)
|
||||
(find-declarations body))
|
||||
;; Since ENDP did not complain, this is definitely a (CDR ,temp) is safe
|
||||
`(DO* ((,temp ,form (CDR (THE CONS ,temp))) (,var))
|
||||
((ENDP ,temp) ,val)
|
||||
,@decl
|
||||
(SETQ ,var (CAR ,temp))
|
||||
,@body
|
||||
))
|
||||
|
||||
(defmacro dotimes ((var form &optional (val nil)) &rest body
|
||||
&aux (temp (gensym)))
|
||||
`(DO* ((,temp ,form) (,var 0 (1+ ,var)))
|
||||
((>= ,var ,temp) ,val)
|
||||
(DECLARE (FIXNUM ,var)) ; Beppe (:READ-ONLY ,temp)
|
||||
,@body))
|
||||
|
||||
;; Declarations
|
||||
(defmacro declaim (&rest decl-specs)
|
||||
(if (cdr decl-specs)
|
||||
|
|
|
|||
|
|
@ -41,6 +41,56 @@
|
|||
;; This is also needed for booting ECL. In particular it is required in
|
||||
;; defmacro.lsp.
|
||||
;;
|
||||
(let ((f #'(ext::lambda-block dolist (whole env)
|
||||
(let (body pop finished control var expr exit)
|
||||
(setq body (rest whole))
|
||||
(when (endp body)
|
||||
(simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole))
|
||||
(setq control (first body) body (rest body))
|
||||
(when (endp control)
|
||||
(simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole))
|
||||
(setq var (first control) control (rest control))
|
||||
(if (<= 1 (length control) 2)
|
||||
(setq expr (first control) exit (rest control))
|
||||
(simple-program-error "Syntax error in ~A:~%~A" 'DOLIST whole))
|
||||
(multiple-value-bind (declarations body)
|
||||
(process-declarations body nil)
|
||||
`(block nil
|
||||
(let* ((%dolist-var ,expr)
|
||||
,var)
|
||||
(declare ,@declarations)
|
||||
(si::while %dolist-var
|
||||
(setq ,var (first %dolist-var))
|
||||
,@body
|
||||
(setq %dolist-var (rest %dolist-var)))
|
||||
,(when exit `(setq ,var nil))
|
||||
,@exit)))))))
|
||||
(si::fset 'dolist f t))
|
||||
|
||||
(let ((f #'(ext::lambda-block dotimes (whole env)
|
||||
(let (body pop finished control var expr exit)
|
||||
(setq body (rest whole))
|
||||
(when (endp body)
|
||||
(simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole))
|
||||
(setq control (first body) body (rest body))
|
||||
(when (endp control)
|
||||
(simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole))
|
||||
(setq var (first control) control (rest control))
|
||||
(if (<= 1 (length control) 2)
|
||||
(setq expr (first control) exit (rest control))
|
||||
(simple-program-error "Syntax error in ~A:~%~A" 'DOTIMES whole))
|
||||
(multiple-value-bind (declarations body)
|
||||
(process-declarations body nil)
|
||||
`(block nil
|
||||
(let* ((%dotimes-var ,expr)
|
||||
(,var 0))
|
||||
(declare ,@declarations)
|
||||
(si::while (< ,var %dotimes-var)
|
||||
,@body
|
||||
(setq ,var (1+ ,var)))
|
||||
,@exit)))))))
|
||||
(si::fset 'dotimes f t))
|
||||
|
||||
(let ((f #'(ext::lambda-block do/do*-expand (whole env)
|
||||
(let (do/do* control test result vl step let psetq body)
|
||||
(setq do/do* (first whole) body (rest whole))
|
||||
|
|
@ -48,13 +98,13 @@
|
|||
(setq let 'LET psetq 'PSETQ)
|
||||
(setq let 'LET* psetq 'SETQ))
|
||||
(when (endp body)
|
||||
(simple-program-error "Syntax error in DO/DO* body:~%~A" whole))
|
||||
(simple-program-error "Syntax error in ~A:~%~A" do/do* whole))
|
||||
(setq control (first body) body (rest body))
|
||||
(when (endp body)
|
||||
(simple-program-error "Syntax error in DO/DO* body:~%~A" whole))
|
||||
(simple-program-error "Syntax error in ~A:~%~A" do/do* whole))
|
||||
(setq test (first body) body (rest body))
|
||||
(when (endp test)
|
||||
(simple-program-error "Syntax error in DO/DO* body:~%~A" whole))
|
||||
(simple-program-error "Syntax error in ~A:~%~A" do/do* whole))
|
||||
(setq result (rest test) test (first test))
|
||||
(dolist (c control)
|
||||
(when (symbolp c) (setq c (list c)))
|
||||
|
|
@ -65,15 +115,15 @@
|
|||
(setq vl (cons (butlast c) vl)
|
||||
step (list* (third c) (first c) step)))
|
||||
(t
|
||||
(simple-program-error "Syntax error in DO/DO* body:~%~A" whole))))
|
||||
(multiple-value-bind (declarations real-body doc)
|
||||
(simple-program-error "Syntax error in ~A:~%~A" do/do* whole))))
|
||||
(multiple-value-bind (declarations real-body)
|
||||
(process-declarations body nil)
|
||||
`(BLOCK NIL
|
||||
(,let ,(nreverse vl)
|
||||
(declare ,@declarations)
|
||||
(sys::while ,test
|
||||
,@real-body
|
||||
,@(when step (list (cons psetq (nreverse step)))))
|
||||
(sys::until ,test
|
||||
,@real-body
|
||||
,@(when step (list (cons psetq (nreverse step)))))
|
||||
,@(or result '(nil)))))))))
|
||||
(si::fset 'do f t)
|
||||
(si::fset 'do* f t))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue