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

425 lines
12 KiB
C
Raw Blame History

/*
*
* s y n t a x . c -- Syntaxic forms implementation
*
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, modify, distribute,and license this
* software and its documentation for any purpose is hereby granted,
* provided that existing copyright notices are retained in all
* copies and that this notice is included verbatim in any
* distributions. No written agreement, license, or royalty fee is
* required for any of the authorized uses.
* This software is provided ``AS IS'' without express or implied
* warranty.
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 25-Oct-1993 23:39
* Last file update: 3-Sep-1999 20:59 (eg)
*/
/* 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"
#include "module.h"
#include "extend.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 definition", l);
return UNDEFINED; /* never reached */
}
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 args=CDR(*pform);
if (len < 2) Err("lambda: bad syntax", *pform);
if(ModifyCode()) CAR(*pform) = makecell(tc_lambda);
SYNTAX_RETURN(STk_makeclosure(args, env), 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);
}
/* Things are a tricky for named let: the scope of the name of a
* named let encloses only the body of the let and not the
* initialization values of the bound variables. Thus we have:
* (let ((f -))
* (let f ((n (f 1))) n)) => -1
* and not 1 (the exemple comes from a message from Allegro
* Petrofsky <Allegro@Petrofsky.Berkeley.CA.US> in comp.lang.scheme.
* That means that the previous let is equivalent to
* (let ((f -))
* ((letrec ((f (lambda (n) n))) f)
* (f 1)))
* rather than
* (let ((f -))
* (letrec ((f (lambda (n) n)))
* (f 1)))
*/
tmp = named_let ?
/* named let */
Cons(LIST4(makecell(tc_letrec),
LIST1(CAR(CDR(*pform))),
LIST1(Cons(Sym_lambda,
Cons(Reverse(fl), CDR(CDR(CDR(*pform)))))),
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);
return UNDEFINED; /* never reached */
}
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) {
SYNTAX_RETURN(UNDEFINED, Ntruth);
} else {
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 */
tmp = STk_makeclosure(Cons(NIL, CDR(*pform)), env);
/* 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_append2(EVALCAR(CDR(CAR(x))),
backquotify(CDR(x), env, level));
/* 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, expr;
args = define2lambda(CDR(*pform), len);
var = CAR(args); if (NSYMBOLP(var)) Err("define: bad variable name", var);
expr = EVALCAR(CDR(args));
if (NULLP(env)) { /* Global var */
STk_define_public_var(NIL, var, expr);
STk_last_defined = var;
}
else {
if (MODULEP(CAR(env))) { /* Public variable */
STk_define_public_var(CAR(env), var, expr);
STk_last_defined = var;
}
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 = expr;
}
else {
/* Extend current environment for that definition */
SCM vars, vals, tmp = CAR(env);
/* We add new definition at the end of current environment (since
* some code has possbly be re-written using tc_localvar). This avoid
* re-numbering the code.
*
* Note: The first append cannot be destructive because vars are direct
* references on the procedure environmment.
*/
vars = STk_append2(CAR(tmp), LIST1(var));
vals = STk_dappend2(CDR(tmp), LIST1(expr));
CAR(tmp) = vars;
CDR(tmp) = vals;
}
}
}
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-environement: Bad syntax", *pform);
if (ModifyCode()) CAR(*pform) = makecell(tc_extend_env);
SYNTAX_RETURN(*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