100 |
* expression is expected, a 'Bad expression' error is signalled. */ |
* expression is expected, a 'Bad expression' error is signalled. */ |
101 |
static const char s_bad_expression[] = "Bad expression"; |
static const char s_bad_expression[] = "Bad expression"; |
102 |
|
|
103 |
|
/* If a form is detected that holds less expressions than are required in that |
104 |
|
* contect, a 'Missing expression' error is signalled. */ |
105 |
|
static const char s_missing_expression[] = "Missing expression in"; |
106 |
|
|
107 |
/* If a form is detected that holds more expressions than are allowed in that |
/* If a form is detected that holds more expressions than are allowed in that |
108 |
* contect, an 'Extra expression' error is signalled. */ |
* contect, an 'Extra expression' error is signalled. */ |
109 |
static const char s_extra_expression[] = "Extra expression in"; |
static const char s_extra_expression[] = "Extra expression in"; |
147 |
* error is signalled. */ |
* error is signalled. */ |
148 |
static const char s_missing_recipient[] = "Missing recipient in"; |
static const char s_missing_recipient[] = "Missing recipient in"; |
149 |
|
|
150 |
|
/* If in a position where a variable name is required some other object is |
151 |
|
* detected, a 'Bad variable' error is signalled. */ |
152 |
|
static const char s_bad_variable[] = "Bad variable"; |
153 |
|
|
154 |
|
|
155 |
/* Signal a syntax error. We distinguish between the form that caused the |
/* Signal a syntax error. We distinguish between the form that caused the |
156 |
* error and the enclosing expression. The error message will print out as |
* error and the enclosing expression. The error message will print out as |
876 |
/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS |
/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS |
877 |
* module that does not implement this extension. */ |
* module that does not implement this extension. */ |
878 |
SCM |
SCM |
879 |
scm_m_define (SCM x, SCM env) |
scm_m_define (SCM expr, SCM env) |
880 |
{ |
{ |
881 |
SCM name; |
SCM body; |
882 |
x = SCM_CDR (x); |
SCM variable; |
883 |
SCM_ASSYNT (scm_ilength (x) >= 2, s_expression, s_define); |
|
884 |
name = SCM_CAR (x); |
const SCM cdr_expr = SCM_CDR (expr); |
885 |
x = SCM_CDR (x); |
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
886 |
while (SCM_CONSP (name)) |
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); |
887 |
{ |
|
888 |
/* This while loop realizes function currying by variable nesting. */ |
body = SCM_CDR (cdr_expr); |
889 |
SCM formals = SCM_CDR (name); |
variable = SCM_CAR (cdr_expr); |
890 |
x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); |
while (SCM_CONSP (variable)) |
891 |
name = SCM_CAR (name); |
{ |
892 |
|
/* This while loop realizes function currying by variable nesting. |
893 |
|
* Variable is known to be a nested-variable. In every iteration of the |
894 |
|
* loop another level of lambda expression is created, starting with the |
895 |
|
* innermost one. */ |
896 |
|
const SCM formals = SCM_CDR (variable); |
897 |
|
const SCM tail = scm_cons (formals, body); |
898 |
|
|
899 |
|
/* Add source properties to each new lambda expression: */ |
900 |
|
const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail); |
901 |
|
|
902 |
|
body = scm_list_1 (lambda); |
903 |
|
variable = SCM_CAR (variable); |
904 |
} |
} |
905 |
SCM_ASSYNT (SCM_SYMBOLP (name), s_variable, s_define); |
ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); |
906 |
SCM_ASSYNT (scm_ilength (x) == 1, s_expression, s_define); |
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); |
907 |
|
|
908 |
if (SCM_TOP_LEVEL (env)) |
if (SCM_TOP_LEVEL (env)) |
909 |
{ |
{ |
910 |
SCM var; |
SCM var; |
911 |
x = scm_eval_car (x, env); |
const SCM value = scm_eval_car (body, env); |
912 |
if (SCM_REC_PROCNAMES_P) |
if (SCM_REC_PROCNAMES_P) |
913 |
{ |
{ |
914 |
SCM tmp = x; |
SCM tmp = value; |
915 |
while (SCM_MACROP (tmp)) |
while (SCM_MACROP (tmp)) |
916 |
tmp = SCM_MACRO_CODE (tmp); |
tmp = SCM_MACRO_CODE (tmp); |
917 |
if (SCM_CLOSUREP (tmp) |
if (SCM_CLOSUREP (tmp) |
918 |
/* Only the first definition determines the name. */ |
/* Only the first definition determines the name. */ |
919 |
&& SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) |
&& SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) |
920 |
scm_set_procedure_property_x (tmp, scm_sym_name, name); |
scm_set_procedure_property_x (tmp, scm_sym_name, variable); |
921 |
} |
} |
922 |
var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); |
var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); |
923 |
SCM_VARIABLE_SET (var, x); |
SCM_VARIABLE_SET (var, value); |
924 |
return SCM_UNSPECIFIED; |
return SCM_UNSPECIFIED; |
925 |
} |
} |
926 |
else |
else |
927 |
return scm_cons2 (SCM_IM_DEFINE, name, x); |
{ |
928 |
|
SCM_SETCAR (expr, SCM_IM_DEFINE); |
929 |
|
SCM_SETCAR (cdr_expr, variable); |
930 |
|
SCM_SETCDR (cdr_expr, body); |
931 |
|
return expr; |
932 |
|
} |
933 |
} |
} |
934 |
|
|
935 |
|
|