artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: One SCM type for function.

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2016-11-03 21:28:05 +01:00
parent 0eda7383f2
commit 7e8341d76c
7 changed files with 69 additions and 78 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
build-aux/mes-snarf.scm
View file

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

2
lib.c
View file

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

16
math.c
View file

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

70
mes.c
View file

@ -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, "#<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);

30
module/mes/type-0.mes
View file

@ -31,22 +31,19 @@
;;; 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>)
@ -54,12 +51,7 @@
(,<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))

6
string.c
View file

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

7
type.c
View file

@ -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