452 |
} |
} |
453 |
|
|
454 |
|
|
455 |
SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote); |
/* Start of the memoizers for the standard R5RS builtin macros. */ |
|
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); |
|
|
|
|
|
SCM |
|
|
scm_m_quote (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote); |
|
|
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
|
|
|
SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); |
|
|
|
|
|
SCM |
|
|
scm_m_begin (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin); |
|
|
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
|
|
|
SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); |
|
|
|
|
|
SCM |
|
|
scm_m_if (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
long len = scm_ilength (SCM_CDR (xorig)); |
|
|
SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if); |
|
|
return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
|
|
|
/* Will go into the RnRS module when Guile is factorized. |
|
|
SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */ |
|
|
static const char s_set_x[] = "set!"; |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); |
|
|
|
|
|
SCM |
|
|
scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM x = SCM_CDR (xorig); |
|
|
SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x); |
|
|
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x); |
|
|
return scm_cons (SCM_IM_SET_X, x); |
|
|
} |
|
456 |
|
|
457 |
|
|
458 |
SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and); |
SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and); |
470 |
} |
} |
471 |
|
|
472 |
|
|
473 |
SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or); |
SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin); |
474 |
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); |
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); |
475 |
|
|
476 |
SCM |
SCM |
477 |
scm_m_or (SCM xorig, SCM env SCM_UNUSED) |
scm_m_begin (SCM xorig, SCM env SCM_UNUSED) |
478 |
{ |
{ |
479 |
long len = scm_ilength (SCM_CDR (xorig)); |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin); |
480 |
SCM_ASSYNT (len >= 0, scm_s_test, s_or); |
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); |
|
if (len >= 1) |
|
|
return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); |
|
|
else |
|
|
return SCM_BOOL_F; |
|
481 |
} |
} |
482 |
|
|
483 |
|
|
535 |
} |
} |
536 |
|
|
537 |
|
|
538 |
SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda); |
SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); |
539 |
SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); |
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); |
540 |
|
|
541 |
/* Return true if OBJ is `eq?' to one of the elements of LIST or to the |
/* Guile provides an extension to R5RS' define syntax to represent function |
542 |
* cdr of the last cons. (Thus, LIST is not required to be a proper |
* currying in a compact way. With this extension, it is allowed to write |
543 |
* list and OBJ can also be found in the improper ending.) */ |
* (define <nested-variable> <body>), where <nested-variable> has of one of |
544 |
static int |
* the forms (<nested-variable> <formals>), (<nested-variable> . <formal>), |
545 |
scm_c_improper_memq (SCM obj, SCM list) |
* (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals> |
546 |
|
* should be either a sequence of zero or more variables, or a sequence of one |
547 |
|
* or more variables followed by a space-delimited period and another |
548 |
|
* variable. Each level of argument nesting wraps the <body> within another |
549 |
|
* lambda expression. For example, the following forms are allowed, each one |
550 |
|
* followed by an equivalent, more explicit implementation. |
551 |
|
* Example 1: |
552 |
|
* (define ((a b . c) . d) <body>) is equivalent to |
553 |
|
* (define a (lambda (b . c) (lambda d <body>))) |
554 |
|
* Example 2: |
555 |
|
* (define (((a) b) c . d) <body>) is equivalent to |
556 |
|
* (define a (lambda () (lambda (b) (lambda (c . d) <body>)))) |
557 |
|
*/ |
558 |
|
/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS |
559 |
|
* module that does not implement this extension. */ |
560 |
|
SCM |
561 |
|
scm_m_define (SCM x, SCM env) |
562 |
{ |
{ |
563 |
for (; SCM_CONSP (list); list = SCM_CDR (list)) |
SCM name; |
564 |
|
x = SCM_CDR (x); |
565 |
|
SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define); |
566 |
|
name = SCM_CAR (x); |
567 |
|
x = SCM_CDR (x); |
568 |
|
while (SCM_CONSP (name)) |
569 |
{ |
{ |
570 |
if (SCM_EQ_P (SCM_CAR (list), obj)) |
/* This while loop realizes function currying by variable nesting. */ |
571 |
return 1; |
SCM formals = SCM_CDR (name); |
572 |
|
x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); |
573 |
|
name = SCM_CAR (name); |
574 |
} |
} |
575 |
return SCM_EQ_P (list, obj); |
SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define); |
576 |
} |
SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define); |
577 |
|
if (SCM_TOP_LEVEL (env)) |
|
SCM |
|
|
scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM formals; |
|
|
SCM x = SCM_CDR (xorig); |
|
|
|
|
|
SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda); |
|
|
|
|
|
formals = SCM_CAR (x); |
|
|
while (SCM_CONSP (formals)) |
|
578 |
{ |
{ |
579 |
SCM formal = SCM_CAR (formals); |
SCM var; |
580 |
SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda); |
x = scm_eval_car (x, env); |
581 |
if (scm_c_improper_memq (formal, SCM_CDR (formals))) |
if (SCM_REC_PROCNAMES_P) |
582 |
scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); |
{ |
583 |
formals = SCM_CDR (formals); |
SCM tmp = x; |
584 |
|
while (SCM_MACROP (tmp)) |
585 |
|
tmp = SCM_MACRO_CODE (tmp); |
586 |
|
if (SCM_CLOSUREP (tmp) |
587 |
|
/* Only the first definition determines the name. */ |
588 |
|
&& SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) |
589 |
|
scm_set_procedure_property_x (tmp, scm_sym_name, name); |
590 |
|
} |
591 |
|
var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); |
592 |
|
SCM_VARIABLE_SET (var, x); |
593 |
|
return SCM_UNSPECIFIED; |
594 |
} |
} |
595 |
if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals)) |
else |
596 |
scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); |
return scm_cons2 (SCM_IM_DEFINE, name, x); |
|
|
|
|
return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x), |
|
|
scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda)); |
|
597 |
} |
} |
598 |
|
|
599 |
|
|
600 |
SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar); |
SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); |
601 |
SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); |
SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); |
602 |
|
|
603 |
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers |
/* Promises are implemented as closures with an empty parameter list. Thus, |
604 |
* i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */ |
* (delay <expression>) is transformed into (#@delay '() <expression>), where |
605 |
|
* the empty list represents the empty parameter list. This representation |
606 |
|
* allows for easy creation of the closure during evaluation. */ |
607 |
SCM |
SCM |
608 |
scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) |
scm_m_delay (SCM xorig, SCM env SCM_UNUSED) |
609 |
{ |
{ |
610 |
SCM bindings; |
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); |
611 |
SCM x = SCM_CDR (xorig); |
return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); |
|
SCM vars = SCM_EOL; |
|
|
SCM *varloc = &vars; |
|
|
|
|
|
SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar); |
|
|
|
|
|
bindings = SCM_CAR (x); |
|
|
SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar); |
|
|
while (!SCM_NULLP (bindings)) |
|
|
{ |
|
|
SCM binding = SCM_CAR (bindings); |
|
|
SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar); |
|
|
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar); |
|
|
*varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding)); |
|
|
varloc = SCM_CDRLOC (SCM_CDR (*varloc)); |
|
|
bindings = SCM_CDR (bindings); |
|
|
} |
|
|
|
|
|
return scm_cons2 (SCM_IM_LETSTAR, vars, |
|
|
scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); |
|
612 |
} |
} |
613 |
|
|
614 |
|
|
673 |
} |
} |
674 |
|
|
675 |
|
|
676 |
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); |
SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if); |
677 |
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); |
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); |
|
|
|
|
/* Internal function to handle a quasiquotation: 'form' is the parameter in |
|
|
* the call (quasiquotation form), 'env' is the environment where unquoted |
|
|
* expressions will be evaluated, and 'depth' is the current quasiquotation |
|
|
* nesting level and is known to be greater than zero. */ |
|
|
static SCM |
|
|
iqq (SCM form, SCM env, unsigned long int depth) |
|
|
{ |
|
|
if (SCM_CONSP (form)) |
|
|
{ |
|
|
SCM tmp = SCM_CAR (form); |
|
|
if (SCM_EQ_P (tmp, scm_sym_quasiquote)) |
|
|
{ |
|
|
SCM args = SCM_CDR (form); |
|
|
SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); |
|
|
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); |
|
|
} |
|
|
else if (SCM_EQ_P (tmp, scm_sym_unquote)) |
|
|
{ |
|
|
SCM args = SCM_CDR (form); |
|
|
SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); |
|
|
if (depth - 1 == 0) |
|
|
return scm_eval_car (args, env); |
|
|
else |
|
|
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1)); |
|
|
} |
|
|
else if (SCM_CONSP (tmp) |
|
|
&& SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) |
|
|
{ |
|
|
SCM args = SCM_CDR (tmp); |
|
|
SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); |
|
|
if (depth - 1 == 0) |
|
|
{ |
|
|
SCM list = scm_eval_car (args, env); |
|
|
SCM rest = SCM_CDR (form); |
|
|
SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote); |
|
|
return scm_append (scm_list_2 (list, iqq (rest, env, depth))); |
|
|
} |
|
|
else |
|
|
return scm_cons (iqq (SCM_CAR (form), env, depth - 1), |
|
|
iqq (SCM_CDR (form), env, depth)); |
|
|
} |
|
|
else |
|
|
return scm_cons (iqq (SCM_CAR (form), env, depth), |
|
|
iqq (SCM_CDR (form), env, depth)); |
|
|
} |
|
|
else if (SCM_VECTORP (form)) |
|
|
{ |
|
|
size_t i = SCM_VECTOR_LENGTH (form); |
|
|
SCM const *const data = SCM_VELTS (form); |
|
|
SCM tmp = SCM_EOL; |
|
|
while (i != 0) |
|
|
tmp = scm_cons (data[--i], tmp); |
|
|
scm_remember_upto_here_1 (form); |
|
|
return scm_vector (iqq (tmp, env, depth)); |
|
|
} |
|
|
else |
|
|
return form; |
|
|
} |
|
|
|
|
|
SCM |
|
|
scm_m_quasiquote (SCM xorig, SCM env) |
|
|
{ |
|
|
SCM x = SCM_CDR (xorig); |
|
|
SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote); |
|
|
return iqq (SCM_CAR (x), env, 1); |
|
|
} |
|
|
|
|
|
|
|
|
SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); |
|
678 |
|
|
|
/* Promises are implemented as closures with an empty parameter list. Thus, |
|
|
* (delay <expression>) is transformed into (#@delay '() <expression>), where |
|
|
* the empty list represents the empty parameter list. This representation |
|
|
* allows for easy creation of the closure during evaluation. */ |
|
679 |
SCM |
SCM |
680 |
scm_m_delay (SCM xorig, SCM env SCM_UNUSED) |
scm_m_if (SCM xorig, SCM env SCM_UNUSED) |
681 |
{ |
{ |
682 |
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); |
long len = scm_ilength (SCM_CDR (xorig)); |
683 |
return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); |
SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if); |
684 |
|
return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); |
685 |
} |
} |
686 |
|
|
687 |
|
|
688 |
SCM_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x); |
SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda); |
689 |
SCM_SYMBOL (scm_sym_setter, "setter"); |
SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); |
690 |
|
|
691 |
SCM |
/* Return true if OBJ is `eq?' to one of the elements of LIST or to the |
692 |
scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) |
* cdr of the last cons. (Thus, LIST is not required to be a proper |
693 |
|
* list and OBJ can also be found in the improper ending.) */ |
694 |
|
static int |
695 |
|
scm_c_improper_memq (SCM obj, SCM list) |
696 |
{ |
{ |
697 |
SCM x = SCM_CDR (xorig); |
for (; SCM_CONSP (list); list = SCM_CDR (list)) |
698 |
SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x); |
{ |
699 |
if (SCM_SYMBOLP (SCM_CAR (x))) |
if (SCM_EQ_P (SCM_CAR (list), obj)) |
700 |
return scm_cons (SCM_IM_SET_X, x); |
return 1; |
701 |
else if (SCM_CONSP (SCM_CAR (x))) |
} |
702 |
return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)), |
return SCM_EQ_P (list, obj); |
|
scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x)))); |
|
|
else |
|
|
scm_misc_error (s_set_x, scm_s_variable, SCM_EOL); |
|
703 |
} |
} |
704 |
|
|
|
|
|
|
SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future); |
|
|
SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); |
|
|
|
|
|
/* Like promises, futures are implemented as closures with an empty |
|
|
* parameter list. Thus, (future <expression>) is transformed into |
|
|
* (#@future '() <expression>), where the empty list represents the |
|
|
* empty parameter list. This representation allows for easy creation |
|
|
* of the closure during evaluation. */ |
|
705 |
SCM |
SCM |
706 |
scm_m_future (SCM xorig, SCM env SCM_UNUSED) |
scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) |
707 |
{ |
{ |
708 |
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future); |
SCM formals; |
709 |
return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig)); |
SCM x = SCM_CDR (xorig); |
|
} |
|
|
|
|
710 |
|
|
711 |
SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); |
SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda); |
|
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); |
|
712 |
|
|
713 |
/* Guile provides an extension to R5RS' define syntax to represent function |
formals = SCM_CAR (x); |
714 |
* currying in a compact way. With this extension, it is allowed to write |
while (SCM_CONSP (formals)) |
|
* (define <nested-variable> <body>), where <nested-variable> has of one of |
|
|
* the forms (<nested-variable> <formals>), (<nested-variable> . <formal>), |
|
|
* (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals> |
|
|
* should be either a sequence of zero or more variables, or a sequence of one |
|
|
* or more variables followed by a space-delimited period and another |
|
|
* variable. Each level of argument nesting wraps the <body> within another |
|
|
* lambda expression. For example, the following forms are allowed, each one |
|
|
* followed by an equivalent, more explicit implementation. |
|
|
* Example 1: |
|
|
* (define ((a b . c) . d) <body>) is equivalent to |
|
|
* (define a (lambda (b . c) (lambda d <body>))) |
|
|
* Example 2: |
|
|
* (define (((a) b) c . d) <body>) is equivalent to |
|
|
* (define a (lambda () (lambda (b) (lambda (c . d) <body>)))) |
|
|
*/ |
|
|
/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS |
|
|
* module that does not implement this extension. */ |
|
|
SCM |
|
|
scm_m_define (SCM x, SCM env) |
|
|
{ |
|
|
SCM name; |
|
|
x = SCM_CDR (x); |
|
|
SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define); |
|
|
name = SCM_CAR (x); |
|
|
x = SCM_CDR (x); |
|
|
while (SCM_CONSP (name)) |
|
|
{ |
|
|
/* This while loop realizes function currying by variable nesting. */ |
|
|
SCM formals = SCM_CDR (name); |
|
|
x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); |
|
|
name = SCM_CAR (name); |
|
|
} |
|
|
SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define); |
|
|
SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define); |
|
|
if (SCM_TOP_LEVEL (env)) |
|
715 |
{ |
{ |
716 |
SCM var; |
SCM formal = SCM_CAR (formals); |
717 |
x = scm_eval_car (x, env); |
SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda); |
718 |
if (SCM_REC_PROCNAMES_P) |
if (scm_c_improper_memq (formal, SCM_CDR (formals))) |
719 |
{ |
scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); |
720 |
SCM tmp = x; |
formals = SCM_CDR (formals); |
|
while (SCM_MACROP (tmp)) |
|
|
tmp = SCM_MACRO_CODE (tmp); |
|
|
if (SCM_CLOSUREP (tmp) |
|
|
/* Only the first definition determines the name. */ |
|
|
&& SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) |
|
|
scm_set_procedure_property_x (tmp, scm_sym_name, name); |
|
|
} |
|
|
var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); |
|
|
SCM_VARIABLE_SET (var, x); |
|
|
return SCM_UNSPECIFIED; |
|
721 |
} |
} |
722 |
else |
if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals)) |
723 |
return scm_cons2 (SCM_IM_DEFINE, name, x); |
scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); |
724 |
|
|
725 |
|
return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x), |
726 |
|
scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda)); |
727 |
} |
} |
728 |
|
|
729 |
|
|
757 |
} |
} |
758 |
|
|
759 |
|
|
|
SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); |
|
|
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); |
|
|
|
|
|
SCM |
|
|
scm_m_letrec (SCM xorig, SCM env) |
|
|
{ |
|
|
SCM x = SCM_CDR (xorig); |
|
|
SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec); |
|
|
|
|
|
if (SCM_NULLP (SCM_CAR (x))) |
|
|
{ |
|
|
/* null binding, let* faster */ |
|
|
SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec); |
|
|
return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env); |
|
|
} |
|
|
else |
|
|
{ |
|
|
SCM rvars, inits, body; |
|
|
transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec"); |
|
|
body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec"); |
|
|
return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); |
|
|
} |
|
|
} |
|
|
|
|
|
|
|
760 |
SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let); |
SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let); |
761 |
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); |
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); |
762 |
|
|
827 |
} |
} |
828 |
|
|
829 |
|
|
830 |
SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply); |
SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar); |
831 |
SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); |
SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); |
|
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); |
|
832 |
|
|
833 |
SCM |
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers |
834 |
scm_m_apply (SCM xorig, SCM env SCM_UNUSED) |
* i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */ |
835 |
|
SCM |
836 |
|
scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) |
837 |
{ |
{ |
838 |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply); |
SCM bindings; |
839 |
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); |
SCM x = SCM_CDR (xorig); |
840 |
} |
SCM vars = SCM_EOL; |
841 |
|
SCM *varloc = &vars; |
842 |
|
|
843 |
|
SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar); |
844 |
|
|
845 |
SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont); |
bindings = SCM_CAR (x); |
846 |
SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); |
SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar); |
847 |
|
while (!SCM_NULLP (bindings)) |
848 |
|
{ |
849 |
|
SCM binding = SCM_CAR (bindings); |
850 |
|
SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar); |
851 |
|
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar); |
852 |
|
*varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding)); |
853 |
|
varloc = SCM_CDRLOC (SCM_CDR (*varloc)); |
854 |
|
bindings = SCM_CDR (bindings); |
855 |
|
} |
856 |
|
|
857 |
|
return scm_cons2 (SCM_IM_LETSTAR, vars, |
858 |
|
scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); |
859 |
|
} |
860 |
|
|
861 |
|
|
862 |
|
SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); |
863 |
|
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); |
864 |
|
|
865 |
SCM |
SCM |
866 |
scm_m_cont (SCM xorig, SCM env SCM_UNUSED) |
scm_m_letrec (SCM xorig, SCM env) |
867 |
{ |
{ |
868 |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, |
SCM x = SCM_CDR (xorig); |
869 |
scm_s_expression, s_atcall_cc); |
SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec); |
870 |
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); |
|
871 |
|
if (SCM_NULLP (SCM_CAR (x))) |
872 |
|
{ |
873 |
|
/* null binding, let* faster */ |
874 |
|
SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec); |
875 |
|
return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env); |
876 |
|
} |
877 |
|
else |
878 |
|
{ |
879 |
|
SCM rvars, inits, body; |
880 |
|
transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec"); |
881 |
|
body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec"); |
882 |
|
return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); |
883 |
|
} |
884 |
} |
} |
885 |
|
|
|
#if SCM_ENABLE_ELISP |
|
886 |
|
|
887 |
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); |
SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or); |
888 |
|
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); |
889 |
|
|
890 |
SCM |
SCM |
891 |
scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) |
scm_m_or (SCM xorig, SCM env SCM_UNUSED) |
892 |
{ |
{ |
893 |
long len = scm_ilength (SCM_CDR (xorig)); |
long len = scm_ilength (SCM_CDR (xorig)); |
894 |
SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); |
SCM_ASSYNT (len >= 0, scm_s_test, s_or); |
895 |
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); |
if (len >= 1) |
896 |
|
return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); |
897 |
|
else |
898 |
|
return SCM_BOOL_F; |
899 |
} |
} |
900 |
|
|
|
SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); |
|
901 |
|
|
902 |
SCM |
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); |
903 |
scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) |
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); |
904 |
|
|
905 |
|
/* Internal function to handle a quasiquotation: 'form' is the parameter in |
906 |
|
* the call (quasiquotation form), 'env' is the environment where unquoted |
907 |
|
* expressions will be evaluated, and 'depth' is the current quasiquotation |
908 |
|
* nesting level and is known to be greater than zero. */ |
909 |
|
static SCM |
910 |
|
iqq (SCM form, SCM env, unsigned long int depth) |
911 |
{ |
{ |
912 |
SCM x = SCM_CDR (xorig), var; |
if (SCM_CONSP (form)) |
|
SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); |
|
|
var = scm_symbol_fref (SCM_CAR (x)); |
|
|
/* Passing the symbol name as the `subr' arg here isn't really |
|
|
right, but without it it can be very difficult to work out from |
|
|
the error message which function definition was missing. In any |
|
|
case, we shouldn't really use SCM_ASSYNT here at all, but instead |
|
|
something equivalent to (signal void-function (list SYM)) in |
|
|
Elisp. */ |
|
|
SCM_ASSYNT (SCM_VARIABLEP (var), |
|
|
"Symbol's function definition is void", |
|
|
SCM_SYMBOL_CHARS (SCM_CAR (x))); |
|
|
/* Support `defalias'. */ |
|
|
while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) |
|
913 |
{ |
{ |
914 |
var = scm_symbol_fref (SCM_VARIABLE_REF (var)); |
SCM tmp = SCM_CAR (form); |
915 |
SCM_ASSYNT (SCM_VARIABLEP (var), |
if (SCM_EQ_P (tmp, scm_sym_quasiquote)) |
916 |
"Symbol's function definition is void", |
{ |
917 |
SCM_SYMBOL_CHARS (SCM_CAR (x))); |
SCM args = SCM_CDR (form); |
918 |
|
SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); |
919 |
|
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); |
920 |
|
} |
921 |
|
else if (SCM_EQ_P (tmp, scm_sym_unquote)) |
922 |
|
{ |
923 |
|
SCM args = SCM_CDR (form); |
924 |
|
SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); |
925 |
|
if (depth - 1 == 0) |
926 |
|
return scm_eval_car (args, env); |
927 |
|
else |
928 |
|
return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1)); |
929 |
|
} |
930 |
|
else if (SCM_CONSP (tmp) |
931 |
|
&& SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) |
932 |
|
{ |
933 |
|
SCM args = SCM_CDR (tmp); |
934 |
|
SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); |
935 |
|
if (depth - 1 == 0) |
936 |
|
{ |
937 |
|
SCM list = scm_eval_car (args, env); |
938 |
|
SCM rest = SCM_CDR (form); |
939 |
|
SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote); |
940 |
|
return scm_append (scm_list_2 (list, iqq (rest, env, depth))); |
941 |
|
} |
942 |
|
else |
943 |
|
return scm_cons (iqq (SCM_CAR (form), env, depth - 1), |
944 |
|
iqq (SCM_CDR (form), env, depth)); |
945 |
|
} |
946 |
|
else |
947 |
|
return scm_cons (iqq (SCM_CAR (form), env, depth), |
948 |
|
iqq (SCM_CDR (form), env, depth)); |
949 |
} |
} |
950 |
/* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the |
else if (SCM_VECTORP (form)) |
|
former allows for automatically picking up redefinitions of the |
|
|
corresponding symbol. */ |
|
|
SCM_SETCAR (x, var); |
|
|
/* If the variable contains a procedure, leave the |
|
|
`transformer-macro' in place so that the procedure's arguments |
|
|
get properly transformed, and change the initial @fop to |
|
|
SCM_IM_APPLY. */ |
|
|
if (!SCM_MACROP (SCM_VARIABLE_REF (var))) |
|
951 |
{ |
{ |
952 |
SCM_SETCAR (xorig, SCM_IM_APPLY); |
size_t i = SCM_VECTOR_LENGTH (form); |
953 |
return xorig; |
SCM const *const data = SCM_VELTS (form); |
954 |
|
SCM tmp = SCM_EOL; |
955 |
|
while (i != 0) |
956 |
|
tmp = scm_cons (data[--i], tmp); |
957 |
|
scm_remember_upto_here_1 (form); |
958 |
|
return scm_vector (iqq (tmp, env, depth)); |
959 |
} |
} |
960 |
/* Otherwise (the variable contains a macro), the arguments should |
else |
961 |
not be transformed, so cut the `transformer-macro' out and return |
return form; |
962 |
the resulting expression starting with the variable. */ |
} |
963 |
SCM_SETCDR (x, SCM_CDADR (x)); |
|
964 |
return x; |
SCM |
965 |
|
scm_m_quasiquote (SCM xorig, SCM env) |
966 |
|
{ |
967 |
|
SCM x = SCM_CDR (xorig); |
968 |
|
SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote); |
969 |
|
return iqq (SCM_CAR (x), env, 1); |
970 |
|
} |
971 |
|
|
972 |
|
|
973 |
|
SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote); |
974 |
|
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); |
975 |
|
|
976 |
|
SCM |
977 |
|
scm_m_quote (SCM xorig, SCM env SCM_UNUSED) |
978 |
|
{ |
979 |
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote); |
980 |
|
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); |
981 |
|
} |
982 |
|
|
983 |
|
|
984 |
|
/* Will go into the RnRS module when Guile is factorized. |
985 |
|
SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */ |
986 |
|
static const char s_set_x[] = "set!"; |
987 |
|
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); |
988 |
|
|
989 |
|
SCM |
990 |
|
scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) |
991 |
|
{ |
992 |
|
SCM x = SCM_CDR (xorig); |
993 |
|
SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x); |
994 |
|
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x); |
995 |
|
return scm_cons (SCM_IM_SET_X, x); |
996 |
|
} |
997 |
|
|
998 |
|
|
999 |
|
/* Start of the memoizers for non-R5RS builtin macros. */ |
1000 |
|
|
1001 |
|
|
1002 |
|
SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply); |
1003 |
|
SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); |
1004 |
|
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); |
1005 |
|
|
1006 |
|
SCM |
1007 |
|
scm_m_apply (SCM xorig, SCM env SCM_UNUSED) |
1008 |
|
{ |
1009 |
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply); |
1010 |
|
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); |
1011 |
} |
} |
1012 |
|
|
|
#endif /* SCM_ENABLE_ELISP */ |
|
1013 |
|
|
1014 |
/* (@bind ((var exp) ...) body ...) |
/* (@bind ((var exp) ...) body ...) |
1015 |
|
|
1064 |
SCM_CDDR (xorig))); |
SCM_CDDR (xorig))); |
1065 |
} |
} |
1066 |
|
|
|
SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); |
|
1067 |
|
|
1068 |
SCM |
SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont); |
1069 |
scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED) |
SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); |
1070 |
#define FUNC_NAME s_atslot_ref |
|
1071 |
|
|
1072 |
|
SCM |
1073 |
|
scm_m_cont (SCM xorig, SCM env SCM_UNUSED) |
1074 |
{ |
{ |
1075 |
SCM x = SCM_CDR (xorig); |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, |
1076 |
SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME); |
scm_s_expression, s_atcall_cc); |
1077 |
SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); |
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); |
|
return scm_cons (SCM_IM_SLOT_REF, x); |
|
1078 |
} |
} |
|
#undef FUNC_NAME |
|
1079 |
|
|
1080 |
|
|
1081 |
SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x); |
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values); |
1082 |
|
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); |
1083 |
|
|
1084 |
SCM |
SCM |
1085 |
scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED) |
scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED) |
|
#define FUNC_NAME s_atslot_set_x |
|
1086 |
{ |
{ |
1087 |
SCM x = SCM_CDR (xorig); |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, |
1088 |
SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME); |
scm_s_expression, s_at_call_with_values); |
1089 |
SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); |
return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig)); |
|
return scm_cons (SCM_IM_SLOT_SET_X, x); |
|
1090 |
} |
} |
|
#undef FUNC_NAME |
|
1091 |
|
|
1092 |
|
|
1093 |
SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch); |
SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch); |
1118 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1119 |
|
|
1120 |
|
|
1121 |
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values); |
SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future); |
1122 |
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); |
SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); |
1123 |
|
|
1124 |
|
/* Like promises, futures are implemented as closures with an empty |
1125 |
|
* parameter list. Thus, (future <expression>) is transformed into |
1126 |
|
* (#@future '() <expression>), where the empty list represents the |
1127 |
|
* empty parameter list. This representation allows for easy creation |
1128 |
|
* of the closure during evaluation. */ |
1129 |
SCM |
SCM |
1130 |
scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED) |
scm_m_future (SCM xorig, SCM env SCM_UNUSED) |
1131 |
{ |
{ |
1132 |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, |
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future); |
1133 |
scm_s_expression, s_at_call_with_values); |
return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig)); |
|
return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig)); |
|
1134 |
} |
} |
1135 |
|
|
1136 |
|
|
1137 |
|
SCM_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x); |
1138 |
|
SCM_SYMBOL (scm_sym_setter, "setter"); |
1139 |
|
|
1140 |
|
SCM |
1141 |
|
scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) |
1142 |
|
{ |
1143 |
|
SCM x = SCM_CDR (xorig); |
1144 |
|
SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x); |
1145 |
|
if (SCM_SYMBOLP (SCM_CAR (x))) |
1146 |
|
return scm_cons (SCM_IM_SET_X, x); |
1147 |
|
else if (SCM_CONSP (SCM_CAR (x))) |
1148 |
|
return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)), |
1149 |
|
scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x)))); |
1150 |
|
else |
1151 |
|
scm_misc_error (s_set_x, scm_s_variable, SCM_EOL); |
1152 |
|
} |
1153 |
|
|
1154 |
|
|
1155 |
|
SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref); |
1156 |
|
|
1157 |
|
SCM |
1158 |
|
scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED) |
1159 |
|
#define FUNC_NAME s_atslot_ref |
1160 |
|
{ |
1161 |
|
SCM x = SCM_CDR (xorig); |
1162 |
|
SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME); |
1163 |
|
SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); |
1164 |
|
return scm_cons (SCM_IM_SLOT_REF, x); |
1165 |
|
} |
1166 |
|
#undef FUNC_NAME |
1167 |
|
|
1168 |
|
|
1169 |
|
SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x); |
1170 |
|
|
1171 |
|
SCM |
1172 |
|
scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED) |
1173 |
|
#define FUNC_NAME s_atslot_set_x |
1174 |
|
{ |
1175 |
|
SCM x = SCM_CDR (xorig); |
1176 |
|
SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME); |
1177 |
|
SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x)); |
1178 |
|
return scm_cons (SCM_IM_SLOT_SET_X, x); |
1179 |
|
} |
1180 |
|
#undef FUNC_NAME |
1181 |
|
|
1182 |
|
|
1183 |
|
#if SCM_ENABLE_ELISP |
1184 |
|
|
1185 |
|
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); |
1186 |
|
|
1187 |
|
SCM |
1188 |
|
scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) |
1189 |
|
{ |
1190 |
|
long len = scm_ilength (SCM_CDR (xorig)); |
1191 |
|
SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); |
1192 |
|
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); |
1193 |
|
} |
1194 |
|
|
1195 |
|
|
1196 |
|
SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); |
1197 |
|
|
1198 |
|
SCM |
1199 |
|
scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) |
1200 |
|
{ |
1201 |
|
SCM x = SCM_CDR (xorig), var; |
1202 |
|
SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); |
1203 |
|
var = scm_symbol_fref (SCM_CAR (x)); |
1204 |
|
/* Passing the symbol name as the `subr' arg here isn't really |
1205 |
|
right, but without it it can be very difficult to work out from |
1206 |
|
the error message which function definition was missing. In any |
1207 |
|
case, we shouldn't really use SCM_ASSYNT here at all, but instead |
1208 |
|
something equivalent to (signal void-function (list SYM)) in |
1209 |
|
Elisp. */ |
1210 |
|
SCM_ASSYNT (SCM_VARIABLEP (var), |
1211 |
|
"Symbol's function definition is void", |
1212 |
|
SCM_SYMBOL_CHARS (SCM_CAR (x))); |
1213 |
|
/* Support `defalias'. */ |
1214 |
|
while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) |
1215 |
|
{ |
1216 |
|
var = scm_symbol_fref (SCM_VARIABLE_REF (var)); |
1217 |
|
SCM_ASSYNT (SCM_VARIABLEP (var), |
1218 |
|
"Symbol's function definition is void", |
1219 |
|
SCM_SYMBOL_CHARS (SCM_CAR (x))); |
1220 |
|
} |
1221 |
|
/* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the |
1222 |
|
former allows for automatically picking up redefinitions of the |
1223 |
|
corresponding symbol. */ |
1224 |
|
SCM_SETCAR (x, var); |
1225 |
|
/* If the variable contains a procedure, leave the |
1226 |
|
`transformer-macro' in place so that the procedure's arguments |
1227 |
|
get properly transformed, and change the initial @fop to |
1228 |
|
SCM_IM_APPLY. */ |
1229 |
|
if (!SCM_MACROP (SCM_VARIABLE_REF (var))) |
1230 |
|
{ |
1231 |
|
SCM_SETCAR (xorig, SCM_IM_APPLY); |
1232 |
|
return xorig; |
1233 |
|
} |
1234 |
|
/* Otherwise (the variable contains a macro), the arguments should |
1235 |
|
not be transformed, so cut the `transformer-macro' out and return |
1236 |
|
the resulting expression starting with the variable. */ |
1237 |
|
SCM_SETCDR (x, SCM_CDADR (x)); |
1238 |
|
return x; |
1239 |
|
} |
1240 |
|
|
1241 |
|
#endif /* SCM_ENABLE_ELISP */ |
1242 |
|
|
1243 |
|
|
1244 |
SCM |
SCM |
1245 |
scm_m_expand_body (SCM xorig, SCM env) |
scm_m_expand_body (SCM xorig, SCM env) |
1246 |
{ |
{ |