From 6e1e4b56be4dbf32d793a94736d53e516292f3bc Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Tue, 30 Jun 2015 21:44:23 -0400 Subject: [PATCH] Allow primitives to take a continuation argument Also stubbed out the command-line-args function as such. --- cgen.scm | 37 +++++++++++++++++++++++++++++-------- runtime.c | 14 +++++++++----- runtime.h | 5 +++-- test2.scm | 2 ++ 4 files changed, 43 insertions(+), 15 deletions(-) diff --git a/cgen.scm b/cgen.scm index da7db4e7..5858b900 100644 --- a/cgen.scm +++ b/cgen.scm @@ -529,6 +529,7 @@ ((eq? p 'string-length) "integer_type") ((eq? p 'substring) "string_type") ((eq? p 'apply) "object") + ((eq? p 'command-line-arguments) "object") (else #f))) ;; Determine if primitive creates a C variable @@ -545,7 +546,19 @@ make-vector list->vector symbol->string number->string string-length substring - + - * / apply cons length vector-length cell)))) + + - * / apply + command-line-arguments + cons length vector-length cell)))) + +;; Pass continuation as the function's first parameter? +(define (prim:cont? exp) + (and (prim? exp) + (member exp '(apply command-line-arguments)))) +;; TODO: this is a hack, right answer is to include information about +;; how many args each primitive is supposed to take +(define (prim:cont-has-args? exp) + (and (prim? exp) + (member exp '(apply)))) ;; Pass an integer arg count as the function's first parameter? (define (prim:arg-count? exp) @@ -560,16 +573,16 @@ ;; c-compile-prim : prim-exp -> string -> string (define (c-compile-prim p cont) (let* ((c-func (prim->c-func p)) - ;; Following closure defs are only used for apply, to + ;; Following closure defs are only used for prim:cont? to ;; create a new closure for the continuation, if needed. ;; - ;; Apply is different in that it takes a continuation so that it can + ;; Each prim:cont? function is different in that it takes a continuation so that it can ;; allocate arbitrary data as needed using alloca, and then call into ;; the cont so allocations can remain on stack until GC. (closure-sym (mangle (gensym 'c))) (closure-def (cond - ((and (eq? p 'apply) + ((and (prim:cont? p) (> (string-length cont) (string-length "__lambda_")) (equal? (substring cont 0 9) "__lambda_")) (string-append @@ -581,7 +594,7 @@ (lambda (type) (let ((cv-name (mangle (gensym 'c)))) (c-code/vars - (string-append (if (eq? p 'apply) "" "&") cv-name) + (string-append (if (prim:cont? p) "" "&") cv-name) (list (string-append ;; Define closure if necessary (apply only) @@ -595,14 +608,22 @@ ;; Emit closure as first arg, if necessary (apply only) (cond (closure-def - (string-append "&" closure-sym ", ")) - ((eq? p 'apply) - (string-append cont ", ")) + (string-append "&" closure-sym + (if (prim:cont-has-args? p) ", " ""))) + ((prim:cont? p) + (string-append cont + (if (prim:cont-has-args? p) ", " ""))) (else ""))))))))) (cond ((prim/c-var-assign p) (c-var-assign (prim/c-var-assign p))) ((prim/cvar? p) + ;; + ;; TODO: look at functions that would actually fall into this + ;; branch, I think they are just the macro's like string->list ?? + ;; may be able to remove this using prim:cont? and simplify + ;; the logic + ;; (let ((cv-name (mangle (gensym 'c)))) (c-code/vars (if (prim:allocates-object? p) diff --git a/runtime.c b/runtime.c index 7d665df4..2a62e131 100644 --- a/runtime.c +++ b/runtime.c @@ -51,7 +51,8 @@ int gc_num_ans; jmp_buf jmp_main; /* Where to jump to. */ object Cyc_global_variables = nil; -object Cyc_command_line_arguments = nil; +int _cyc_argc = 0; +char **_cyc_argv = NULL; static symbol_type __EOF = {eof_tag, "", nil}; // symbol_type in lieu of custom type const object Cyc_EOF = &__EOF; @@ -892,9 +893,12 @@ string_type Cyc_substring(object str, object start, object end) { } } -object Cyc_command_line_arguments() { - Cyc_rt_raise_msg("not implemented yet"); - return boolean_f; +object Cyc_command_line_arguments(object cont) { + //Cyc_rt_raise_msg("not implemented yet"); + //return boolean_f; + make_string(s, "TODO"); + make_cons(l, &s, nil); + return_funcall1(cont, &l); } integer_type Cyc_system(object cmd) { @@ -1313,7 +1317,7 @@ void _cyc_string_91ref(object cont, object args) { object c = Cyc_string_ref(car(args), cadr(args)); return_funcall1(cont, c); } void _command_91line_91arguments(object cont, object args) { - object cmdline = Cyc_command_line_arguments(); + object cmdline = Cyc_command_line_arguments(cont); return_funcall1(cont, cmdline); } void _cyc_system(object cont, object args) { integer_type i = Cyc_system(car(args)); diff --git a/runtime.h b/runtime.h index 19fd15a5..519fdd63 100644 --- a/runtime.h +++ b/runtime.h @@ -56,7 +56,8 @@ object cell_get(object cell); /* Prototypes for Lisp built-in functions. */ extern object Cyc_global_variables; -extern object Cyc_command_line_arguments; +int _cyc_argc; +char **_cyc_argv; object Cyc_get_global_variables(); object Cyc_get_cvar(object var); object Cyc_set_cvar(object var, object value); @@ -104,7 +105,7 @@ string_type Cyc_string_append_va_list(int argc, object str1, va_list ap); integer_type Cyc_string_length(object str); string_type Cyc_substring(object str, object start, object end); object Cyc_string_ref(object str, object k); -object Cyc_command_line_arguments(); +object Cyc_command_line_arguments(object cont); integer_type Cyc_system(object cmd); integer_type Cyc_char2integer(object chr); object Cyc_integer2char(object n); diff --git a/test2.scm b/test2.scm index 71fe1dfc..0b080a6e 100644 --- a/test2.scm +++ b/test2.scm @@ -8,6 +8,8 @@ (loop (- i 1)))) +(write (command-line-arguments)) + (write (when (lambda () #t) 'true)) (write (when (lambda () #f) 'false))