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

@@ -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)
+  (let* ((arity (or (assoc-ref (.annotation f) 'arity)
-                (if (string-null? (.formals f)) 0
+                    (if (string-null? (.formals f)) 0
-                    (length (string-split (.formals f) #\,))))))
+                        (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)

lib.c

@@ -51,7 +51,7 @@ last_pair (scm *x)
 }
 
 scm *
-list (scm *x) ///((args . n))
+list (scm *x) ///((arity . n))
 {
   return x;
 }

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)

mes.c

@@ -31,15 +31,24 @@
 #define QUASIQUOTE 1
 //#define QUASISYNTAX 0
 
-enum type {CHAR, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR,
+enum type {CHAR, FUNCTION, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR};
-           FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
+
-struct scm_t;
 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;
+    function* function;
-    function1_t function1;
-    function2_t function2;
-    function3_t function3;
-    functionn_t functionn;
     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->type == FUNCTION) return call (fn, x);
-      if (fn == &scm_cdr) return x->car->cdr;
+      if (fn == &symbol_call_with_values)
-      if (builtin_p (fn) == &scm_t)
-        return call (fn, x);
-      if (eq_p (fn, &symbol_call_with_values) == &scm_t)
         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)
+  if ((fn->function->arity > 0 || fn->function->arity == -1)
-    return fn->function0 ();
+      && x != &scm_nil && car (x)->type == VALUES)
-  if (x != &scm_nil && x->car->type == VALUES)
     x = cons (x->car->cdr->car, x->cdr);
-  if (fn->type == FUNCTION1)
+  if ((fn->function->arity > 1 || fn->function->arity == -1)
-    return fn->function1 (car (x));
+      && x != &scm_nil && x->cdr->car->type == VALUES)
-  if (x != &scm_nil && x->cdr->car->type == VALUES)
     x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr));
-  if (fn->type == FUNCTION2)
+  switch (fn->function->arity)
-    return fn->function2 (car (x), cadr (x));
+    {
-  if (fn->type == FUNCTION3)
+    case 0: return fn->function->function0 ();
-    return fn->function3 (car (x), cadr (x), caddr (x));
+    case 1: return fn->function->function1 (car (x)); 
-  if (fn->type == FUNCTIONn)
+    case 2: return fn->function->function2 (car (x), cadr (x));
-    return fn->functionn (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);

module/mes/type-0.mes

@@ -31,22 +31,19 @@
 ;;; Code:
 
 (define <char> 0)
-(define <macro> 1)
+(define <function> 1)
-(define <number> 2)
+(define <macro> 2)
-(define <pair> 3)
+(define <number> 3)
-(define <scm> 4)
+(define <pair> 4)
-(define <string> 5)
+(define <scm> 5)
-(define <symbol> 6)
+(define <string> 6)
-(define <values> 7)
+(define <symbol> 7)
-(define <vector> 8)
+(define <values> 8)
-(define <function0> 8)
+(define <vector> 9)
-(define <function1> 9)
-(define <function2> 10)
-(define <function3> 11)
-(define <functionn> 12)
 
 (define mes-type-alist
   `((,<char> . <char>)
+    (,<function> . <function>)
     (,<macro> . <macro>)
     (,<number> . <number>)
     (,<pair> . <pair>)
@@ -54,12 +51,7 @@
     (,<string> . <string>)
     (,<symbol> . <symbol>)
     (,<char> . <char>)
-    (,<values> . <values>)
+    (,<values> . <values>)))
-    (,<function0> . <function0>)
-    (,<function1> . <function1>)
-    (,<function2> . <function2>)
-    (,<function3> . <function3>)
-    (,<functionn> . <functionn>)))
   
 (define (class-of x)
   (assq (mes-type-of x) mes-type-alist))

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);

type.c

@@ -71,12 +71,7 @@ vector_p (scm *x)
 scm *
 builtin_p (scm *x)
 {
-  return (x->type == FUNCTION0
+  return x->type == FUNCTION ? &scm_t : &scm_f;
-          || x->type == FUNCTION1
-          || x->type == FUNCTION2
-          || x->type == FUNCTION3
-          || x->type == FUNCTIONn)
-    ? &scm_t : &scm_f;
 }
 
 // Non-types