core: One SCM type for function.
authorJan Nieuwenhuizen <janneke@gnu.org>
Thu, 3 Nov 2016 20:28:05 +0000 (21:28 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 12 Dec 2016 19:33:50 +0000 (20:33 +0100)
* 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
lib.c
math.c
mes.c
module/mes/type-0.mes
string.c
type.c

index 02c7f0ef8bdf0619e5b67c235ea8c37b8f3abb64..00a065dc92f086e79828d1d2bb905cc83b91245f 100755 (executable)
@@ -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 <file>
                    #:name (string-append base-name ".environment.h")
-                   #:content (string-join (map function->header functions))))
+                   #:content (string-join (map function->header functions) "")))
          (environment (make <file>
                         #: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 <file>
                     #: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 b252ef1a014e8cce6b0ccdda49ad874492e93f11..d27bad130af0d10e8ab6e7ac1b7400c506498738 100644 (file)
--- 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 a28f89b806f7b20081e1794f47d590fe9dc458e8..c7dd3d7d5d16bdce0ecd4e3528d1069f1f445241 100644 (file)
--- 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 03b0ca4c5b3e011457f28b88f94654b415c1624c..0d953f40ed144b5594c2b3927cbc52bb60ebe358 100644 (file)
--- a/mes.c
+++ b/mes.c
 #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, "#<procedure %s>", x->name);
+  else if (x->type == FUNCTION) fprintf (f, "#<procedure %s>", 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);
index 81fc3edc656c0f364710226f386b7da010d7d007..bd28e6690cdf6518a03c87601cda8032505359af 100644 (file)
 ;;; Code:
 
 (define <char> 0)
-(define <macro> 1)
-(define <number> 2)
-(define <pair> 3)
-(define <scm> 4)
-(define <string> 5)
-(define <symbol> 6)
-(define <values> 7)
-(define <vector> 8)
-(define <function0> 8)
-(define <function1> 9)
-(define <function2> 10)
-(define <function3> 11)
-(define <functionn> 12)
+(define <function> 1)
+(define <macro> 2)
+(define <number> 3)
+(define <pair> 4)
+(define <scm> 5)
+(define <string> 6)
+(define <symbol> 7)
+(define <values> 8)
+(define <vector> 9)
 
 (define mes-type-alist
   `((,<char> . <char>)
+    (,<function> . <function>)
     (,<macro> . <macro>)
     (,<number> . <number>)
     (,<pair> . <pair>)
     (,<string> . <string>)
     (,<symbol> . <symbol>)
     (,<char> . <char>)
-    (,<values> . <values>)
-    (,<function0> . <function0>)
-    (,<function1> . <function1>)
-    (,<function2> . <function2>)
-    (,<function3> . <function3>)
-    (,<functionn> . <functionn>)))
+    (,<values> . <values>)))
   
 (define (class-of x)
   (assq (mes-type-of x) mes-type-alist))
index 0d87ce46c2365bc7059be2894b9104fddda68288..b633babc80498ece2de4813345b6b6803d390000 100644 (file)
--- a/string.c
+++ b/string.c
  */
 
 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 ca7119c8a25ec2031f296f70a29713f9cdd5ceb0..e8f0a4ec33459086d70d9f5ff851cea93b3b474a 100644 (file)
--- 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