Permalink
Browse files

Now supports variadic functions

  codegen: when emitting C-code of the form:
      ((fn (foo . rest) (body foo rest))
       arg1 arg2)
    code-generate will now treat the argument list as (foo rest)
  codegen: variadic functions will put extra arguments
    into a list; their arguments are treated as proper, i.e.
    (foo . rest) arglists are converted to (foo rest), and
    variadic functions will put the extra arguments into a
    list in rest
  codegen: added variadic handling in C code
  codegen: added a num_args variable which specifies the number
    of parameters passed (this information might actually be
    determined by measuring sp - stack)
  codegen: 'source and 'code-walk now properly handles variadic
    arglists

  utils: added 'properify function to convert improper lists and
    non-lists into proper lists

  xe: modified 'fn to handle improper lists for argument lists
  • Loading branch information...
AmkG committed Apr 6, 2008
1 parent e36ba17 commit aa720661e09719ba3f766f238cd78aa0d6d46d9f
Showing with 87 additions and 14 deletions.
  1. +33 −7 codegen.arc
  2. +6 −1 utils.arc
  3. +31 −0 varargs.arc
  4. +17 −6 xe.arc
View
@@ -82,7 +82,7 @@
args (cdr ast!subx)
n (len args))
(if (alam fun)
- (cg-list args fun!params stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
+ (cg-list args (properify fun!params) stack-env "\n" (fn (code new-stack-env) (list code (code-gen (car fun!subx) new-stack-env))))
(cg-list args (range 1 n) stack-env "\n" (fn (code new-stack-env)
(with
(start (len stack-env)
@@ -105,7 +105,14 @@
(pop lambda-todo)
(list
"case " (car x) ":\n\n"
- (code-gen (car ast!subx) (rev ast!params))
+ ; if variadic, insert variadic handling code
+ (if (dotted ast!params)
+ ; determine the number of required arguments
+ (let num-reqs (- (len:properify ast!params) 1)
+ (list " VARIADIC2LIST(" num-reqs ");\n")))
+ ; <insert code to check that caller passed
+ ; correct number of arguments here>
+ (code-gen (car ast!subx) (rev:properify ast!params))
"\n\n"
(compile-all-lambdas))))))
@@ -219,11 +226,15 @@ void PR(){
#define HALT() break
+//place arguments exceeding nbreq into a list at the top of
+//the stack
+#define VARIADIC2LIST(nbreq) for(PUSH(NILOBJ); num_args > nbreq; num_args--) CONS()
+
#define BEGIN_CLOSURE(label,nbfree) closure = GC_MALLOC(sizeof(obj) * nbfree + 1);
#define INICLO(i) closure[i] = POP();
#define END_CLOSURE(label,nbfree) closure[0] = label; PUSH((obj)closure);
-#define BEGIN_JUMP(nbargs) sp = stack;
+#define BEGIN_JUMP(nbargs) {sp = stack; num_args = nbargs;}
#define END_JUMP(nbargs) pc = ((obj *)LOCAL(0))[0]; goto jump;
obj SYM2OBJ (char * s){ /* Find a symbol, or save it if it's the first time */
@@ -251,6 +262,7 @@ obj execute (int pc)
sp = stack;
obj NILOBJ = SYM2OBJ (\"nil\");
obj TOBJ = SYM2OBJ (\"t\");
+ long num_args = 0;
jump: switch (pc) {
@@ -269,6 +281,17 @@ int main (int argc, char * argv[]) {
;------------------------------------------------------------------------------
+
+(def map-improper (f l)
+ " A mapping function which supports both
+ proper and improper lists; mapping on an
+ improper list returns an improper list "
+ (if
+ (acons l)
+ (cons (f:car l) (map-improper f (cdr l)))
+ l
+ (f l)))
+
; debugging
(def source (ast)
@@ -285,10 +308,11 @@ int main (int argc, char * argv[]) {
(cons ast!op (map source ast!subx))
(anapp ast)
(if (alam (car ast!subx))
- (list 'let (map (fn (p a) (list p!uid (source a))) ((car ast!subx) 'params) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
+ ; actually, shouldn't properify the params, maybe okay since this is debug code, but...
+ (list 'let (map (fn (p a) (list p!uid (source a))) (properify ((car ast!subx) 'params)) (cdr ast!subx)) (source (car ((car ast!subx) 'subx))))
(map source ast!subx))
(alam ast)
- (list 'fn (map [_ 'uid] ast!params) (source (car ast!subx)))
+ (list 'fn (map-improper [_ 'uid] ast!params) (source (car ast!subx)))
(aseq ast)
(cons 'do (map source ast!subx))
(aquote ast)
@@ -297,6 +321,8 @@ int main (int argc, char * argv[]) {
; (cref driver)
ast))
+; seems currently unused -
+; note that this function doesn't support varargs
(def ds (ast)
(if
(alit ast)
@@ -337,7 +363,7 @@ int main (int argc, char * argv[]) {
; (don't move on unless code is stable)
(*code-walk-internal usercode new-code)
(if (acons new-code)
- (map [*code-walk-internal usercode _] new-code)
+ (map-improper [*code-walk-internal usercode _] new-code)
new-code))))
(if (acons code)
(if
@@ -355,7 +381,7 @@ int main (int argc, char * argv[]) {
(list 'unquote (*code-walk-internal usercode
(cadr code)))
; else
- (map quasiwalk code))
+ (map-improper quasiwalk code))
code))
(cadr code)))
; else
View
@@ -32,6 +32,11 @@
(++ result (string elt))))
result))
+(def properify (lst)
+ " Makes an improper list proper, or a non-list into a
+ singleton list "
+ (if (alist lst) (makeproper lst) (cons lst nil)))
+
;------------------------------------------------------------------------------
; free variables
@@ -43,7 +48,7 @@
(aset ast)
(union (fv (car ast!subx)) (list ast!var))
(alam ast)
- (diff (fv (car ast!subx)) ast!params)
+ (diff (fv (car ast!subx)) (properify ast!params))
(aquote ast)
nil
(union-multi (map fv ast!subx))))
View
@@ -0,0 +1,31 @@
+
+(set list
+ (fn rest
+ rest))
+
+(prn (list 1 2 3)) ; (1 . (2 . (3 . nil)))
+(prn (list 'x 'y)) ; (x . (y . nil))
+(prn (list)) ; nil
+
+(set test1
+ (fn (v . rest)
+ (pr 'v) (prn v)
+ (pr 'rest) (prn rest)))
+
+; v1
+; restnil
+(test1 1)
+; vx
+; rest(y . nil)
+(test1 'x 'y)
+
+(set test2
+ (fn (x y . rest)
+ (pr 'x) (prn x)
+ (pr 'y) (prn y)
+ (pr 'rest) (prn rest)))
+
+; x1
+; y2
+; rest(3 . nil)
+(test2 1 2 3)
View
23 xe.arc
@@ -158,12 +158,23 @@
(= macfn* (make-macro 'fn
(fn (e cte)
- (if (>= (len (cdr e)) 1)
- (withs
- (params (map new-var (cadr e))
- new-cte (extend params cte))
- (make-lam (list:xe (cons 'do (cddr e)) new-cte) params))
- (err "fn expects a parameter list")))))
+ (let (_ exp-params . body) e
+ (if (>= (len (cdr e)) 1)
+ (withs
+ ; support proper and improper lists
+ ; as argument list: (arg arg) or (arg . arg)
+ (params ((afn (l)
+ (if
+ (acons l)
+ (let (e . rest) l
+ (cons (new-var e) (self rest)))
+ l
+ (new-var l)))
+ exp-params)
+ proper-params (if (alist params) (makeproper params) (cons params nil))
+ new-cte (extend proper-params cte))
+ (make-lam (list:xe (cons 'do body) new-cte) params))
+ (err "fn expects a parameter list"))))))
(= macdo* (make-macro 'do
(fn (e cte)

0 comments on commit aa72066

Please sign in to comment.