From f17cbc337de366f7ab21629dd547e7b6d8b94192 Mon Sep 17 00:00:00 2001 From: Itamar Date: Wed, 11 Mar 2009 22:05:15 +0200 Subject: [PATCH] added built in: apply. annoying --- src/c/builtins.c | 24 ++++++++++++++--- src/c/rtemgr.c | 78 ++++++++++++++++++++++++++++++++++++++++++++++++++------ src/c/rtemgr.h | 4 +++ src/c/strings.h | 3 ++- src/sml/cg.sml | 2 +- 5 files changed, 98 insertions(+), 13 deletions(-) diff --git a/src/c/builtins.c b/src/c/builtins.c index 1f7e995..409d262 100644 --- a/src/c/builtins.c +++ b/src/c/builtins.c @@ -24,6 +24,7 @@ */ #define BI_ST_ARG(n) (stack[sp-4-(n)]) #define BI_ST_ARG_COUNT() (stack[sp-3]) +#define BI_ST_RET() (stack[sp-1]) #define BI_RETURN() goto *pop() goto Lstart; /* skip all definitions */ @@ -198,6 +199,25 @@ Lchar_to_integer: r_res = (int)makeSchemeInt( (int)r[0] ); BI_RETURN(); +Lapply: + push( fp ); + fp = sp; + ASSERT_ALWAYS( ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("apply",2) ); + r[0] = ST_ARG(0); /* r[0] is now the closure */ + ASSERT_ALWAYS( IS_SOB_CLOSURE(r[0]), MSG_ERR_APPNONPROC ); + r[1] = ST_ARG(1); /* r[1] is now the list of arguments */ + ASSERT_ALWAYS( (r[1]==(int)&sc_nil) | (IS_SOB_PAIR(r[1])), MSG_ERR_NOTLIST ); + /* push arguments (backwards) and number of arguments */ + pushArgsList( (SchemeObject*)r[1] ); + /* push env. of closure */ + push( (int)SOB_CLOSURE_ENV(r[0]) ); + /* push current return address (it's a tail call) */ + push( (int)ST_RET() ); + /* override current frame (it's a tail call) */ + shiftActFrmDown(); + /* branch */ + goto *SOB_CLOSURE_CODE(r[0]); + Lstart: /* create closures for the free variables of the built-in procedures */ CREATE_BUILTIN_CLOS("car" ,&&Lcar); @@ -216,8 +236,6 @@ Lstart: CREATE_BUILTIN_CLOS("box" ,&&Lbox); CREATE_BUILTIN_CLOS("null?" ,&&Lnull); CREATE_BUILTIN_CLOS("char->integer" ,&&Lchar_to_integer); -/* - CREATE_BUILTIN_CLOS("",&&L); - */ + CREATE_BUILTIN_CLOS("apply" ,&&Lapply); /* */ diff --git a/src/c/rtemgr.c b/src/c/rtemgr.c index afaba7e..11b1366 100644 --- a/src/c/rtemgr.c +++ b/src/c/rtemgr.c @@ -4,6 +4,8 @@ #include "assertions.h" #include "strings.h" +extern SchemeObject sc_nil; + void printActFrm(int p) { unsigned int fp,ret,env,n; unsigned int i; @@ -13,12 +15,14 @@ void printActFrm(int p) { env = stack[p-3]; n = stack[p-4]; - fprintf( stderr, "fp=0x%x\n", fp ); - fprintf( stderr, "ret=0x%x\n", ret ); - fprintf( stderr, "env=0x%x\n", env ); - fprintf( stderr, "n=%d\n" , n ); - for (i=p-5; i>=p-5-n+1; i--) - fprintf( stderr, "a[%d]=%s\n", -i+p-5, sobToString((SchemeObject*)(stack[i])) ); + fprintf( stderr, "[%d] fp=0x%x\n", p-1, fp ); fflush(stderr); + fprintf( stderr, "[%d] ret=0x%x\n", p-2, ret ); fflush(stderr); + fprintf( stderr, "[%d] env=0x%x\n", p-3, env ); fflush(stderr); + fprintf( stderr, "[%d] n=%d\n", p-4, n ); fflush(stderr); + for (i=p-5; i>=p-5-n+1; i--) { + fprintf( stderr, "[%d] a[%d]=%s\n",i, -i+p-5, sobToString((SchemeObject*)(stack[i])) ); + fflush(stderr); + } } /* Copies the enviroment vector currenv to a new vector of size @@ -158,7 +162,7 @@ void prepareStackForAbsOpt(int formalParams) ST_ARG_COUNT() = formalParams; /* set it to () */ - stack[ ST_FRMEND() ] = (int)makeSchemeNil(); + stack[ ST_FRMEND() ] = (int)&sc_nil; } else { /* if the optional parameters were used, move them to a list @@ -170,7 +174,7 @@ void prepareStackForAbsOpt(int formalParams) int i; /* copy optional params to a list on the heap */ - opt = makeSchemeNil(); + opt = &sc_nil; lastOptional = ST_FRMEND(); firstOptional = lastOptional + (optionalsUsed-1); @@ -189,3 +193,61 @@ void prepareStackForAbsOpt(int formalParams) } } + +/* Reverses a Scheme list (in place) + + @param list: the list to reverse + @return: the reversed list +*/ +SchemeObject* reverseSchemeList( SchemeObject* list ) +{ + SchemeObject* prev; + SchemeObject* curr; + SchemeObject* next; + + prev = &sc_nil; + curr = list; + + while ( curr!=&sc_nil ) { + ASSERT_ALWAYS( IS_SOB_PAIR(curr), MSG_ERR_NOTLIST ); + next = SOB_PAIR_CDR(curr); + SOB_PAIR_CDR(curr) = prev; + prev = curr; + curr = next; + } + + return prev; +} + +/* Pushes the argument list (and the number of arguments in the list + onto the stack + + @param list: the arguments list + + The arguments are pushed backwards. +*/ +void pushArgsList(SchemeObject* list) +{ + /* strategy: + 1. reverse list + 2. push each argument + 3. push the number of arguments + 4. reverse again + */ + + SchemeObject* pair; + int args_count; + + list = reverseSchemeList( list ); + + args_count = 0; + pair = list; + while (pair != &sc_nil) { + push( (int)SOB_PAIR_CAR(pair) ); + pair = SOB_PAIR_CDR(pair); + args_count++; + } + push( args_count ); + + list = reverseSchemeList( list ); +} diff --git a/src/c/rtemgr.h b/src/c/rtemgr.h index 72c78e6..53568c2 100644 --- a/src/c/rtemgr.h +++ b/src/c/rtemgr.h @@ -3,10 +3,14 @@ #ifndef __RTEMGR_H #define __RTEMGR_H +#include "scheme.h" + int** extendEnviroment(int** currenv, int currenv_size); void shiftActFrmDown(); void shiftStackUp(int pos, unsigned int amount); void shiftStackDown(int pos, unsigned int amount); void prepareStackForAbsOpt(int formalParams); +SchemeObject* reverseSchemeList( SchemeObject* list ); +void pushArgsList(SchemeObject* list); #endif diff --git a/src/c/strings.h b/src/c/strings.h index 6cbe892..14e3d51 100644 --- a/src/c/strings.h +++ b/src/c/strings.h @@ -3,7 +3,8 @@ /* Error messages for use with ASSERT_ALWAYS( predicate, error_message ) */ #define MSG_ERR_ARGCOUNT(proc,ex) ("incorrect number of arguments for " proc ". Expected " #ex "\n") -#define MSG_ERR_NOTPAIR "not a pair" +#define MSG_ERR_NOTPAIR "not a pair" +#define MSG_ERR_NOTLIST "not a proper list" #define MSG_ERR_APPNONPROC "attempt to apply non-procedure" #endif diff --git a/src/sml/cg.sml b/src/sml/cg.sml index d3892a7..0e962e2 100644 --- a/src/sml/cg.sml +++ b/src/sml/cg.sml @@ -423,7 +423,7 @@ end = struct - enviroment pointer (at sp-1) - n, the number of arguments (at sp-2) - n arguments *) - ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) + ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) (* todo: remove? its a tail call - we would never get back here *) ) ) | genExpr (Seq []) absDepth = () -- 2.11.4.GIT