From 7e8341d76c021c77e4657aaf17a842a1e63bb6a0 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 3 Nov 2016 21:28:05 +0100 Subject: [PATCH] core: One SCM type for function. * mes.c (function_t): New struct. (type): One type for function. (call): Refactor. * build-aux/mes-snarf.mes: Use arity annotation. WAS: args. Update annotations. --- build-aux/mes-snarf.scm | 16 +++++----- lib.c | 2 +- math.c | 16 +++++----- mes.c | 70 +++++++++++++++++++++-------------------- module/mes/type-0.mes | 30 +++++++----------- string.c | 6 ++-- type.c | 7 +---- 7 files changed, 69 insertions(+), 78 deletions(-) diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 02c7f0ef..00a065dc 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -73,11 +73,13 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (define %builtin-prefix% "scm_") (define (function->header f) - (let* ((n (or (assoc-ref (.annotation f) 'args) - (if (string-null? (.formals f)) 0 - (length (string-split (.formals f) #\,)))))) + (let* ((arity (or (assoc-ref (.annotation f) 'arity) + (if (string-null? (.formals f)) 0 + (length (string-split (.formals f) #\,))))) + (n (if (eq? arity 'n) -1 arity))) (string-append (format #f "scm *~a (~a);\n" (.name f) (.formals f)) - (format #f "scm ~a = {FUNCTION~a, .name=~S, .function~a=&~a};\n" (function-builtin-name f) n (function-scm-name f) n (.name f))))) + (format #f "function fun_~a = {.function~a=&~a, .arity=~a};\n" (.name f) arity (.name f) n) + (format #f "scm ~a = {FUNCTION, .name=~S, .function=&fun_~a};\n" (function-builtin-name f) (function-scm-name f) (.name f))))) (define (snarf-symbols string) (let* ((matches (append (list-matches "\nscm ([a-z_0-9]+) = [{](SCM)," string) @@ -114,13 +116,13 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (base-name (basename file-name ".c")) (header (make #:name (string-append base-name ".environment.h") - #:content (string-join (map function->header functions)))) + #:content (string-join (map function->header functions) ""))) (environment (make #:name (string-append base-name ".environment.i") - #:content (string-join (map function->source (filter (negate no-environment?) functions))))) + #:content (string-join (map function->source (filter (negate no-environment?) functions)) ""))) (symbols (make #:name (string-append base-name ".symbols.i") - #:content (string-join (map symbol->source symbols))))) + #:content (string-join (map symbol->source symbols) "")))) (list header environment symbols))) (define (file-write file) diff --git a/lib.c b/lib.c index b252ef1a..d27bad13 100644 --- a/lib.c +++ b/lib.c @@ -51,7 +51,7 @@ last_pair (scm *x) } scm * -list (scm *x) ///((args . n)) +list (scm *x) ///((arity . n)) { return x; } diff --git a/math.c b/math.c index a28f89b8..c7dd3d7d 100644 --- a/math.c +++ b/math.c @@ -19,7 +19,7 @@ */ scm * -greater_p (scm *x) ///((name . ">") (args . n)) +greater_p (scm *x) ///((name . ">") (arity . n)) { int n = INT_MAX; while (x != &scm_nil) @@ -33,7 +33,7 @@ greater_p (scm *x) ///((name . ">") (args . n)) } scm * -less_p (scm *x) ///((name . "<") (args . n)) +less_p (scm *x) ///((name . "<") (arity . n)) { int n = INT_MIN; while (x != &scm_nil) @@ -47,7 +47,7 @@ less_p (scm *x) ///((name . "<") (args . n)) } scm * -is_p (scm *x) ///((name . "=") (args . n)) +is_p (scm *x) ///((name . "=") (arity . n)) { if (x == &scm_nil) return &scm_t; assert (x->car->type == NUMBER); @@ -62,7 +62,7 @@ is_p (scm *x) ///((name . "=") (args . n)) } scm * -minus (scm *x) ///((name . "-") (args . n)) +minus (scm *x) ///((name . "-") (arity . n)) { scm *a = car (x); assert (a->type == NUMBER); @@ -80,7 +80,7 @@ minus (scm *x) ///((name . "-") (args . n)) } scm * -plus (scm *x) ///((name . "+") (args . n)) +plus (scm *x) ///((name . "+") (arity . n)) { int n = 0; while (x != &scm_nil) @@ -93,7 +93,7 @@ plus (scm *x) ///((name . "+") (args . n)) } scm * -divide (scm *x) ///((name . "/") (args . n)) +divide (scm *x) ///((name . "/") (arity . n)) { int n = 1; if (x != &scm_nil) { @@ -119,7 +119,7 @@ modulo (scm *a, scm *b) } scm * -multiply (scm *x) ///((name . "*") (args . n)) +multiply (scm *x) ///((name . "*") (arity . n)) { int n = 1; while (x != &scm_nil) @@ -132,7 +132,7 @@ multiply (scm *x) ///((name . "*") (args . n)) } scm * -logior (scm *x) ///((args . n)) +logior (scm *x) ///((arity . n)) { int n = 0; while (x != &scm_nil) diff --git a/mes.c b/mes.c index 03b0ca4c..0d953f40 100644 --- a/mes.c +++ b/mes.c @@ -31,15 +31,24 @@ #define QUASIQUOTE 1 //#define QUASISYNTAX 0 -enum type {CHAR, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR, - FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn}; -struct scm_t; +enum type {CHAR, FUNCTION, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR}; + typedef struct scm_t* (*function0_t) (void); typedef struct scm_t* (*function1_t) (struct scm_t*); typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*); typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*); typedef struct scm_t* (*functionn_t) (struct scm_t*); - +typedef struct function_t { + union { + function0_t function0; + function1_t function1; + function2_t function2; + function3_t function3; + functionn_t functionn; + }; + int arity; +} function; +struct scm_t; typedef struct scm_t { enum type type; union { @@ -51,11 +60,7 @@ typedef struct scm_t { }; union { int value; - function0_t function0; - function1_t function1; - function2_t function2; - function3_t function3; - functionn_t functionn; + function* function; struct scm_t* cdr; struct scm_t* macro; struct scm_t* vector; @@ -360,11 +365,8 @@ apply_env (scm *fn, scm *x, scm *a) { if (fn->type != PAIR) { - if (fn == &scm_car) return x->car->car; - if (fn == &scm_cdr) return x->car->cdr; - if (builtin_p (fn) == &scm_t) - return call (fn, x); - if (eq_p (fn, &symbol_call_with_values) == &scm_t) + if (fn->type == FUNCTION) return call (fn, x); + if (fn == &symbol_call_with_values) return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil))); if (fn == &symbol_current_module) return a; } @@ -401,7 +403,7 @@ apply_env (scm *fn, scm *x, scm *a) scm * builtin_eval (scm *e, scm *a) { - if (builtin_p (e) == &scm_t) return e; + if (e->type == FUNCTION) return e; if (e->type == SCM) return e; if (e->type == SYMBOL) return assert_defined (assq_ref_cache (e, a)); if (e->type != PAIR) return e; @@ -508,7 +510,7 @@ builtin_if (scm *e, scm *a) //Helpers scm * -display (scm *x) ///((args . n)) +display (scm *x) ///((arity . n)) { scm *e = car (x); scm *p = cdr (x); @@ -527,20 +529,20 @@ display_ (FILE* f, scm *x) scm * call (scm *fn, scm *x) { - if (fn->type == FUNCTION0) - return fn->function0 (); - if (x != &scm_nil && x->car->type == VALUES) + if ((fn->function->arity > 0 || fn->function->arity == -1) + && x != &scm_nil && car (x)->type == VALUES) x = cons (x->car->cdr->car, x->cdr); - if (fn->type == FUNCTION1) - return fn->function1 (car (x)); - if (x != &scm_nil && x->cdr->car->type == VALUES) + if ((fn->function->arity > 1 || fn->function->arity == -1) + && x != &scm_nil && x->cdr->car->type == VALUES) x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr)); - if (fn->type == FUNCTION2) - return fn->function2 (car (x), cadr (x)); - if (fn->type == FUNCTION3) - return fn->function3 (car (x), cadr (x), caddr (x)); - if (fn->type == FUNCTIONn) - return fn->functionn (x); + switch (fn->function->arity) + { + case 0: return fn->function->function0 (); + case 1: return fn->function->function1 (car (x)); + case 2: return fn->function->function2 (car (x), cadr (x)); + case 3: return fn->function->function3 (car (x), cadr (x), caddr (x)); + case -1: return fn->function->functionn (x); + } return &scm_unspecified; } @@ -553,7 +555,7 @@ append2 (scm *x, scm *y) } scm * -append (scm *x) ///((args . n)) +append (scm *x) ///((arity . n)) { if (x == &scm_nil) return &scm_nil; return append2 (car (x), append (cdr (x))); @@ -664,7 +666,7 @@ make_vector (scm *n) } scm * -values (scm *x) ///((args . n)) +values (scm *x) ///((arity . n)) { scm *v = cons (0, x); v->type = VALUES; @@ -779,7 +781,7 @@ list_to_vector (scm *x) } scm * -newline (scm *p) ///((args . n)) +newline (scm *p) ///((arity . n)) { int fd = 1; if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value; @@ -789,7 +791,7 @@ newline (scm *p) ///((args . n)) } scm * -force_output (scm *p) ///((args . n)) +force_output (scm *p) ///((arity . n)) { int fd = 1; if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value; @@ -853,7 +855,7 @@ display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote) fprintf (f, ")"); } else if (x->type == REF) display_helper (f, x->ref, cont, "", true); - else if (builtin_p (x) == &scm_t) fprintf (f, "#", x->name); + else if (x->type == FUNCTION) fprintf (f, "#", x->name); else if (x->type != PAIR && x->string) { scm *p = x->string; assert (p); @@ -904,7 +906,7 @@ read_char () } scm * -write_char (scm *x) ///((args . n)) +write_char (scm *x) ///((arity . n)) { scm *c = car (x); scm *p = cdr (x); diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes index 81fc3edc..bd28e669 100644 --- a/module/mes/type-0.mes +++ b/module/mes/type-0.mes @@ -31,22 +31,19 @@ ;;; Code: (define 0) -(define 1) -(define 2) -(define 3) -(define 4) -(define 5) -(define 6) -(define 7) -(define 8) -(define 8) -(define 9) -(define 10) -(define 11) -(define 12) +(define 1) +(define 2) +(define 3) +(define 4) +(define 5) +(define 6) +(define 7) +(define 8) +(define 9) (define mes-type-alist `((, . ) + (, . ) (, . ) (, . ) (, . ) @@ -54,12 +51,7 @@ (, . ) (, . ) (, . ) - (, . ) - (, . ) - (, . ) - (, . ) - (, . ) - (, . ))) + (, . ))) (define (class-of x) (assq (mes-type-of x) mes-type-alist)) diff --git a/string.c b/string.c index 0d87ce46..b633babc 100644 --- a/string.c +++ b/string.c @@ -19,13 +19,13 @@ */ scm * -string (scm *x) ///((args . n)) +string (scm *x) ///((arity . n)) { return make_string (x); } scm * -string_append (scm *x) ///((args . n)) +string_append (scm *x) ///((arity . n)) { scm *p = &scm_nil; while (x != &scm_nil) @@ -61,7 +61,7 @@ string_ref (scm *x, scm *k) } scm * -substring (scm *x) ///((args . n)) +substring (scm *x) ///((arity . n)) { assert (x->type == PAIR); assert (x->car->type == STRING); diff --git a/type.c b/type.c index ca7119c8..e8f0a4ec 100644 --- a/type.c +++ b/type.c @@ -71,12 +71,7 @@ vector_p (scm *x) scm * builtin_p (scm *x) { - return (x->type == FUNCTION0 - || x->type == FUNCTION1 - || x->type == FUNCTION2 - || x->type == FUNCTION3 - || x->type == FUNCTIONn) - ? &scm_t : &scm_f; + return x->type == FUNCTION ? &scm_t : &scm_f; } // Non-types