core: Add struct type.
* src/struct.c: New file. * build-aux/snarf.sh: Snarf it. * src/mes.c: Include it.
This commit is contained in:
Jan Nieuwenhuizen
parent
8df367b3a2
commit
0068fe533d
|
|
@ -33,4 +33,5 @@ trace "SNARF$snarf math.c" ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
|
|||
trace "SNARF$snarf mes.c" ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c
|
||||
trace "SNARF$snarf posix.c" ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c
|
||||
trace "SNARF$snarf reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c
|
||||
trace "SNARF$snarf struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c
|
||||
trace "SNARF$snarf vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c
|
||||
|
|
|
|||
|
|
@ -143,6 +143,13 @@
|
|||
(if (keyword? x) (display "#:" port))
|
||||
(for-each (display-cut2 display-char <> port write?) (string->list x))
|
||||
(if (and (string? x) write?) (write-char #\" port)))
|
||||
((struct? x)
|
||||
(display "#<" port)
|
||||
(for-each (lambda (i)
|
||||
(let ((x (struct-ref x i)))
|
||||
(d x #f (if (= i 0) "" " "))))
|
||||
(iota (struct-length x)))
|
||||
(display ")" port))
|
||||
((vector? x)
|
||||
(display "#(" port)
|
||||
(for-each (lambda (i)
|
||||
|
|
@ -215,7 +222,7 @@
|
|||
((#\s) (write (car args) port))
|
||||
(else (display (car args) port)))
|
||||
(simple-format (cddr lst) (cdr args)))))))
|
||||
|
||||
|
||||
(if destination (simple-format lst rest)
|
||||
(with-output-to-string
|
||||
(lambda () (simple-format lst rest))))))
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@
|
|||
(cons <cell:ref> (quote <cell:ref>))
|
||||
(cons <cell:special> (quote <cell:special>))
|
||||
(cons <cell:string> (quote <cell:string>))
|
||||
(cons <cell:struct> (quote <cell:struct>))
|
||||
(cons <cell:symbol> (quote <cell:symbol>))
|
||||
(cons <cell:values> (quote <cell:values>))
|
||||
(cons <cell:variable> (quote <cell:variable>))
|
||||
|
|
@ -86,6 +87,9 @@
|
|||
(define (string? x)
|
||||
(eq? (core:type x) <cell:string>))
|
||||
|
||||
(define (struct? x)
|
||||
(eq? (core:type x) <cell:struct>))
|
||||
|
||||
(define (symbol? x)
|
||||
(eq? (core:type x) <cell:symbol>))
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ SCM r2 = 0;
|
|||
// continuation
|
||||
SCM r3 = 0;
|
||||
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
|
||||
struct scm {
|
||||
enum type_t type;
|
||||
|
|
@ -189,6 +189,7 @@ struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
|
|||
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
|
||||
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
|
||||
struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
|
||||
struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
|
||||
struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
|
||||
struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
|
||||
struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
|
||||
|
|
@ -234,6 +235,7 @@ SCM gc_init_news ();
|
|||
#define LENGTH(x) g_cells[x].car
|
||||
#define REF(x) g_cells[x].car
|
||||
#define STRING(x) g_cells[x].car
|
||||
#define STRUCT(x) g_cells[x].cdr
|
||||
#define VARIABLE(x) g_cells[x].car
|
||||
|
||||
#define CLOSURE(x) g_cells[x].cdr
|
||||
|
|
|
|||
3
src/gc.c
3
src/gc.c
|
|
@ -70,7 +70,8 @@ gc_copy (SCM old) ///((internal))
|
|||
return g_cells[old].car;
|
||||
SCM new = g_free++;
|
||||
g_news[new] = g_cells[old];
|
||||
if (NTYPE (new) == TVECTOR)
|
||||
if (NTYPE (new) == TSTRUCT
|
||||
|| NTYPE (new) == TVECTOR)
|
||||
{
|
||||
NVECTOR (new) = g_free;
|
||||
for (long i=0; i<LENGTH (old); i++)
|
||||
|
|
|
|||
25
src/lib.c
25
src/lib.c
|
|
@ -166,11 +166,34 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|
|||
if (TYPE (x) == TPORT)
|
||||
fdputs (">", fd);
|
||||
}
|
||||
else if (t == TREF)
|
||||
fdisplay_ (REF (x), fd, write_p);
|
||||
else if (t == TSTRUCT)
|
||||
{
|
||||
SCM printer = STRUCT (x) + 1;
|
||||
if (TYPE (printer) == TREF)
|
||||
printer = REF (printer);
|
||||
if (printer != cell_unspecified)
|
||||
apply (printer, cons (x, cell_nil), r0);
|
||||
else
|
||||
{
|
||||
fdputs ("#<", fd);
|
||||
fdisplay_ (STRUCT (x), fd, write_p);
|
||||
SCM t = CAR (x);
|
||||
long size = LENGTH (x);
|
||||
for (long i=2; i<size; i++)
|
||||
{
|
||||
fdputc (' ', fd);
|
||||
fdisplay_ (STRUCT (x) + i, fd, write_p);
|
||||
}
|
||||
fdputc ('>', fd);
|
||||
}
|
||||
}
|
||||
else if (t == TVECTOR)
|
||||
{
|
||||
fdputs ("#(", fd);
|
||||
SCM t = CAR (x);
|
||||
for (long i = 0; i < LENGTH (x); i++)
|
||||
for (long i = 0; i<LENGTH (x); i++)
|
||||
{
|
||||
if (i)
|
||||
fdputc (' ', fd);
|
||||
|
|
|
|||
26
src/mes.c
26
src/mes.c
|
|
@ -69,13 +69,14 @@ CONSTANT TPORT 8
|
|||
CONSTANT TREF 9
|
||||
CONSTANT TSPECIAL 10
|
||||
CONSTANT TSTRING 11
|
||||
CONSTANT TSYMBOL 12
|
||||
CONSTANT TVALUES 13
|
||||
CONSTANT TVARIABLE 14
|
||||
CONSTANT TVECTOR 15
|
||||
CONSTANT TBROKEN_HEART 16
|
||||
CONSTANT TSTRUCT 12
|
||||
CONSTANT TSYMBOL 13
|
||||
CONSTANT TVALUES 14
|
||||
CONSTANT TVARIABLE 15
|
||||
CONSTANT TVECTOR 16
|
||||
CONSTANT TBROKEN_HEART 17
|
||||
#else // !__M2_PLANET__
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
#endif // !__M2_PLANET__
|
||||
|
||||
typedef SCM (*function0_t) (void);
|
||||
|
|
@ -252,6 +253,7 @@ struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
|
|||
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
|
||||
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
|
||||
struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
|
||||
struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
|
||||
struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
|
||||
struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
|
||||
struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
|
||||
|
|
@ -279,6 +281,7 @@ int g_function = 0;
|
|||
#include "mes.mes.h"
|
||||
#include "posix.mes.h"
|
||||
#include "reader.mes.h"
|
||||
#include "struct.mes.h"
|
||||
#include "vector.mes.h"
|
||||
#else
|
||||
#include "gc.h"
|
||||
|
|
@ -287,6 +290,7 @@ int g_function = 0;
|
|||
#include "mes.h"
|
||||
#include "posix.h"
|
||||
#include "reader.h"
|
||||
#include "struct.h"
|
||||
#include "vector.h"
|
||||
#endif
|
||||
|
||||
|
|
@ -311,6 +315,7 @@ int g_function = 0;
|
|||
#define FUNCTION0(x) g_functions[g_cells[x].cdr].function
|
||||
#define MACRO(x) g_cells[x].cdr
|
||||
#define PORT(x) g_cells[x].cdr
|
||||
#define STRUCT(x) g_cells[x].cdr
|
||||
#define VALUE(x) g_cells[x].cdr
|
||||
#define VECTOR(x) g_cells[x].cdr
|
||||
|
||||
|
|
@ -331,6 +336,7 @@ int g_function = 0;
|
|||
#define MACRO(x) g_cells[x].macro
|
||||
#define PORT(x) g_cells[x].port
|
||||
#define REF(x) g_cells[x].ref
|
||||
#define STRUCT(x) g_cells[x].vector
|
||||
#define VALUE(x) g_cells[x].value
|
||||
#define VECTOR(x) g_cells[x].vector
|
||||
#define FUNCTION(x) g_functions[g_cells[x].function]
|
||||
|
|
@ -626,6 +632,8 @@ check_apply (SCM f, SCM e) ///((internal))
|
|||
type = "number";
|
||||
if (TYPE (f) == TSTRING)
|
||||
type = "string";
|
||||
if (TYPE (f) == TSTRUCT)
|
||||
type = "#<...>";
|
||||
if (TYPE (f) == TBROKEN_HEART)
|
||||
type = "<3";
|
||||
|
||||
|
|
@ -2043,6 +2051,7 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
|
|||
a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
|
||||
a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
|
||||
a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
|
||||
a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
|
||||
a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
|
||||
a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
|
||||
a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
|
||||
|
|
@ -2196,6 +2205,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
|
|||
#include "math.mes.i"
|
||||
#include "lib.mes.i"
|
||||
#include "vector.mes.i"
|
||||
#include "struct.mes.i"
|
||||
#include "gc.mes.i"
|
||||
#include "reader.mes.i"
|
||||
|
||||
|
|
@ -2205,6 +2215,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
|
|||
#include "mes.mes.environment.i"
|
||||
#include "posix.mes.environment.i"
|
||||
#include "reader.mes.environment.i"
|
||||
#include "struct.mes.environment.i"
|
||||
#include "vector.mes.environment.i"
|
||||
#else
|
||||
#include "mes.i"
|
||||
|
|
@ -2214,6 +2225,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
|
|||
#include "math.i"
|
||||
#include "lib.i"
|
||||
#include "vector.i"
|
||||
#include "struct.i"
|
||||
#include "gc.i"
|
||||
#include "reader.i"
|
||||
|
||||
|
|
@ -2223,6 +2235,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
|
|||
#include "mes.environment.i"
|
||||
#include "posix.environment.i"
|
||||
#include "reader.environment.i"
|
||||
#include "struct.environment.i"
|
||||
#include "vector.environment.i"
|
||||
#endif
|
||||
|
||||
|
|
@ -2403,6 +2416,7 @@ bload_env (SCM a) ///((internal))
|
|||
}
|
||||
|
||||
#include "vector.c"
|
||||
#include "struct.c"
|
||||
#include "gc.c"
|
||||
#include "reader.c"
|
||||
|
||||
|
|
|
|||
71
src/struct.c
Normal file
71
src/struct.c
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* GNU Mes --- Maxwell Equations of Software
|
||||
* Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
*
|
||||
* This file is part of GNU Mes.
|
||||
*
|
||||
* GNU Mes is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation; either version 3 of the License, or (at
|
||||
* your option) any later version.
|
||||
*
|
||||
* GNU Mes is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
SCM
|
||||
make_struct (SCM type, SCM fields, SCM printer)
|
||||
{
|
||||
long size = 2 + length__ (fields);
|
||||
SCM v = alloc (size);
|
||||
SCM x = make_cell__ (TSTRUCT, size, v);
|
||||
g_cells[v] = g_cells[vector_entry (type)];
|
||||
g_cells[v+1] = g_cells[vector_entry (printer)];
|
||||
for (long i=2; i<size; i++)
|
||||
{
|
||||
SCM e = cell_unspecified;
|
||||
if (fields != cell_nil)
|
||||
{
|
||||
e = CAR (fields);
|
||||
fields = CDR (fields);
|
||||
}
|
||||
g_cells[v+i] = g_cells[vector_entry (e)];
|
||||
}
|
||||
return x;
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_length (SCM x)
|
||||
{
|
||||
assert (TYPE (x) == TSTRUCT);
|
||||
return MAKE_NUMBER (LENGTH (x));
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_ref (SCM x, SCM i)
|
||||
{
|
||||
assert (TYPE (x) == TSTRUCT);
|
||||
assert (VALUE (i) < LENGTH (x));
|
||||
SCM e = STRUCT (x) + VALUE (i);
|
||||
if (TYPE (e) == TREF)
|
||||
e = REF (e);
|
||||
if (TYPE (e) == TCHAR)
|
||||
e = MAKE_CHAR (VALUE (e));
|
||||
if (TYPE (e) == TNUMBER)
|
||||
e = MAKE_NUMBER (VALUE (e));
|
||||
return e;
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_set_x (SCM x, SCM i, SCM e)
|
||||
{
|
||||
assert (TYPE (x) == TSTRUCT);
|
||||
assert (VALUE (i) < LENGTH (x));
|
||||
g_cells[STRUCT (x)+VALUE (i)] = g_cells[vector_entry (e)];
|
||||
return cell_unspecified;
|
||||
}
|
||||
Loading…
Reference in a new issue