conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Src/syntax.c

408 lines
11 KiB
C
Raw Blame History

/*
*
* s y n t a x . c -- Syntaxic forms implementation
*
* Copyright © 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, and/or distribute this software and its
* documentation for any purpose and without fee is hereby granted, provided
* that both the above copyright notice and this permission notice appear in
* all copies and derived works. Fees for distribution or use of this
* software or derived works may only be charged with express written
* permission of the copyright holder.
* This software is provided ``as is'' without express or implied warranty.
*
* This software is a derivative work of other copyrighted softwares; the
* copyright notices of these softwares are placed in the file COPYRIGHTS
*
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 25-Oct-1993 23:39
* Last file update: 19-Sep-1995 11:49
*/
/* Notes:
* ------
* C functions syntax_xxx implement the scheme syntax xxx. A syntax function
* returns its work in its first argument (SCM *pform). The function result
* is a boolean. If false, it indicates to eval that this result is
* a final one (eval can return it unmodified). Otherwise, the eval function
* take the result stored in *pform and evaluates it again (in the same eval
* frame). This mechanaism permits to treat tail recursive calls as jump in
* the eval function.
*
* Syntax function which returns EVALCAR(zzzz) are not tail recursive in debug
* mode (in normal mode only the first call is non tail recursive, since this
* first call will replace the original code by an equivalent code which is
* clean on tail recursive calls.
*
*/
#include "stk.h"
#ifdef COMPACT_SMALL_CST
# define makecell(type) ((SCM) MAKE_SMALL_CST(0, type))
#else
static SCM makecell(int type)
{
register SCM z;
NEWCELL(z, type);
return z;
}
#endif
static SCM define2lambda(SCM l, int len)
{
/* transform (define (f p) b) in (define f (lambda (p) b)) */
if (CONSP(l) && CONSP(CAR(l))){
if (len < 2) goto Error;
return Cons(CAR(CAR(l)), Cons(Cons(Sym_lambda,
Cons(CDR(CAR(l)), CDR(l))),
NIL));
}
else
if (len == 2) return l;
Error:
Err("define: bad parameter list", l);
}
PRIMITIVE STk_syntax_quote(SCM *pform, SCM env, int len)
{
SCM args = CDR(*pform);
if (len != 1) Err("quote: Bad syntax", *pform);
if (ModifyCode()) CAR(*pform) = makecell(tc_quote);
SYNTAX_RETURN(CAR(args), Ntruth);
}
PRIMITIVE STk_syntax_lambda(SCM *pform, SCM env, int len)
{
register SCM z, args=CDR(*pform);
if (len < 2) Err("lambda: bad syntax", *pform);
if(ModifyCode()) CAR(*pform) = makecell(tc_lambda);
NEWCELL(z, tc_closure);
z->storage_as.closure.env = env;
z->storage_as.closure.code = args;
SYNTAX_RETURN(z, Ntruth);
}
PRIMITIVE STk_syntax_if(SCM *pform, SCM env, int len)
{
SCM args = CDR(*pform);
switch (len) {
case 2: args = LIST3(CAR(args), CAR(CDR(args)), UNDEFINED);
case 3: break;
default: Err("if: bad syntax", *pform);
}
if (ModifyCode()) {
CAR(*pform) = makecell(tc_if);
CDR(*pform) = args; /* will always contain a else part */
}
SYNTAX_RETURN(NEQ(EVALCAR(args), Ntruth) ? CAR(CDR(args)):CAR(CDR(CDR(args))),
Truth);
}
PRIMITIVE STk_syntax_setq(SCM *pform, SCM env, int len)
{
SCM var, *tmp, args = CDR(*pform);
if (len != 2) Err("set!: bad assignement", args);
if (NSYMBOLP(var=CAR(args))) Err("set!: first argument is not a symbol", var);
tmp = STk_varlookup(var, env, 0);
if (*tmp == UNBOUND) {
/* C variables are always seen as unbound variables. This tends to
* make them slower than standard variables but, in counterpart, this
* doesn't slow down accesses to Scheme variables
*/
if (var->cell_info & CELL_INFO_C_VAR) {
/* This is not an unbound variable but rather a C variable */
STk_apply_setter_C_variable(PNAME(var), EVALCAR(CDR(args)));
goto Out;
}
else
Err("set!: variable not defined", var);
}
if (ModifyCode()) CAR(*pform) = makecell(tc_setq);
*tmp = EVALCAR(CDR(args));
Out:
if (TRACED_VARP(var)) STk_change_value(var, env);
SYNTAX_RETURN(UNDEFINED, Ntruth);
}
PRIMITIVE STk_syntax_cond(SCM *pform, SCM env, int len) /* len unused here */
{
SCM l, tmp;
for (l=CDR(*pform); CONSP(l); l=CDR(l)) {
if (NCONSP(CAR(l))) Err("cond: malformed clause", CAR(l));
if (EQ(CAR(CAR(l)), Sym_else) && NNULLP(CDR(l)))
Err("cond: else clause must be the last", *pform);
}
if (NNULLP(l)) Err("cond: malformed clauses list", CDR(*pform));
tmp = Cons(makecell(tc_cond), CDR(*pform));
if (ModifyCode()) CAR(*pform) = CAR(tmp);
SYNTAX_RETURN(tmp, Truth);
}
PRIMITIVE STk_syntax_and(SCM *pform, SCM env, int len)
{
SCM l = CDR(*pform);
if (ModifyCode()) CAR(*pform) = makecell(tc_and);
if (len == 0) SYNTAX_RETURN(Truth, Ntruth);
for (--len; len; len--, l=CDR(l)) {
if (EVALCAR(l) == Ntruth) SYNTAX_RETURN(Ntruth, Ntruth);
}
SYNTAX_RETURN(CAR(l), Truth);
}
PRIMITIVE STk_syntax_or(SCM *pform, SCM env, int len)
{
SCM l = CDR(*pform);
SCM val;
if (ModifyCode()) CAR(*pform) = makecell(tc_or);
if (len == 0) SYNTAX_RETURN(Ntruth, Ntruth);
for (--len; len; len--, l=CDR(l)) {
if ((val=EVALCAR(l)) != Ntruth) SYNTAX_RETURN(val, Ntruth);
}
SYNTAX_RETURN(CAR(l), Truth);
}
static SCM syntax_let_family(SCM *pform, SCM env, char *who, int type, int len)
{
register SCM p, tmp, fl=NIL, al=NIL;
char buffer[100];
int named_let = 0;
if (len < 2) goto Error;
p = CAR(CDR(*pform));
if (SYMBOLP(p) && type == tc_let) {
/* It's a named let. Re-initialize to a correct value */
if (len < 3) goto Error;
named_let = 1;
p = CAR(CDR(CDR(*pform)));
}
for( ; NNULLP(p); p=CDR(p)) {
if (STk_llength(tmp=CAR(p)) != 2 || NSYMBOLP(CAR(tmp))) {
sprintf(buffer, "%s: badly formed binding", who);
Err(buffer, CONSP(p)? tmp: p);
}
/* Verify that this binding doesn't already exist in fl
* except for let* which aloows it (at least the formal semantics
* given in R4RS). Problem shown by Brent Knight <knight@CS.Cornell.EDU>
*/
if (type!=tc_letstar && STk_memv(CAR(tmp),fl)!=Ntruth) {
sprintf(buffer, "%s: duplicate binding", who);
Err(buffer, CAR(CDR(*pform)));
}
fl = Cons(CAR(tmp),fl);
al = Cons(CAR(CDR(tmp)),al);
}
tmp = named_let ?
/* named let */
LIST4(makecell(tc_letrec),
LIST1(CAR(CDR(*pform))),
LIST1(Cons(Sym_lambda,
Cons(Reverse(fl), CDR(CDR(CDR(*pform)))))),
Cons(CAR(CDR(*pform)), Reverse(al))) :
/* normal case */
Cons(makecell(type),
Cons(Reverse(fl),
Cons(Reverse(al),
CDR(CDR(*pform)))));
if (ModifyCode()) {
CAR(*pform) = CAR(tmp);
CDR(*pform) = CDR(tmp);
}
SYNTAX_RETURN(tmp, Truth);
Error:
sprintf(buffer, "%s: incorrect number of subforms", who);
Err(buffer, *pform);
}
PRIMITIVE STk_syntax_let(SCM *pform, SCM env, int len)
{
return syntax_let_family(pform, env, "let", tc_let, len);
}
PRIMITIVE STk_syntax_letstar(SCM *pform, SCM env, int len)
{
return syntax_let_family(pform, env, "let*", tc_letstar, len);
}
PRIMITIVE STk_syntax_letrec(SCM *pform, SCM env, int len)
{
return syntax_let_family(pform, env, "letrec", tc_letrec, len);
}
PRIMITIVE STk_syntax_begin(SCM *pform, SCM env, int len)
{
register SCM l = CDR(*pform);
if (len == 0) Err("begin: no subform in sequence", l);
for ( ; NNULLP(CDR(l)); l = CDR(l))
EVALCAR(l);
if (ModifyCode()) CAR(*pform) = makecell(tc_begin);
SYNTAX_RETURN(CAR(l), Truth);;
}
PRIMITIVE STk_syntax_delay(SCM *pform, SCM env, int len)
{
SCM z, tmp;
if (len != 1) Err("delay: Bad expression", *pform);
/* Build (lambda () expr) in tmp */
NEWCELL(tmp, tc_closure);
tmp->storage_as.closure.env = env;
tmp->storage_as.closure.code = Cons(NIL, CDR(*pform));
/* save this closure in the promise */
NEWCELL(z, tc_promise);
z->storage_as.promise.expr = tmp;
z->storage_as.promise.resultknown = 0;
SYNTAX_RETURN(z, Ntruth);
}
static SCM backquotify(SCM x, SCM env, int level)
{
if (VECTORP(x))
return STk_list2vector(backquotify(STk_vector2list(x), env, level));
if (NCONSP(x)) return x;
if (EQ(CAR(x), Sym_quasiquote))
return LIST2(Sym_quasiquote,
backquotify(CAR(CDR(x)), env, level+1));
if (EQ(CAR(x), Sym_unquote))
return (level == 1) ? EVALCAR(CDR(x))
: LIST2(Sym_unquote,
backquotify(CAR(CDR(x)), env, level-1));
if (CONSP(CAR(x)) && EQ(CAR(CAR(x)), Sym_unq_splicing))
return NULLP(CDR(x)) ? EVALCAR(CDR(CAR(x)))
: STk_append(LIST2(EVALCAR(CDR(CAR(x))),
backquotify(CDR(x), env, level)),
2);
/* Otherwise */
return Cons(backquotify(CAR(x), env, level), backquotify(CDR(x), env, level));
}
PRIMITIVE STk_syntax_quasiquote(SCM *pform, SCM env, int len)
{
if (len == 0) Err("quasiquote: no form", NIL);
SYNTAX_RETURN(backquotify(CAR(CDR(*pform)), env, 1), Ntruth);
}
PRIMITIVE STk_syntax_define(SCM *pform, SCM env, int len)
{
SCM *tmp, var, args;
args = define2lambda(CDR(*pform), len);
var = CAR(args); if (NSYMBOLP(var)) Err("define: bad variable name", var);
if (NULLP(env)) {
/* Global var */
if (VCELL(var) == UNBOUND && (var->cell_info&CELL_INFO_C_VAR)) {
/* This is not an unbound variable but rather a C variable */
STk_apply_setter_C_variable(PNAME(var), EVALCAR(CDR(args)));
}
else {
tmp = STk_varlookup(var, env, 0);
*tmp = EVALCAR(CDR(args));
}
}
else {
/* Local var */
tmp = STk_value_in_env(var, env);
if (tmp != &UNBOUND) {
/* This symbol was already defined at current level. Just do an assignment */
*tmp = EVALCAR(CDR(args));
}
else {
/* Extend current environment for that definition
/* We should add new definition at the end of current environment (since some
/* code as possbly be re-written usin tc_localvar). This avoid re-numbering
/* acual code is FALSE */
SCM tmp = CAR(env);
tmp = Cons(Cons(var, CAR(tmp)),
Cons(EVALCAR(CDR(args)), CDR(tmp)));
CAR(CAR(env)) = CAR(tmp);
CDR(CAR(env)) = CDR(tmp);
}
}
if (TRACED_VARP(var)) STk_change_value(var, env);
SYNTAX_RETURN(UNDEFINED, Ntruth);
}
/*
*
* STk special syntaxic forms
*
*/
PRIMITIVE STk_syntax_extend_env(SCM *pform, SCM env, int len)
{
if (len < 2) Err("extend-current-env: Bad syntax", *pform);
SYNTAX_RETURN(Cons(makecell(tc_extend_env), STk_copy_tree(CDR(*pform))),
Truth);
}
PRIMITIVE STk_while(SCM l, SCM env, int len)
{
register SCM test, body;
if (len < 2) Err("while: bad argument list", NIL);
for (test = EVALCAR(l); test != Ntruth; test = EVAL(CAR(l))) {
/* Evaluate each expression of the body */
for (body = CDR(l); !NULLP(body); body = CDR(body))
EVALCAR(body);
}
return UNDEFINED;
}
PRIMITIVE STk_until(SCM l, SCM env, int len)
{
register SCM test, body;
if (len < 2) Err("until: bad argument list", NIL);
for (test = EVALCAR(l); test == Ntruth; test = EVAL(CAR(l))) {
/* Evaluate each expression of the body */
for (body = CDR(l); !NULLP(body); body = CDR(body))
EVALCAR(body);
}
return UNDEFINED;
}
Reference in New Issue View Git Blame Copy Permalink