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

core: Switch to pointer cells.

Browse source 
Run

   build-aux/pointer.sh

* include/mes/macros.h: Remove.
* src/*.c: Update.
* include/mes/*.h: Update.
* simple.make: Update.
* kaem.run: Update.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2020-10-18 11:34:32 +02:00
parent e4a8bdcc8f
commit 3b29abc850
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
28 changed files with 1455 additions and 1557 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
build-aux/pointer.sh
View file

@ -49,7 +49,6 @@ sed -ri \
include/mes/symbols.h \ include/mes/symbols.h \
include/mes/builtins.h \ include/mes/builtins.h \
include/m2/lib.h \ include/m2/lib.h \
include/mes/m2.h \
src/builtins.c \ src/builtins.c \
src/cc.c \ src/cc.c \
src/core.c \ src/core.c \

280
include/mes/builtins.h
View file

@ -22,159 +22,159 @@
#define __MES_BUILTINS_H #define __MES_BUILTINS_H
/* src/builtins.c */ /* src/builtins.c */
SCM make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function); struct scm *make_builtin (struct scm *builtin_type, struct scm *name, struct scm *arity, struct scm *function);
SCM builtin_name (SCM builtin); struct scm *builtin_name (struct scm *builtin);
SCM builtin_arity (SCM builtin); struct scm *builtin_arity (struct scm *builtin);
SCM builtin_p (SCM x); struct scm *builtin_p (struct scm *x);
SCM builtin_printer (SCM builtin); struct scm *builtin_printer (struct scm *builtin);
/* src/core.c */ /* src/core.c */
SCM car (SCM x); struct scm *car (struct scm *x);
SCM cdr (SCM x); struct scm *cdr (struct scm *x);
SCM list (SCM x); struct scm *list (struct scm *x);
SCM null_p (SCM x); struct scm *null_p (struct scm *x);
SCM eq_p (SCM x, SCM y); struct scm *eq_p (struct scm *x, struct scm *y);
SCM values (SCM x); struct scm *values (struct scm *x);
SCM acons (SCM key, SCM value, SCM alist); struct scm *acons (struct scm *key, struct scm *value, struct scm *alist);
SCM length (SCM x); struct scm *length (struct scm *x);
SCM error (SCM key, SCM x); struct scm *error (struct scm *key, struct scm *x);
SCM append2 (SCM x, SCM y); struct scm *append2 (struct scm *x, struct scm *y);
SCM append_reverse (SCM x, SCM y); struct scm *append_reverse (struct scm *x, struct scm *y);
SCM reverse_x_ (SCM x, SCM t); struct scm *reverse_x_ (struct scm *x, struct scm *t);
SCM assq (SCM x, SCM a); struct scm *assq (struct scm *x, struct scm *a);
SCM assoc (SCM x, SCM a); struct scm *assoc (struct scm *x, struct scm *a);
/* src/display.c */ /* src/display.c */
SCM display_ (SCM x); struct scm *display_ (struct scm *x);
SCM display_error_ (SCM x); struct scm *display_error_ (struct scm *x);
SCM display_port_ (SCM x, SCM p); struct scm *display_port_ (struct scm *x, struct scm *p);
SCM write_ (SCM x); struct scm *write_ (struct scm *x);
SCM write_error_ (SCM x); struct scm *write_error_ (struct scm *x);
SCM write_port_ (SCM x, SCM p); struct scm *write_port_ (struct scm *x, struct scm *p);
/* src/eval-apply.c */ /* src/eval-apply.c */
SCM pairlis (SCM x, SCM y, SCM a); struct scm *pairlis (struct scm *x, struct scm *y, struct scm *a);
SCM set_car_x (SCM x, SCM e); struct scm *set_car_x (struct scm *x, struct scm *e);
SCM set_cdr_x (SCM x, SCM e); struct scm *set_cdr_x (struct scm *x, struct scm *e);
SCM set_env_x (SCM x, SCM e, SCM a); struct scm *set_env_x (struct scm *x, struct scm *e, struct scm *a);
SCM add_formals (SCM formals, SCM x); struct scm *add_formals (struct scm *formals, struct scm *x);
SCM eval_apply (); struct scm *eval_apply ();
/* src/gc.c */ /* src/gc.c */
SCM cons (SCM x, SCM y); struct scm *cons (struct scm *x, struct scm *y);
SCM gc_check (); struct scm *gc_check ();
SCM gc (); struct scm *gc ();
/* src/hash.c */ /* src/hash.c */
SCM hashq (SCM x, SCM size); struct scm *hashq (struct scm *x, struct scm *size);
SCM hash (SCM x, SCM size); struct scm *hash (struct scm *x, struct scm *size);
SCM hashq_get_handle (SCM table, SCM key, SCM dflt); struct scm *hashq_get_handle (struct scm *table, struct scm *key, struct scm *dflt);
SCM hashq_ref (SCM table, SCM key, SCM dflt); struct scm *hashq_ref (struct scm *table, struct scm *key, struct scm *dflt);
SCM hash_ref (SCM table, SCM key, SCM dflt); struct scm *hash_ref (struct scm *table, struct scm *key, struct scm *dflt);
SCM hashq_set_x (SCM table, SCM key, SCM value); struct scm *hashq_set_x (struct scm *table, struct scm *key, struct scm *value);
SCM hash_set_x (SCM table, SCM key, SCM value); struct scm *hash_set_x (struct scm *table, struct scm *key, struct scm *value);
SCM hash_table_printer (SCM table); struct scm *hash_table_printer (struct scm *table);
SCM make_hash_table (SCM x); struct scm *make_hash_table (struct scm *x);
/* src/lib.c */ /* src/lib.c */
SCM type_ (SCM x); struct scm *type_ (struct scm *x);
SCM car_ (SCM x); struct scm *car_ (struct scm *x);
SCM cdr_ (SCM x); struct scm *cdr_ (struct scm *x);
SCM xassq (SCM x, SCM a); struct scm *xassq (struct scm *x, struct scm *a);
SCM memq (SCM x, SCM a); struct scm *memq (struct scm *x, struct scm *a);
SCM equal2_p (SCM a, SCM b); struct scm *equal2_p (struct scm *a, struct scm *b);
SCM last_pair (SCM x); struct scm *last_pair (struct scm *x);
SCM pair_p (SCM x); struct scm *pair_p (struct scm *x);
SCM char_to_integer (SCM x); struct scm *char_to_integer (struct scm *x);
SCM integer_to_char (SCM x); struct scm *integer_to_char (struct scm *x);
/* src/math.c */ /* src/math.c */
SCM greater_p (SCM x); struct scm *greater_p (struct scm *x);
SCM less_p (SCM x); struct scm *less_p (struct scm *x);
SCM is_p (SCM x); struct scm *is_p (struct scm *x);
SCM minus (SCM x); struct scm *minus (struct scm *x);
SCM plus (SCM x); struct scm *plus (struct scm *x);
SCM divide (SCM x); struct scm *divide (struct scm *x);
SCM modulo (SCM a, SCM b); struct scm *modulo (struct scm *a, struct scm *b);
SCM multiply (SCM x); struct scm *multiply (struct scm *x);
SCM logand (SCM x); struct scm *logand (struct scm *x);
SCM logior (SCM x); struct scm *logior (struct scm *x);
SCM lognot (SCM x); struct scm *lognot (struct scm *x);
SCM logxor (SCM x); struct scm *logxor (struct scm *x);
SCM ash (SCM n, SCM count); struct scm *ash (struct scm *n, struct scm *count);
/* src/module.c */ /* src/module.c */
SCM make_module_type (); struct scm *make_module_type ();
SCM module_printer (SCM module); struct scm *module_printer (struct scm *module);
SCM module_variable (SCM module, SCM name); struct scm *module_variable (struct scm *module, struct scm *name);
SCM module_ref (SCM module, SCM name); struct scm *module_ref (struct scm *module, struct scm *name);
SCM module_define_x (SCM module, SCM name, SCM value); struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value);
/* src/posix.c */ /* src/posix.c */
SCM exit_ (SCM x); struct scm *exit_ (struct scm *x);
SCM peek_byte (); struct scm *peek_byte ();
SCM read_byte (); struct scm *read_byte ();
SCM unread_byte (SCM i); struct scm *unread_byte (struct scm *i);
SCM peek_char (); struct scm *peek_char ();
SCM read_char (SCM port); struct scm *read_char (struct scm *port);
SCM unread_char (SCM i); struct scm *unread_char (struct scm *i);
SCM write_char (SCM i); struct scm *write_char (struct scm *i);
SCM write_byte (SCM x); struct scm *write_byte (struct scm *x);
SCM getenv_ (SCM s); struct scm *getenv_ (struct scm *s);
SCM setenv_ (SCM s, SCM v); struct scm *setenv_ (struct scm *s, struct scm *v);
SCM access_p (SCM file_name, SCM mode); struct scm *access_p (struct scm *file_name, struct scm *mode);
SCM current_input_port (); struct scm *current_input_port ();
SCM open_input_file (SCM file_name); struct scm *open_input_file (struct scm *file_name);
SCM open_input_string (SCM string); struct scm *open_input_string (struct scm *string);
SCM set_current_input_port (SCM port); struct scm *set_current_input_port (struct scm *port);
SCM current_output_port (); struct scm *current_output_port ();
SCM current_error_port (); struct scm *current_error_port ();
SCM open_output_file (SCM x); struct scm *open_output_file (struct scm *x);
SCM set_current_output_port (SCM port); struct scm *set_current_output_port (struct scm *port);
SCM set_current_error_port (SCM port); struct scm *set_current_error_port (struct scm *port);
SCM chmod_ (SCM file_name, SCM mode); struct scm *chmod_ (struct scm *file_name, struct scm *mode);
SCM isatty_p (SCM port); struct scm *isatty_p (struct scm *port);
SCM primitive_fork (); struct scm *primitive_fork ();
SCM execl_ (SCM file_name, SCM args); struct scm *execl_ (struct scm *file_name, struct scm *args);
SCM waitpid_ (SCM pid, SCM options); struct scm *waitpid_ (struct scm *pid, struct scm *options);
SCM current_time (); struct scm *current_time ();
SCM gettimeofday_ (); struct scm *gettimeofday_ ();
SCM get_internal_run_time (); struct scm *get_internal_run_time ();
SCM getcwd_ (); struct scm *getcwd_ ();
SCM dup_ (SCM port); struct scm *dup_ (struct scm *port);
SCM dup2_ (SCM old, SCM new); struct scm *dup2_ (struct scm *old, struct scm *new);
SCM delete_file (SCM file_name); struct scm *delete_file (struct scm *file_name);
/* src/reader.c */ /* src/reader.c */
SCM read_input_file_env_ (SCM e, SCM a); struct scm *read_input_file_env_ (struct scm *e, struct scm *a);
SCM read_input_file_env (SCM a); struct scm *read_input_file_env (struct scm *a);
SCM read_env (SCM a); struct scm *read_env (struct scm *a);
SCM reader_read_sexp (SCM c, SCM s, SCM a); struct scm *reader_read_sexp (struct scm *c, struct scm *s, struct scm *a);
SCM reader_read_character (); struct scm *reader_read_character ();
SCM reader_read_binary (); struct scm *reader_read_binary ();
SCM reader_read_octal (); struct scm *reader_read_octal ();
SCM reader_read_hex (); struct scm *reader_read_hex ();
SCM reader_read_string (); struct scm *reader_read_string ();
/* src/stack.c */ /* src/stack.c */
SCM frame_printer (SCM frame); struct scm *frame_printer (struct scm *frame);
SCM make_stack (SCM stack); struct scm *make_stack (struct scm *stack);
SCM stack_length (SCM stack); struct scm *stack_length (struct scm *stack);
SCM stack_ref (SCM stack, SCM index); struct scm *stack_ref (struct scm *stack, struct scm *index);
/* src/string.c */ /* src/string.c */
SCM string_equal_p (SCM a, SCM b); struct scm *string_equal_p (struct scm *a, struct scm *b);
SCM symbol_to_string (SCM symbol); struct scm *symbol_to_string (struct scm *symbol);
SCM symbol_to_keyword (SCM symbol); struct scm *symbol_to_keyword (struct scm *symbol);
SCM keyword_to_string (SCM keyword); struct scm *keyword_to_string (struct scm *keyword);
SCM string_to_symbol (SCM string); struct scm *string_to_symbol (struct scm *string);
SCM make_symbol (SCM string); struct scm *make_symbol (struct scm *string);
SCM string_to_list (SCM string); struct scm *string_to_list (struct scm *string);
SCM list_to_string (SCM list); struct scm *list_to_string (struct scm *list);
SCM read_string (SCM port); struct scm *read_string (struct scm *port);
SCM string_append (SCM x); struct scm *string_append (struct scm *x);
SCM string_length (SCM string); struct scm *string_length (struct scm *string);
SCM string_ref (SCM str, SCM k); struct scm *string_ref (struct scm *str, struct scm *k);
/* src/struct.c */ /* src/struct.c */
SCM make_struct (SCM type, SCM fields, SCM printer); struct scm *make_struct (struct scm *type, struct scm *fields, struct scm *printer);
SCM struct_length (SCM x); struct scm *struct_length (struct scm *x);
SCM struct_ref (SCM x, SCM i); struct scm *struct_ref (struct scm *x, struct scm *i);
SCM struct_set_x (SCM x, SCM i, SCM e); struct scm *struct_set_x (struct scm *x, struct scm *i, struct scm *e);
/* src/vector.c */ /* src/vector.c */
SCM make_vector (SCM x); struct scm *make_vector (struct scm *x);
SCM vector_length (SCM x); struct scm *vector_length (struct scm *x);
SCM vector_ref (SCM x, SCM i); struct scm *vector_ref (struct scm *x, struct scm *i);
SCM vector_entry (SCM x); struct scm *vector_entry (struct scm *x);
SCM vector_set_x (SCM x, SCM i, SCM e); struct scm *vector_set_x (struct scm *x, struct scm *i, struct scm *e);
SCM list_to_vector (SCM x); struct scm *list_to_vector (struct scm *x);
SCM vector_to_list (SCM v); struct scm *vector_to_list (struct scm *v);
#endif /* __MES_BUILTINS_H */ #endif /* __MES_BUILTINS_H */

24
include/mes/m2.h
View file

@ -1,24 +0,0 @@
/* -*-comment-start: "//";comment-end:""-*-
* GNU Mes --- Maxwell Equations of Software
* Copyright © 2016,2017,2018,2019 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/>.
*/
#ifndef __MES_M2_H
#define __MES_M2_H
#endif /* __MES_M2_H */

66
include/mes/macros.h
View file

@ -1,66 +0,0 @@
/* -*-comment-start: "//";comment-end:""-*-
* GNU Mes --- Maxwell Equations of Software
* Copyright © 2016,2017,2018,2019 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/>.
*/
#ifndef __MES_MACROS_H
#define __MES_MACROS_H
#define TYPE(x) g_cells[x - g_cells].type
#define CAR(x) g_cells[x - g_cells].car
#define CDR(x) g_cells[x - g_cells].cdr
#define NTYPE(x) g_news[x - g_news].type
#define NCAR(x) g_news[x - g_news].car
#define NCDR(x) g_news[x - g_news].cdr
#define STYPE(x) TYPE (g_stack_array[x])
#define SCAR(x) CAR (g_stack_array[x])
#define SCDR(x) CDR (g_stack_arraynews[x])
#define BYTES(x) g_cells[x - g_cells].bytes
#define LENGTH(x) g_cells[x - g_cells].length
#define MACRO(x) g_cells[x - g_cells].macro
#define PORT(x) g_cells[x - g_cells].port
#define REF(x) g_cells[x - g_cells].ref
#define VARIABLE(x) g_cells[x - g_cells].variable
#define CLOSURE(x) g_cells[x - g_cells].closure
#define CONTINUATION(x) g_cells[x - g_cells].continuation
#define NAME(x) g_cells[x - g_cells].name
#define STRING(x) g_cells[x - g_cells].string
#define STRUCT(x) g_cells[x - g_cells].structure
#define VALUE(x) g_cells[x - g_cells].value
#define VECTOR(x) g_cells[x - g_cells].vector
#define NLENGTH(x) g_news[x - g_news].length
#define NVALUE(x) g_news[x - g_news].value
#define NSTRING(x) g_news[x - g_news].string
#define NVECTOR(x) g_news[x - g_news].vector
#define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x))
#define CDAR(x) CDR (CAR (x))
#define CDDR(x) CDR (CDR (x))
#define CADAR(x) CAR (CDR (CAR (x)))
#define CADDR(x) CAR (CDR (CDR (x)))
#define CDADR(x) CDR (CAR (CDR (x)))
#define CDDAR(x) CDR (CDR (CAR (x)))
#endif //__MES_MACROS_H

133
include/mes/mes.h
View file

@ -29,24 +29,24 @@ struct scm
long type; long type;
union union
{ {
SCM car; struct scm *car;
char *bytes; char *bytes;
long length; long length;
SCM ref; struct scm *ref;
SCM variable; struct scm *variable;
SCM macro; struct scm *macro;
long port; long port;
}; };
union union
{ {
SCM cdr; struct scm *cdr;
SCM closure; struct scm *closure;
SCM continuation; struct scm *continuation;
char *name; char *name;
SCM string; struct scm *string;
SCM structure; struct scm *structure;
long value; long value;
SCM vector; struct scm *vector;
}; };
}; };
@ -54,24 +54,24 @@ struct scm
char *g_datadir; char *g_datadir;
int g_debug; int g_debug;
char *g_buf; char *g_buf;
SCM g_continuations; struct scm *g_continuations;
SCM g_symbols; struct scm *g_symbols;
SCM g_symbol_max; struct scm *g_symbol_max;
int g_mini; int g_mini;
/* a/env */ /* a/env */
SCM R0; struct scm *R0;
/* param 1 */ /* param 1 */
SCM R1; struct scm *R1;
/* save 2 */ /* save 2 */
SCM R2; struct scm *R2;
/* continuation */ /* continuation */
SCM R3; struct scm *R3;
/* current-module */ /* current-module */
SCM M0; struct scm *M0;
/* macro */ /* macro */
SCM g_macros; struct scm *g_macros;
SCM g_ports; struct scm *g_ports;
/* gc */ /* gc */
long ARENA_SIZE; long ARENA_SIZE;
@ -81,13 +81,13 @@ long JAM_SIZE;
long GC_SAFETY; long GC_SAFETY;
long MAX_STRING; long MAX_STRING;
char *g_arena; char *g_arena;
SCM cell_arena; struct scm *cell_arena;
SCM cell_zero; struct scm *cell_zero;
SCM g_free; struct scm *g_free;
SCM g_symbol; struct scm *g_symbol;
SCM *g_stack_array; struct scm **g_stack_array;
struct scm *g_cells; struct scm *g_cells;
struct scm *g_news; struct scm *g_news;
long g_stack; long g_stack;
@ -102,54 +102,54 @@ struct timespec *g_start_time;
struct timeval *__gettimeofday_time; struct timeval *__gettimeofday_time;
struct timespec *__get_internal_run_time_ts; struct timespec *__get_internal_run_time_ts;
SCM alloc (long n); struct scm *alloc (long n);
SCM apply (SCM f, SCM x, SCM a); struct scm *apply (struct scm *f, struct scm *x, struct scm *a);
SCM apply_builtin (SCM fn, SCM x); struct scm *apply_builtin (struct scm *fn, struct scm *x);
SCM apply_builtin0 (SCM fn); struct scm *apply_builtin0 (struct scm *fn);
SCM apply_builtin1 (SCM fn, SCM x); struct scm *apply_builtin1 (struct scm *fn, struct scm *x);
SCM apply_builtin2 (SCM fn, SCM x, SCM y); struct scm *apply_builtin2 (struct scm *fn, struct scm *x, struct scm *y);
SCM apply_builtin3 (SCM fn, SCM x, SCM y, SCM z); struct scm *apply_builtin3 (struct scm *fn, struct scm *x, struct scm *y, struct scm *z);
SCM builtin_name (SCM builtin); struct scm *builtin_name (struct scm *builtin);
SCM cstring_to_list (char const *s); struct scm *cstring_to_list (char const *s);
SCM cstring_to_symbol (char const *s); struct scm *cstring_to_symbol (char const *s);
SCM cell_ref (SCM cell, long index); struct scm *cell_ref (struct scm *cell, long index);
SCM fdisplay_ (SCM, int, int); struct scm *fdisplay_ (struct scm *, int, int);
SCM init_symbols (); struct scm *init_symbols ();
SCM init_time (SCM a); struct scm *init_time (struct scm *a);
SCM make_builtin_type (); struct scm *make_builtin_type ();
SCM make_bytes (char const *s, size_t length); struct scm *make_bytes (char const *s, size_t length);
SCM make_cell (long type, SCM car, SCM cdr); struct scm *make_cell (long type, struct scm *car, struct scm *cdr);
SCM make_char (int n); struct scm *make_char (int n);
SCM make_continuation (long n); struct scm *make_continuation (long n);
SCM make_hash_table_ (long size); struct scm *make_hash_table_ (long size);
SCM make_hashq_type (); struct scm *make_hashq_type ();
SCM make_initial_module (SCM a); struct scm *make_initial_module (struct scm *a);
SCM make_macro (SCM name, SCM x); struct scm *make_macro (struct scm *name, struct scm *x);
SCM make_number (long n); struct scm *make_number (long n);
SCM make_ref (SCM x); struct scm *make_ref (struct scm *x);
SCM make_string (char const *s, size_t length); struct scm *make_string (char const *s, size_t length);
SCM make_string0 (char const *s); struct scm *make_string0 (char const *s);
SCM make_string_port (SCM x); struct scm *make_string_port (struct scm *x);
SCM make_vector_ (long k, SCM e); struct scm *make_vector_ (long k, struct scm *e);
SCM mes_builtins (SCM a); struct scm *mes_builtins (struct scm *a);
SCM push_cc (SCM p1, SCM p2, SCM a, SCM c); struct scm *push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c);
SCM struct_ref_ (SCM x, long i); struct scm *struct_ref_ (struct scm *x, long i);
SCM struct_set_x_ (SCM x, long i, SCM e); struct scm *struct_set_x_ (struct scm *x, long i, struct scm *e);
SCM vector_ref_ (SCM x, long i); struct scm *vector_ref_ (struct scm *x, long i);
SCM vector_set_x_ (SCM x, long i, SCM e); struct scm *vector_set_x_ (struct scm *x, long i, struct scm *e);
FUNCTION builtin_function (SCM builtin); FUNCTION builtin_function (struct scm *builtin);
char *cell_bytes (SCM x); char *cell_bytes (struct scm *x);
char *news_bytes (SCM x); char *news_bytes (struct scm *x);
int peekchar (); int peekchar ();
int readchar (); int readchar ();
int unreadchar (); int unreadchar ();
long gc_free (); long gc_free ();
long length__ (SCM x); long length__ (struct scm *x);
size_t bytes_cells (size_t length); size_t bytes_cells (size_t length);
void assert_max_string (size_t i, char const *msg, char *string); void assert_max_string (size_t i, char const *msg, char *string);
void assert_msg (int check, char *msg); void assert_msg (int check, char *msg);
void assert_number (char const *name, SCM x); void assert_number (char const *name, struct scm *x);
void copy_cell (SCM to, SCM from); void copy_cell (struct scm *to, struct scm *from);
void gc_ (); void gc_ ();
void gc_dump_arena (struct scm *cells, long size); void gc_dump_arena (struct scm *cells, long size);
void gc_init (); void gc_init ();
@ -161,7 +161,6 @@ void init_symbols_ ();
#include "mes/builtins.h" #include "mes/builtins.h"
#include "mes/constants.h" #include "mes/constants.h"
#include "mes/macros.h"
#include "mes/symbols.h" #include "mes/symbols.h"
#endif /* __MES_MES_H */ #endif /* __MES_MES_H */

226
include/mes/symbols.h
View file

@ -21,121 +21,121 @@
#ifndef __MES_SYMBOLS_H #ifndef __MES_SYMBOLS_H
#define __MES_SYMBOLS_H #define __MES_SYMBOLS_H
SCM cell_nil; struct scm *cell_nil;
SCM cell_f; struct scm *cell_f;
SCM cell_t; struct scm *cell_t;
SCM cell_dot; struct scm *cell_dot;
SCM cell_arrow; struct scm *cell_arrow;
SCM cell_undefined; struct scm *cell_undefined;
SCM cell_unspecified; struct scm *cell_unspecified;
SCM cell_closure; struct scm *cell_closure;
SCM cell_circular; struct scm *cell_circular;
SCM cell_vm_apply; struct scm *cell_vm_apply;
SCM cell_vm_apply2; struct scm *cell_vm_apply2;
SCM cell_vm_begin; struct scm *cell_vm_begin;
SCM cell_vm_begin_eval; struct scm *cell_vm_begin_eval;
SCM cell_vm_begin_expand; struct scm *cell_vm_begin_expand;
SCM cell_vm_begin_expand_eval; struct scm *cell_vm_begin_expand_eval;
SCM cell_vm_begin_expand_macro; struct scm *cell_vm_begin_expand_macro;
SCM cell_vm_begin_expand_primitive_load; struct scm *cell_vm_begin_expand_primitive_load;
SCM cell_vm_begin_primitive_load; struct scm *cell_vm_begin_primitive_load;
SCM cell_vm_begin_read_input_file; struct scm *cell_vm_begin_read_input_file;
SCM cell_vm_call_with_current_continuation2; struct scm *cell_vm_call_with_current_continuation2;
SCM cell_vm_call_with_values2; struct scm *cell_vm_call_with_values2;
SCM cell_vm_eval; struct scm *cell_vm_eval;
SCM cell_vm_eval2; struct scm *cell_vm_eval2;
SCM cell_vm_eval_check_func; struct scm *cell_vm_eval_check_func;
SCM cell_vm_eval_define; struct scm *cell_vm_eval_define;
SCM cell_vm_eval_macro_expand_eval; struct scm *cell_vm_eval_macro_expand_eval;
SCM cell_vm_eval_macro_expand_expand; struct scm *cell_vm_eval_macro_expand_expand;
SCM cell_vm_eval_pmatch_car; struct scm *cell_vm_eval_pmatch_car;
SCM cell_vm_eval_pmatch_cdr; struct scm *cell_vm_eval_pmatch_cdr;
SCM cell_vm_eval_set_x; struct scm *cell_vm_eval_set_x;
SCM cell_vm_evlis; struct scm *cell_vm_evlis;
SCM cell_vm_evlis2; struct scm *cell_vm_evlis2;
SCM cell_vm_evlis3; struct scm *cell_vm_evlis3;
SCM cell_vm_if; struct scm *cell_vm_if;
SCM cell_vm_if_expr; struct scm *cell_vm_if_expr;
SCM cell_vm_macro_expand; struct scm *cell_vm_macro_expand;
SCM cell_vm_macro_expand_car; struct scm *cell_vm_macro_expand_car;
SCM cell_vm_macro_expand_cdr; struct scm *cell_vm_macro_expand_cdr;
SCM cell_vm_macro_expand_define; struct scm *cell_vm_macro_expand_define;
SCM cell_vm_macro_expand_define_macro; struct scm *cell_vm_macro_expand_define_macro;
SCM cell_vm_macro_expand_lambda; struct scm *cell_vm_macro_expand_lambda;
SCM cell_vm_macro_expand_set_x; struct scm *cell_vm_macro_expand_set_x;
SCM cell_vm_return; struct scm *cell_vm_return;
SCM cell_symbol_lambda; struct scm *cell_symbol_lambda;
SCM cell_symbol_begin; struct scm *cell_symbol_begin;
SCM cell_symbol_if; struct scm *cell_symbol_if;
SCM cell_symbol_quote; struct scm *cell_symbol_quote;
SCM cell_symbol_define; struct scm *cell_symbol_define;
SCM cell_symbol_define_macro; struct scm *cell_symbol_define_macro;
SCM cell_symbol_quasiquote; struct scm *cell_symbol_quasiquote;
SCM cell_symbol_unquote; struct scm *cell_symbol_unquote;
SCM cell_symbol_unquote_splicing; struct scm *cell_symbol_unquote_splicing;
SCM cell_symbol_syntax; struct scm *cell_symbol_syntax;
SCM cell_symbol_quasisyntax; struct scm *cell_symbol_quasisyntax;
SCM cell_symbol_unsyntax; struct scm *cell_symbol_unsyntax;
SCM cell_symbol_unsyntax_splicing; struct scm *cell_symbol_unsyntax_splicing;
SCM cell_symbol_set_x; struct scm *cell_symbol_set_x;
SCM cell_symbol_sc_expand; struct scm *cell_symbol_sc_expand;
SCM cell_symbol_macro_expand; struct scm *cell_symbol_macro_expand;
SCM cell_symbol_portable_macro_expand; struct scm *cell_symbol_portable_macro_expand;
SCM cell_symbol_sc_expander_alist; struct scm *cell_symbol_sc_expander_alist;
SCM cell_symbol_call_with_values; struct scm *cell_symbol_call_with_values;
SCM cell_symbol_call_with_current_continuation; struct scm *cell_symbol_call_with_current_continuation;
SCM cell_symbol_boot_module; struct scm *cell_symbol_boot_module;
SCM cell_symbol_current_module; struct scm *cell_symbol_current_module;
SCM cell_symbol_primitive_load; struct scm *cell_symbol_primitive_load;
SCM cell_symbol_car; struct scm *cell_symbol_car;
SCM cell_symbol_cdr; struct scm *cell_symbol_cdr;
SCM cell_symbol_not_a_number; struct scm *cell_symbol_not_a_number;
SCM cell_symbol_not_a_pair; struct scm *cell_symbol_not_a_pair;
SCM cell_symbol_system_error; struct scm *cell_symbol_system_error;
SCM cell_symbol_throw; struct scm *cell_symbol_throw;
SCM cell_symbol_unbound_variable; struct scm *cell_symbol_unbound_variable;
SCM cell_symbol_wrong_number_of_args; struct scm *cell_symbol_wrong_number_of_args;
SCM cell_symbol_wrong_type_arg; struct scm *cell_symbol_wrong_type_arg;
SCM cell_symbol_buckets; struct scm *cell_symbol_buckets;
SCM cell_symbol_builtin; struct scm *cell_symbol_builtin;
SCM cell_symbol_frame; struct scm *cell_symbol_frame;
SCM cell_symbol_hashq_table; struct scm *cell_symbol_hashq_table;
SCM cell_symbol_module; struct scm *cell_symbol_module;
SCM cell_symbol_procedure; struct scm *cell_symbol_procedure;
SCM cell_symbol_record_type; struct scm *cell_symbol_record_type;
SCM cell_symbol_size; struct scm *cell_symbol_size;
SCM cell_symbol_stack; struct scm *cell_symbol_stack;
SCM cell_symbol_argv; struct scm *cell_symbol_argv;
SCM cell_symbol_mes_datadir; struct scm *cell_symbol_mes_datadir;
SCM cell_symbol_mes_version; struct scm *cell_symbol_mes_version;
SCM cell_symbol_internal_time_units_per_second; struct scm *cell_symbol_internal_time_units_per_second;
SCM cell_symbol_compiler; struct scm *cell_symbol_compiler;
SCM cell_symbol_arch; struct scm *cell_symbol_arch;
SCM cell_symbol_pmatch_car; struct scm *cell_symbol_pmatch_car;
SCM cell_symbol_pmatch_cdr; struct scm *cell_symbol_pmatch_cdr;
SCM cell_type_bytes; struct scm *cell_type_bytes;
SCM cell_type_char; struct scm *cell_type_char;
SCM cell_type_closure; struct scm *cell_type_closure;
SCM cell_type_continuation; struct scm *cell_type_continuation;
SCM cell_type_function; struct scm *cell_type_function;
SCM cell_type_keyword; struct scm *cell_type_keyword;
SCM cell_type_macro; struct scm *cell_type_macro;
SCM cell_type_number; struct scm *cell_type_number;
SCM cell_type_pair; struct scm *cell_type_pair;
SCM cell_type_port; struct scm *cell_type_port;
SCM cell_type_ref; struct scm *cell_type_ref;
SCM cell_type_special; struct scm *cell_type_special;
SCM cell_type_string; struct scm *cell_type_string;
SCM cell_type_struct; struct scm *cell_type_struct;
SCM cell_type_symbol; struct scm *cell_type_symbol;
SCM cell_type_values; struct scm *cell_type_values;
SCM cell_type_variable; struct scm *cell_type_variable;
SCM cell_type_vector; struct scm *cell_type_vector;
SCM cell_type_broken_heart; struct scm *cell_type_broken_heart;
SCM cell_symbol_program; struct scm *cell_symbol_program;
SCM cell_symbol_test; struct scm *cell_symbol_test;
// CONSTANT SYMBOL_MAX 114 // CONSTANT SYMBOL_MAX 114
#define SYMBOL_MAX 114 #define SYMBOL_MAX 114

7
kaem.run
View file

@ -19,12 +19,6 @@
# Usage: # Usage:
# kaem --verbose --strict # kaem --verbose --strict
./build-aux/pointer.sh
./build-aux/pointer.sh
./build-aux/pointer.sh
./build-aux/pointer.sh
./build-aux/pointer.sh
mes_cpu=${mes_cpu:-x86} mes_cpu=${mes_cpu:-x86}
stage0_cpu=${stage0_cpu:-x86} stage0_cpu=${stage0_cpu:-x86}
@ -55,7 +49,6 @@ M2-Planet \
-f lib/mes/eputc.c \ -f lib/mes/eputc.c \
\ \
-f include/mes/mes.h \ -f include/mes/mes.h \
-f include/mes/m2.h \
-f include/mes/builtins.h \ -f include/mes/builtins.h \
-f include/mes/constants.h \ -f include/mes/constants.h \
-f include/mes/symbols.h \ -f include/mes/symbols.h \

1
simple.make
View file

@ -191,7 +191,6 @@ M2_PLANET_INCLUDES = \
include/m2/lib.h \ include/m2/lib.h \
include/linux/x86/syscall.h \ include/linux/x86/syscall.h \
include/mes/mes.h \ include/mes/mes.h \
include/mes/m2.h \
include/mes/builtins.h \ include/mes/builtins.h \
include/mes/constants.h \ include/mes/constants.h \
include/mes/symbols.h \ include/mes/symbols.h \

52
src/builtins.c
View file

@ -21,11 +21,11 @@
#include "mes/lib.h" #include "mes/lib.h"
#include "mes/mes.h" #include "mes/mes.h"
SCM struct scm *
make_builtin_type () /*:((internal)) */ make_builtin_type () /*:((internal)) */
{ {
SCM record_type = cell_symbol_record_type; struct scm *record_type = cell_symbol_record_type;
SCM fields = cell_nil; struct scm *fields = cell_nil;
fields = cons (cstring_to_symbol ("address"), fields); fields = cons (cstring_to_symbol ("address"), fields);
fields = cons (cstring_to_symbol ("arity"), fields); fields = cons (cstring_to_symbol ("arity"), fields);
fields = cons (cstring_to_symbol ("name"), fields); fields = cons (cstring_to_symbol ("name"), fields);
@ -34,10 +34,10 @@ make_builtin_type () /*:((internal)) */
return make_struct (record_type, fields, cell_unspecified); return make_struct (record_type, fields, cell_unspecified);
} }
SCM struct scm *
make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function) make_builtin (struct scm *builtin_type, struct scm *name, struct scm *arity, struct scm *function)
{ {
SCM values = cell_nil; struct scm *values = cell_nil;
values = cons (function, values); values = cons (function, values);
values = cons (arity, values); values = cons (arity, values);
values = cons (name, values); values = cons (name, values);
@ -45,42 +45,42 @@ make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function)
return make_struct (builtin_type, values, cstring_to_symbol ("builtin-printer")); return make_struct (builtin_type, values, cstring_to_symbol ("builtin-printer"));
} }
SCM struct scm *
builtin_name (SCM builtin) builtin_name (struct scm *builtin)
{ {
return struct_ref_ (builtin, 3); return struct_ref_ (builtin, 3);
} }
SCM struct scm *
builtin_arity (SCM builtin) builtin_arity (struct scm *builtin)
{ {
return struct_ref_ (builtin, 4); return struct_ref_ (builtin, 4);
} }
FUNCTION FUNCTION
builtin_function (SCM builtin) builtin_function (struct scm *builtin)
{ {
SCM x = struct_ref_ (builtin, 5); struct scm *x = struct_ref_ (builtin, 5);
return VALUE (x); return x->value;
} }
SCM struct scm *
builtin_p (SCM x) builtin_p (struct scm *x)
{ {
if (TYPE (x) == TSTRUCT) if (x->type == TSTRUCT)
if (struct_ref_ (x, 2) == cell_symbol_builtin) if (struct_ref_ (x, 2) == cell_symbol_builtin)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
SCM struct scm *
builtin_printer (SCM builtin) builtin_printer (struct scm *builtin)
{ {
fdputs ("#<procedure ", __stdout); fdputs ("#<procedure ", __stdout);
display_ (builtin_name (builtin)); display_ (builtin_name (builtin));
fdputc (' ', __stdout); fdputc (' ', __stdout);
SCM x = builtin_arity (builtin); struct scm *x = builtin_arity (builtin);
int arity = VALUE (x); int arity = x->value;
if (arity == -1) if (arity == -1)
fdputc ('_', __stdout); fdputc ('_', __stdout);
else else
@ -97,19 +97,19 @@ builtin_printer (SCM builtin)
fdputc ('>', __stdout); fdputc ('>', __stdout);
} }
SCM struct scm *
init_builtin (SCM builtin_type, char const *name, int arity, FUNCTION function, SCM a) init_builtin (struct scm *builtin_type, char const *name, int arity, FUNCTION function, struct scm *a)
{ {
SCM s = cstring_to_symbol (name); struct scm *s = cstring_to_symbol (name);
return acons (s, return acons (s,
make_builtin (builtin_type, symbol_to_string (s), make_number (arity), make_builtin (builtin_type, symbol_to_string (s), make_number (arity),
make_number (function)), a); make_number (function)), a);
} }
SCM struct scm *
mes_builtins (SCM a) /*:((internal)) */ mes_builtins (struct scm *a) /*:((internal)) */
{ {
SCM builtin_type = make_builtin_type (); struct scm *builtin_type = make_builtin_type ();
if (g_mini != 0) if (g_mini != 0)
{ {

24
src/cc.c
View file

@ -21,30 +21,30 @@
#include "mes/lib.h" #include "mes/lib.h"
#include "mes/mes.h" #include "mes/mes.h"
SCM struct scm *
apply_builtin0 (SCM fn) apply_builtin0 (struct scm *fn)
{ {
SCM (*fp) (void) = (function0_t) builtin_function (fn); struct scm *(*fp) (void) = (function0_t) builtin_function (fn);
return fp (); return fp ();
} }
SCM struct scm *
apply_builtin1 (SCM fn, SCM x) apply_builtin1 (struct scm *fn, struct scm *x)
{ {
SCM (*fp) (SCM) = (function1_t) builtin_function (fn); struct scm *(*fp) (struct scm *) = (function1_t) builtin_function (fn);
return fp (x); return fp (x);
} }
SCM struct scm *
apply_builtin2 (SCM fn, SCM x, SCM y) apply_builtin2 (struct scm *fn, struct scm *x, struct scm *y)
{ {
SCM (*fp) (SCM, SCM) = (function2_t) builtin_function (fn); struct scm *(*fp) (struct scm *, struct scm *) = (function2_t) builtin_function (fn);
return fp (x, y); return fp (x, y);
} }
SCM struct scm *
apply_builtin3 (SCM fn, SCM x, SCM y, SCM z) apply_builtin3 (struct scm *fn, struct scm *x, struct scm *y, struct scm *z)
{ {
SCM (*fp) (SCM, SCM, SCM) = (function3_t) builtin_function (fn); struct scm *(*fp) (struct scm *, struct scm *, struct scm *) = (function3_t) builtin_function (fn);
return fp (x, y, z); return fp (x, y, z);
} }

164
src/core.c
View file

@ -29,127 +29,127 @@
#include <stdlib.h> #include <stdlib.h>
SCM struct scm *
assoc_string (SCM x, SCM a) /*:((internal)) */ assoc_string (struct scm *x, struct scm *a) /*:((internal)) */
{ {
SCM b; struct scm *b;
while (a != cell_nil) while (a != cell_nil)
{ {
b = CAR (a); b = a->car;
if (TYPE (CAR (b)) == TSTRING) if (b->car->type == TSTRING)
if (string_equal_p (x, CAR (b)) == cell_t) if (string_equal_p (x, b->car) == cell_t)
return b; return b;
a = CDR (a); a = a->cdr;
} }
if (a != cell_nil) if (a != cell_nil)
return CAR (a); return a->car;
return cell_f; return cell_f;
} }
SCM struct scm *
car (SCM x) car (struct scm *x)
{ {
#if !__MESC_MES__ #if !__MESC_MES__
if (TYPE (x) != TPAIR) if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
#endif #endif
return CAR (x); return x->car;
} }
SCM struct scm *
cdr (SCM x) cdr (struct scm *x)
{ {
#if !__MESC_MES__ #if !__MESC_MES__
if (TYPE (x) != TPAIR) if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
#endif #endif
return CDR (x); return x->cdr;
} }
SCM struct scm *
list (SCM x) /*:((arity . n)) */ list (struct scm *x) /*:((arity . n)) */
{ {
return x; return x;
} }
SCM struct scm *
null_p (SCM x) null_p (struct scm *x)
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
SCM struct scm *
eq_p (SCM x, SCM y) eq_p (struct scm *x, struct scm *y)
{ {
if (x == y) if (x == y)
return cell_t; return cell_t;
int t = TYPE (x); int t = x->type;
if (t == TKEYWORD) if (t == TKEYWORD)
{ {
if (TYPE (y) == TKEYWORD) if (y->type == TKEYWORD)
return string_equal_p (x, y); return string_equal_p (x, y);
return cell_f; return cell_f;
} }
if (t == TCHAR) if (t == TCHAR)
{ {
if (TYPE (y) != TCHAR) if (y->type != TCHAR)
return cell_f; return cell_f;
if (VALUE (x) == VALUE (y)) if (x->value == y->value)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
if (t == TNUMBER) if (t == TNUMBER)
{ {
if (TYPE (y) != TNUMBER) if (y->type != TNUMBER)
return cell_f; return cell_f;
if (VALUE (x) == VALUE (y)) if (x->value == y->value)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
return cell_f; return cell_f;
} }
SCM struct scm *
values (SCM x) /*:((arity . n)) */ values (struct scm *x) /*:((arity . n)) */
{ {
SCM v = cons (0, x); struct scm *v = cons (0, x);
TYPE (v) = TVALUES; v->type = TVALUES;
return v; return v;
} }
SCM struct scm *
acons (SCM key, SCM value, SCM alist) acons (struct scm *key, struct scm *value, struct scm *alist)
{ {
return cons (cons (key, value), alist); return cons (cons (key, value), alist);
} }
long long
length__ (SCM x) /*:((internal)) */ length__ (struct scm *x) /*:((internal)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
n = n + 1; n = n + 1;
if (TYPE (x) != TPAIR) if (x->type != TPAIR)
return -1; return -1;
x = CDR (x); x = x->cdr;
} }
return n; return n;
} }
SCM struct scm *
length (SCM x) length (struct scm *x)
{ {
return make_number (length__ (x)); return make_number (length__ (x));
} }
SCM struct scm *
error (SCM key, SCM x) error (struct scm *key, struct scm *x)
{ {
#if !__MESC_MES__ && !__M2_PLANET__ #if !__MESC_MES__ && !__M2_PLANET__
SCM throw = module_ref (R0, cell_symbol_throw); struct scm *throw = module_ref (R0, cell_symbol_throw);
if (throw != cell_undefined) if (throw != cell_undefined)
return apply (throw, cons (key, cons (x, cell_nil)), R0); return apply (throw, cons (key, cons (x, cell_nil)), R0);
#endif #endif
@ -161,107 +161,107 @@ error (SCM key, SCM x)
exit (1); exit (1);
} }
SCM struct scm *
append2 (SCM x, SCM y) append2 (struct scm *x, struct scm *y)
{ {
if (x == cell_nil) if (x == cell_nil)
return y; return y;
if (TYPE (x) != TPAIR) if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append2"))); error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append2")));
SCM r = cell_nil; struct scm *r = cell_nil;
while (x != cell_nil) while (x != cell_nil)
{ {
r = cons (CAR (x), r); r = cons (x->car, r);
x = CDR (x); x = x->cdr;
} }
return reverse_x_ (r, y); return reverse_x_ (r, y);
} }
SCM struct scm *
append_reverse (SCM x, SCM y) append_reverse (struct scm *x, struct scm *y)
{ {
if (x == cell_nil) if (x == cell_nil)
return y; return y;
if (TYPE (x) != TPAIR) if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse"))); error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse")));
while (x != cell_nil) while (x != cell_nil)
{ {
y = cons (CAR (x), y); y = cons (x->car, y);
x = CDR (x); x = x->cdr;
} }
return y; return y;
} }
SCM struct scm *
reverse_x_ (SCM x, SCM t) reverse_x_ (struct scm *x, struct scm *t)
{ {
if (x != cell_nil && TYPE (x) != TPAIR) if (x != cell_nil && x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:reverse!"))); error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:reverse!")));
SCM r = t; struct scm *r = t;
while (x != cell_nil) while (x != cell_nil)
{ {
t = CDR (x); t = x->cdr;
CDR (x) = r; x->cdr = r;
r = x; r = x;
x = t; x = t;
} }
return r; return r;
} }
SCM struct scm *
assq (SCM x, SCM a) assq (struct scm *x, struct scm *a)
{ {
if (TYPE (a) != TPAIR) if (a->type != TPAIR)
return cell_f; return cell_f;
int t = TYPE (x); int t = x->type;
if (t == TSYMBOL || t == TSPECIAL) if (t == TSYMBOL || t == TSPECIAL)
while (a != cell_nil) while (a != cell_nil)
{ {
if (x == CAAR (a)) if (x == a->car->car)
return CAR (a); return a->car;
a = CDR (a); a = a->cdr;
} }
else if (t == TCHAR || t == TNUMBER) else if (t == TCHAR || t == TNUMBER)
{ {
long v = VALUE (x); long v = x->value;
while (a != cell_nil) while (a != cell_nil)
{ {
if (v == VALUE (CAAR (a))) if (v == a->car->car->value)
return CAR (a); return a->car;
a = CDR (a); a = a->cdr;
} }
} }
else if (t == TKEYWORD) else if (t == TKEYWORD)
{ {
while (a != cell_nil) while (a != cell_nil)
{ {
if (string_equal_p (x, CAAR (a)) == cell_t) if (string_equal_p (x, a->car->car) == cell_t)
return CAR (a); return a->car;
a = CDR (a); a = a->cdr;
} }
} }
else else
/* pointer equality, e.g. on strings. */ /* pointer equality, e.g. on strings. */
while (a != cell_nil) while (a != cell_nil)
{ {
if (x == CAAR (a)) if (x == a->car->car)
return CAR (a); return a->car;
a = CDR (a); a = a->cdr;
} }
return cell_f; return cell_f;
} }
SCM struct scm *
assoc (SCM x, SCM a) assoc (struct scm *x, struct scm *a)
{ {
if (TYPE (x) == TSTRING) if (x->type == TSTRING)
return assoc_string (x, a); return assoc_string (x, a);
while (a != cell_nil) while (a != cell_nil)
{ {
if (equal2_p (x, CAAR (a)) == cell_t) if (equal2_p (x, a->car->car) == cell_t)
return CAR (a); return a->car;
a = CDR (a); a = a->cdr;
} }
return cell_f; return cell_f;
} }

120
src/display.c
View file

@ -98,34 +98,34 @@ fdwrite_string (char *s, int length, int fd)
fdwrite_string_char (s[i], fd); fdwrite_string_char (s[i], fd);
} }
SCM display_helper (SCM x, int cont, char *sep, int fd, int write_p); struct scm *display_helper (struct scm *x, int cont, char *sep, int fd, int write_p);
SCM struct scm *
display_helper (SCM x, int cont, char *sep, int fd, int write_p) display_helper (struct scm *x, int cont, char *sep, int fd, int write_p)
{ {
fdputs (sep, fd); fdputs (sep, fd);
if (g_depth == 0) if (g_depth == 0)
return cell_unspecified; return cell_unspecified;
g_depth = g_depth - 1; g_depth = g_depth - 1;
int t = TYPE (x); int t = x->type;
if (t == TCHAR) if (t == TCHAR)
{ {
if (write_p == 0) if (write_p == 0)
fdputc (VALUE (x), fd); fdputc (x->value, fd);
else else
{ {
fdputs ("#", fd); fdputs ("#", fd);
fdwrite_char (VALUE (x), fd); fdwrite_char (x->value, fd);
} }
} }
else if (t == TCLOSURE) else if (t == TCLOSURE)
{ {
fdputs ("#<closure ", fd); fdputs ("#<closure ", fd);
SCM circ = CADR (x); struct scm *circ = x->cdr->car;
SCM name = CADR (circ); struct scm *name = circ->cdr->car;
SCM args = CAR (CDDR (x)); struct scm *args = x->cdr->cdr->car;
display_helper (CAR (name), 0, "", fd, 0); display_helper (name->car, 0, "", fd, 0);
fdputc (' ', fd); fdputc (' ', fd);
display_helper (args, 0, "", fd, 0); display_helper (args, 0, "", fd, 0);
fdputs (">", fd); fdputs (">", fd);
@ -133,48 +133,48 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
else if (t == TMACRO) else if (t == TMACRO)
{ {
fdputs ("#<macro ", fd); fdputs ("#<macro ", fd);
display_helper (CDR (x), cont, "", fd, 0); display_helper (x->cdr, cont, "", fd, 0);
fdputs (">", fd); fdputs (">", fd);
} }
else if (t == TVARIABLE) else if (t == TVARIABLE)
{ {
fdputs ("#<variable ", fd); fdputs ("#<variable ", fd);
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0); display_helper (x->variable->car, cont, "", fd, 0);
fdputs (">", fd); fdputs (">", fd);
} }
else if (t == TNUMBER) else if (t == TNUMBER)
{ {
fdputs (itoa (VALUE (x)), fd); fdputs (itoa (x->value), fd);
} }
else if (t == TPAIR) else if (t == TPAIR)
{ {
if (cont == 0) if (cont == 0)
fdputs ("(", fd); fdputs ("(", fd);
if (CAR (x) == cell_circular && CADR (x) != cell_closure) if (x->car == cell_circular && x->cdr->car != cell_closure)
{ {
fdputs ("(*circ* . ", fd); fdputs ("(*circ* . ", fd);
int i = 0; int i = 0;
x = CDR (x); x = x->cdr;
while (x != cell_nil && i < 10) while (x != cell_nil && i < 10)
{ {
i = i + 1; i = i + 1;
fdisplay_ (CAAR (x), fd, write_p); fdisplay_ (x->car->car, fd, write_p);
fdputs (" ", fd); fdputs (" ", fd);
x = CDR (x); x = x->cdr;
} }
fdputs (" ...)", fd); fdputs (" ...)", fd);
} }
else else
{ {
if (x != 0 && x != cell_nil) if (x != 0 && x != cell_nil)
fdisplay_ (CAR (x), fd, write_p); fdisplay_ (x->car, fd, write_p);
if (CDR (x) != 0 && TYPE (CDR (x)) == TPAIR) if (x->cdr != 0 && x->cdr->type == TPAIR)
display_helper (CDR (x), 1, " ", fd, write_p); display_helper (x->cdr, 1, " ", fd, write_p);
else if (CDR (x) != 0 && CDR (x) != cell_nil) else if (x->cdr != 0 && x->cdr != cell_nil)
{ {
if (TYPE (CDR (x)) != TPAIR) if (x->cdr->type != TPAIR)
fdputs (" . ", fd); fdputs (" . ", fd);
fdisplay_ (CDR (x), fd, write_p); fdisplay_ (x->cdr, fd, write_p);
} }
} }
if (cont == 0) if (cont == 0)
@ -183,52 +183,52 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
else if (t == TPORT) else if (t == TPORT)
{ {
fdputs ("#<port ", fd); fdputs ("#<port ", fd);
fdputs (itoa (PORT (x)), fd); fdputs (itoa (x->port), fd);
fdputs (" ", fd); fdputs (" ", fd);
x = STRING (x); x = x->string;
fdputc ('"', fd); fdputc ('"', fd);
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd); fdwrite_string (cell_bytes (x->string), x->length, fd);
fdputc ('"', fd); fdputc ('"', fd);
fdputs (">", fd); fdputs (">", fd);
} }
else if (t == TKEYWORD) else if (t == TKEYWORD)
{ {
fdputs ("#:", fd); fdputs ("#:", fd);
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd); fdwrite_string (cell_bytes (x->string), x->length, fd);
} }
else if (t == TSTRING) else if (t == TSTRING)
{ {
if (write_p == 1) if (write_p == 1)
{ {
fdputc ('"', fd); fdputc ('"', fd);
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd); fdwrite_string (cell_bytes (x->string), x->length, fd);
fdputc ('"', fd); fdputc ('"', fd);
} }
else else
fdputs (cell_bytes (STRING (x)), fd); fdputs (cell_bytes (x->string), fd);
} }
else if (t == TSPECIAL || t == TSYMBOL) else if (t == TSPECIAL || t == TSYMBOL)
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd); fdwrite_string (cell_bytes (x->string), x->length, fd);
else if (t == TREF) else if (t == TREF)
fdisplay_ (REF (x), fd, write_p); fdisplay_ (x->ref, fd, write_p);
else if (t == TSTRUCT) else if (t == TSTRUCT)
{ {
SCM printer = struct_ref_ (x, STRUCT_PRINTER); struct scm *printer = struct_ref_ (x, STRUCT_PRINTER);
if (TYPE (printer) == TREF) if (printer->type == TREF)
printer = REF (printer); printer = printer->ref;
if (TYPE (printer) == TCLOSURE || builtin_p (printer) == cell_t) if (printer->type == TCLOSURE || builtin_p (printer) == cell_t)
apply (printer, cons (x, cell_nil), R0); apply (printer, cons (x, cell_nil), R0);
else else
{ {
fdputs ("#<", fd); fdputs ("#<", fd);
fdisplay_ (STRUCT (x), fd, write_p); fdisplay_ (x->structure, fd, write_p);
SCM t = CAR (x); struct scm *t = x->car;
long size = LENGTH (x); long size = x->length;
long i; long i;
for (i = 2; i < size; i = i + 1) for (i = 2; i < size; i = i + 1)
{ {
fdputc (' ', fd); fdputc (' ', fd);
fdisplay_ (cell_ref (STRUCT (x), i), fd, write_p); fdisplay_ (cell_ref (x->structure, i), fd, write_p);
} }
fdputc ('>', fd); fdputc ('>', fd);
} }
@ -236,13 +236,13 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
else if (t == TVECTOR) else if (t == TVECTOR)
{ {
fdputs ("#(", fd); fdputs ("#(", fd);
SCM t = CAR (x); struct scm *t = x->car;
long i; long i;
for (i = 0; i < LENGTH (x); i = i + 1) for (i = 0; i < x->length; i = i + 1)
{ {
if (i != 0) if (i != 0)
fdputc (' ', fd); fdputc (' ', fd);
fdisplay_ (cell_ref (VECTOR (x), i), fd, write_p); fdisplay_ (cell_ref (x->vector, i), fd, write_p);
} }
fdputc (')', fd); fdputc (')', fd);
} }
@ -257,50 +257,50 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
display_ (SCM x) display_ (struct scm *x)
{ {
g_depth = 5; g_depth = 5;
return display_helper (x, 0, "", __stdout, 0); return display_helper (x, 0, "", __stdout, 0);
} }
SCM struct scm *
display_error_ (SCM x) display_error_ (struct scm *x)
{ {
g_depth = 5; g_depth = 5;
return display_helper (x, 0, "", __stderr, 0); return display_helper (x, 0, "", __stderr, 0);
} }
SCM struct scm *
display_port_ (SCM x, SCM p) display_port_ (struct scm *x, struct scm *p)
{ {
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER"); assert_msg (p->type == TNUMBER, "p->type == TNUMBER");
return fdisplay_ (x, VALUE (p), 0); return fdisplay_ (x, p->value, 0);
} }
SCM struct scm *
write_ (SCM x) write_ (struct scm *x)
{ {
g_depth = 5; g_depth = 5;
return display_helper (x, 0, "", __stdout, 1); return display_helper (x, 0, "", __stdout, 1);
} }
SCM struct scm *
write_error_ (SCM x) write_error_ (struct scm *x)
{ {
g_depth = 5; g_depth = 5;
return display_helper (x, 0, "", __stderr, 1); return display_helper (x, 0, "", __stderr, 1);
} }
SCM struct scm *
write_port_ (SCM x, SCM p) write_port_ (struct scm *x, struct scm *p)
{ {
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER"); assert_msg (p->type == TNUMBER, "p->type == TNUMBER");
return fdisplay_ (x, VALUE (p), 1); return fdisplay_ (x, p->value, 1);
} }
SCM struct scm *
fdisplay_ (SCM x, int fd, int write_p) /*:((internal)) */ fdisplay_ (struct scm *x, int fd, int write_p) /*:((internal)) */
{ {
g_depth = 5; g_depth = 5;
return display_helper (x, 0, "", fd, write_p); return display_helper (x, 0, "", fd, write_p);

524
src/eval-apply.c
View file

File diff suppressed because it is too large Load diff

182
src/gc.c
View file

@ -32,14 +32,14 @@ int g_dump_filedes;
// CONSTANT M2_CELL_SIZE 12 // CONSTANT M2_CELL_SIZE 12
char * char *
cell_bytes (SCM x) cell_bytes (struct scm *x)
{ {
char *p = x; char *p = x;
return p + (2 * sizeof (long)); return p + (2 * sizeof (long));
} }
char * char *
news_bytes (SCM x) news_bytes (struct scm *x)
{ {
char *p = x; char *p = x;
return p + (2 * sizeof (long)); return p + (2 * sizeof (long));
@ -98,12 +98,12 @@ gc_init ()
g_cells = g_cells + M2_CELL_SIZE; /* Hmm? */ g_cells = g_cells + M2_CELL_SIZE; /* Hmm? */
TYPE (cell_arena) = TVECTOR; cell_arena->type = TVECTOR;
LENGTH (cell_arena) = 1000; cell_arena->length = 1000;
VECTOR (cell_arena) = cell_zero; cell_arena->vector = cell_zero;
TYPE (cell_zero) = TCHAR; cell_zero->type = TCHAR;
VALUE (cell_zero) = 'c'; cell_zero->value = 'c';
g_free = g_cells + M2_CELL_SIZE; g_free = g_cells + M2_CELL_SIZE;
@ -128,10 +128,10 @@ gc_stats_ (char const* where)
eputs ("]\n"); eputs ("]\n");
} }
SCM struct scm *
alloc (long n) alloc (long n)
{ {
SCM x = g_free; struct scm *x = g_free;
g_free = g_free + (n * M2_CELL_SIZE); g_free = g_free + (n * M2_CELL_SIZE);
long i = g_free - g_cells; long i = g_free - g_cells;
i = i / M2_CELL_SIZE; i = i / M2_CELL_SIZE;
@ -141,51 +141,51 @@ alloc (long n)
return x; return x;
} }
SCM struct scm *
make_cell (long type, SCM car, SCM cdr) make_cell (long type, struct scm *car, struct scm *cdr)
{ {
SCM x = g_free; struct scm *x = g_free;
g_free = g_free + M2_CELL_SIZE; g_free = g_free + M2_CELL_SIZE;
long i = g_free - g_cells; long i = g_free - g_cells;
i = i / M2_CELL_SIZE; i = i / M2_CELL_SIZE;
if (i > ARENA_SIZE) if (i > ARENA_SIZE)
assert_msg (0, "alloc: out of memory"); assert_msg (0, "alloc: out of memory");
TYPE (x) = type; x->type = type;
CAR (x) = car; x->car = car;
CDR (x) = cdr; x->cdr = cdr;
return x; return x;
} }
void void
copy_cell (SCM to, SCM from) copy_cell (struct scm *to, struct scm *from)
{ {
TYPE (to) = TYPE (from); to->type = from->type;
CAR (to) = CAR (from); to->car = from->car;
CDR (to) = CDR (from); to->cdr = from->cdr;
} }
void void
copy_news (SCM to, SCM from) copy_news (struct scm *to, struct scm *from)
{ {
NTYPE (to) = TYPE (from); to->type = from->type;
NCAR (to) = CAR (from); to->car = from->car;
NCDR (to) = CDR (from); to->cdr = from->cdr;
} }
void void
copy_stack (long index, SCM from) copy_stack (long index, struct scm *from)
{ {
g_stack_array[index] = from; g_stack_array[index] = from;
} }
SCM struct scm *
cell_ref (SCM cell, long index) cell_ref (struct scm *cell, long index)
{ {
return cell + (index * M2_CELL_SIZE); return cell + (index * M2_CELL_SIZE);
} }
SCM struct scm *
cons (SCM x, SCM y) cons (struct scm *x, struct scm *y)
{ {
return make_cell (TPAIR, x, y); return make_cell (TPAIR, x, y);
} }
@ -193,16 +193,16 @@ cons (SCM x, SCM y)
size_t size_t
bytes_cells (size_t length) bytes_cells (size_t length)
{ {
return (sizeof (long) + sizeof (long) + length - 1 + sizeof (SCM)) / sizeof (SCM); return (sizeof (long) + sizeof (long) + length - 1 + sizeof (struct scm *)) / sizeof (struct scm *);
} }
SCM struct scm *
make_bytes (char const *s, size_t length) make_bytes (char const *s, size_t length)
{ {
size_t size = bytes_cells (length); size_t size = bytes_cells (length);
SCM x = alloc (size); struct scm *x = alloc (size);
TYPE (x) = TBYTES; x->type = TBYTES;
LENGTH (x) = length; x->length = length;
char *p = cell_bytes (x); char *p = cell_bytes (x);
if (length == 0) if (length == 0)
p[0] = 0; p[0] = 0;
@ -212,55 +212,55 @@ make_bytes (char const *s, size_t length)
return x; return x;
} }
SCM struct scm *
make_char (int n) make_char (int n)
{ {
return make_cell (TCHAR, 0, n); return make_cell (TCHAR, 0, n);
} }
SCM struct scm *
make_continuation (long n) make_continuation (long n)
{ {
return make_cell (TCONTINUATION, n, g_stack); return make_cell (TCONTINUATION, n, g_stack);
} }
SCM struct scm *
make_macro (SCM name, SCM x) /*:((internal)) */ make_macro (struct scm *name, struct scm *x) /*:((internal)) */
{ {
return make_cell (TMACRO, x, STRING (name)); return make_cell (TMACRO, x, name->string);
} }
SCM struct scm *
make_number (long n) make_number (long n)
{ {
return make_cell (TNUMBER, 0, n); return make_cell (TNUMBER, 0, n);
} }
SCM struct scm *
make_ref (SCM x) /*:((internal)) */ make_ref (struct scm *x) /*:((internal)) */
{ {
return make_cell (TREF, x, 0); return make_cell (TREF, x, 0);
} }
SCM struct scm *
make_string (char const *s, size_t length) make_string (char const *s, size_t length)
{ {
if (length > MAX_STRING) if (length > MAX_STRING)
assert_max_string (length, "make_string", s); assert_max_string (length, "make_string", s);
SCM x = make_cell (TSTRING, length, 0); struct scm *x = make_cell (TSTRING, length, 0);
SCM v = make_bytes (s, length + 1); struct scm *v = make_bytes (s, length + 1);
CDR (x) = v; x->cdr = v;
return x; return x;
} }
SCM struct scm *
make_string0 (char const *s) make_string0 (char const *s)
{ {
return make_string (s, strlen (s)); return make_string (s, strlen (s));
} }
SCM struct scm *
make_string_port (SCM x) /*:((internal)) */ make_string_port (struct scm *x) /*:((internal)) */
{ {
return make_cell (TPORT, -length__ (g_ports) - 2, x); return make_cell (TPORT, -length__ (g_ports) - 2, x);
} }
@ -269,17 +269,17 @@ void
gc_init_news () gc_init_news ()
{ {
g_news = g_free; g_news = g_free;
SCM ncell_arena = g_news; struct scm *ncell_arena = g_news;
SCM ncell_zero = ncell_arena + M2_CELL_SIZE; struct scm *ncell_zero = ncell_arena + M2_CELL_SIZE;
g_news = g_news + M2_CELL_SIZE; g_news = g_news + M2_CELL_SIZE;
NTYPE (ncell_arena) = TVECTOR; ncell_arena->type = TVECTOR;
NLENGTH (ncell_arena) = LENGTH (cell_arena); ncell_arena->length = cell_arena->length;
NVECTOR (ncell_arena) = g_news; ncell_arena->vector = g_news;
NTYPE (ncell_zero) = TCHAR; ncell_zero->type = TCHAR;
NVALUE (ncell_zero) = 'n'; ncell_zero->value = 'n';
} }
void void
@ -311,7 +311,7 @@ gc_up_arena ()
exit (1); exit (1);
} }
g_cells = p; g_cells = p;
memcpy (p + stack_offset, p + old_arena_bytes, STACK_SIZE * sizeof (SCM)); memcpy (p + stack_offset, p + old_arena_bytes, STACK_SIZE * sizeof (struct scm *));
g_cells = g_cells + M2_CELL_SIZE; g_cells = g_cells + M2_CELL_SIZE;
} }
@ -423,29 +423,29 @@ gc_flip ()
gc_stats_ (";;; => jam"); gc_stats_ (";;; => jam");
} }
SCM struct scm *
gc_copy (SCM old) /*:((internal)) */ gc_copy (struct scm *old) /*:((internal)) */
{ {
if (TYPE (old) == TBROKEN_HEART) if (old->type == TBROKEN_HEART)
return CAR (old); return old->car;
SCM new = g_free; struct scm *new = g_free;
g_free = g_free + M2_CELL_SIZE; g_free = g_free + M2_CELL_SIZE;
copy_news (new, old); copy_news (new, old);
if (NTYPE (new) == TSTRUCT || NTYPE (new) == TVECTOR) if (new->type == TSTRUCT || new->type == TVECTOR)
{ {
NVECTOR (new) = g_free; new->vector = g_free;
long i; long i;
for (i = 0; i < LENGTH (old); i = i + 1) for (i = 0; i < old->length; i = i + 1)
{ {
copy_news (g_free, cell_ref (VECTOR (old), i)); copy_news (g_free, cell_ref (old->vector, i));
g_free = g_free + M2_CELL_SIZE; g_free = g_free + M2_CELL_SIZE;
} }
} }
else if (NTYPE (new) == TBYTES) else if (new->type == TBYTES)
{ {
char const *src = cell_bytes (old); char const *src = cell_bytes (old);
char *dest = news_bytes (new); char *dest = news_bytes (new);
size_t length = NLENGTH (new); size_t length = new->length;
memcpy (dest, src, length); memcpy (dest, src, length);
g_free = g_free + ((bytes_cells (length) - 1) * M2_CELL_SIZE); g_free = g_free + ((bytes_cells (length) - 1) * M2_CELL_SIZE);
@ -455,43 +455,43 @@ gc_copy (SCM old) /*:((internal)) */
eputs (src); eputs (src);
eputs ("\n"); eputs ("\n");
eputs (" length: "); eputs (" length: ");
eputs (ltoa (LENGTH (old))); eputs (ltoa (old->length));
eputs ("\n"); eputs ("\n");
eputs (" nlength: "); eputs (" nlength: ");
eputs (ltoa (NLENGTH (new))); eputs (ltoa (new->length));
eputs ("\n"); eputs ("\n");
eputs (" ==> "); eputs (" ==> ");
eputs (dest); eputs (dest);
eputs ("\n"); eputs ("\n");
} }
} }
TYPE (old) = TBROKEN_HEART; old->type = TBROKEN_HEART;
CAR (old) = new; old->car = new;
return new; return new;
} }
SCM struct scm *
gc_relocate_car (SCM new, SCM car) /*:((internal)) */ gc_relocate_car (struct scm *new, struct scm *car) /*:((internal)) */
{ {
NCAR (new) = car; new->car = car;
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
gc_relocate_cdr (SCM new, SCM cdr) /*:((internal)) */ gc_relocate_cdr (struct scm *new, struct scm *cdr) /*:((internal)) */
{ {
NCDR (new) = cdr; new->cdr = cdr;
return cell_unspecified; return cell_unspecified;
} }
void void
gc_loop (SCM scan) gc_loop (struct scm *scan)
{ {
SCM car; struct scm *car;
SCM cdr; struct scm *cdr;
while (scan < g_free) while (scan < g_free)
{ {
long t = NTYPE (scan); long t = scan->type;
if (t == TBROKEN_HEART) if (t == TBROKEN_HEART)
assert_msg (0, "gc_loop: broken heart"); assert_msg (0, "gc_loop: broken heart");
/* *INDENT-OFF* */ /* *INDENT-OFF* */
@ -501,7 +501,7 @@ gc_loop (SCM scan)
|| t == TVARIABLE) || t == TVARIABLE)
/* *INDENT-ON* */ /* *INDENT-ON* */
{ {
car = gc_copy (NCAR (scan)); car = gc_copy (scan->car);
gc_relocate_car (scan, car); gc_relocate_car (scan, car);
} }
/* *INDENT-OFF* */ /* *INDENT-OFF* */
@ -520,18 +520,18 @@ gc_loop (SCM scan)
) )
/* *INDENT-ON* */ /* *INDENT-ON* */
{ {
cdr = gc_copy (NCDR (scan)); cdr = gc_copy (scan->cdr);
gc_relocate_cdr (scan, cdr); gc_relocate_cdr (scan, cdr);
} }
if (t == TBYTES) if (t == TBYTES)
scan = scan + (bytes_cells (NLENGTH (scan)) * M2_CELL_SIZE); scan = scan + (bytes_cells (scan->length) * M2_CELL_SIZE);
else else
scan = scan + M2_CELL_SIZE; scan = scan + M2_CELL_SIZE;
} }
gc_flip (); gc_flip ();
} }
SCM struct scm *
gc_check () gc_check ()
{ {
long used = ((g_free - g_cells) / M2_CELL_SIZE) + GC_SAFETY; long used = ((g_free - g_cells) / M2_CELL_SIZE) + GC_SAFETY;
@ -574,8 +574,8 @@ gc_ ()
gc_up_arena (); gc_up_arena ();
} }
SCM new_cell_nil = g_free; struct scm *new_cell_nil = g_free;
SCM s; struct scm *s;
for (s = cell_nil; s < g_symbol_max; s = s + M2_CELL_SIZE) for (s = cell_nil; s < g_symbol_max; s = s + M2_CELL_SIZE)
gc_copy (s); gc_copy (s);
@ -591,7 +591,7 @@ gc_ ()
gc_loop (new_cell_nil); gc_loop (new_cell_nil);
} }
SCM struct scm *
gc () gc ()
{ {
if (getenv ("MES_DUMP") != 0) if (getenv ("MES_DUMP") != 0)
@ -665,7 +665,7 @@ dumps (char const *s)
} }
void void
gc_dump_register (char const* n, SCM r) gc_dump_register (char const* n, struct scm *r)
{ {
dumps (n); dumps (": "); dumps (n); dumps (": ");
long i = r; long i = r;
@ -706,7 +706,7 @@ gc_dump_stack ()
void void
gc_dump_arena (struct scm *cells, long size) gc_dump_arena (struct scm *cells, long size)
{ {
SCM end = g_cells + (size * M2_CELL_SIZE); struct scm *end = g_cells + (size * M2_CELL_SIZE);
struct scm *dist = cells; struct scm *dist = cells;
if (g_dump_filedes == 0) if (g_dump_filedes == 0)
g_dump_filedes = mes_open ("dump.mo", O_CREAT|O_WRONLY, 0644); g_dump_filedes = mes_open ("dump.mo", O_CREAT|O_WRONLY, 0644);
@ -714,7 +714,7 @@ gc_dump_arena (struct scm *cells, long size)
dumps ("size="); dumps (ltoa (size)); dumpc ('\n'); dumps ("size="); dumps (ltoa (size)); dumpc ('\n');
gc_dump_state (); gc_dump_state ();
gc_dump_stack (); gc_dump_stack ();
while (TYPE (end) == 0 && CAR (end) == 0 && CDR (end) == 0) while (end->type == 0 && end->car == 0 && end->cdr == 0)
{ {
end = end - M2_CELL_SIZE; end = end - M2_CELL_SIZE;
size = size - 1; size = size - 1;

136
src/hash.c
View file

@ -36,116 +36,116 @@ hash_cstring (char const *s, long size)
} }
int int
hashq_ (SCM x, long size) hashq_ (struct scm *x, long size)
{ {
if (TYPE (x) == TSPECIAL || TYPE (x) == TSYMBOL) if (x->type == TSPECIAL || x->type == TSYMBOL)
return hash_cstring (cell_bytes (STRING (x)), size); /* FIXME: hash x directly. */ return hash_cstring (cell_bytes (x->string), size); /* FIXME: hash x directly. */
error (cell_symbol_system_error, cons (make_string0 ("hashq_: not a symbol"), x)); error (cell_symbol_system_error, cons (make_string0 ("hashq_: not a symbol"), x));
} }
int int
hash_ (SCM x, long size) hash_ (struct scm *x, long size)
{ {
if (TYPE (x) != TSTRING) if (x->type != TSTRING)
{ {
eputs ("hash_ failed, not a string:"); eputs ("hash_ failed, not a string:");
display_error_ (x); display_error_ (x);
assert_msg (0, "0"); assert_msg (0, "0");
} }
return hash_cstring (cell_bytes (STRING (x)), size); return hash_cstring (cell_bytes (x->string), size);
} }
SCM struct scm *
hashq (SCM x, SCM size) hashq (struct scm *x, struct scm *size)
{ {
eputs ("hashq not supporteed\n"); eputs ("hashq not supporteed\n");
assert_msg (0, "0"); assert_msg (0, "0");
} }
SCM struct scm *
hash (SCM x, SCM size) hash (struct scm *x, struct scm *size)
{ {
eputs ("hash not supporteed\n"); eputs ("hash not supporteed\n");
assert_msg (0, "0"); assert_msg (0, "0");
} }
SCM struct scm *
hashq_get_handle (SCM table, SCM key, SCM dflt) hashq_get_handle (struct scm *table, struct scm *key, struct scm *dflt)
{ {
SCM s = struct_ref_ (table, 3); struct scm *s = struct_ref_ (table, 3);
long size = VALUE (s); long size = s->value;
unsigned hash = hashq_ (key, size); unsigned hash = hashq_ (key, size);
SCM buckets = struct_ref_ (table, 4); struct scm *buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash); struct scm *bucket = vector_ref_ (buckets, hash);
SCM x = cell_f; struct scm *x = cell_f;
if (TYPE (dflt) == TPAIR) if (dflt->type == TPAIR)
x = CAR (dflt); x = dflt->car;
if (TYPE (bucket) == TPAIR) if (bucket->type == TPAIR)
x = assq (key, bucket); x = assq (key, bucket);
return x; return x;
} }
SCM struct scm *
hashq_ref (SCM table, SCM key, SCM dflt) hashq_ref (struct scm *table, struct scm *key, struct scm *dflt)
{ {
SCM x = hashq_get_handle (table, key, dflt); struct scm *x = hashq_get_handle (table, key, dflt);
if (x != cell_f) if (x != cell_f)
x = CDR (x); x = x->cdr;
return x; return x;
} }
SCM struct scm *
hash_ref (SCM table, SCM key, SCM dflt) hash_ref (struct scm *table, struct scm *key, struct scm *dflt)
{ {
SCM s = struct_ref_ (table, 3); struct scm *s = struct_ref_ (table, 3);
long size = VALUE (s); long size = s->value;
unsigned hash = hash_ (key, size); unsigned hash = hash_ (key, size);
SCM buckets = struct_ref_ (table, 4); struct scm *buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash); struct scm *bucket = vector_ref_ (buckets, hash);
SCM x = cell_f; struct scm *x = cell_f;
if (TYPE (dflt) == TPAIR) if (dflt->type == TPAIR)
x = CAR (dflt); x = dflt->car;
if (TYPE (bucket) == TPAIR) if (bucket->type == TPAIR)
{ {
x = assoc (key, bucket); x = assoc (key, bucket);
if (x != cell_f) if (x != cell_f)
x = CDR (x); x = x->cdr;
} }
return x; return x;
} }
SCM struct scm *
hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value) hash_set_x_ (struct scm *table, unsigned hash, struct scm *key, struct scm *value)
{ {
SCM buckets = struct_ref_ (table, 4); struct scm *buckets = struct_ref_ (table, 4);
SCM bucket = vector_ref_ (buckets, hash); struct scm *bucket = vector_ref_ (buckets, hash);
if (TYPE (bucket) != TPAIR) if (bucket->type != TPAIR)
bucket = cell_nil; bucket = cell_nil;
bucket = acons (key, value, bucket); bucket = acons (key, value, bucket);
vector_set_x_ (buckets, hash, bucket); vector_set_x_ (buckets, hash, bucket);
return value; return value;
} }
SCM struct scm *
hashq_set_x (SCM table, SCM key, SCM value) hashq_set_x (struct scm *table, struct scm *key, struct scm *value)
{ {
SCM s = struct_ref_ (table, 3); struct scm *s = struct_ref_ (table, 3);
long size = VALUE (s); long size = s->value;
unsigned hash = hashq_ (key, size); unsigned hash = hashq_ (key, size);
return hash_set_x_ (table, hash, key, value); return hash_set_x_ (table, hash, key, value);
} }
SCM struct scm *
hash_set_x (SCM table, SCM key, SCM value) hash_set_x (struct scm *table, struct scm *key, struct scm *value)
{ {
SCM s = struct_ref_ (table, 3); struct scm *s = struct_ref_ (table, 3);
long size = VALUE (s); long size = s->value;
unsigned hash = hash_ (key, size); unsigned hash = hash_ (key, size);
return hash_set_x_ (table, hash, key, value); return hash_set_x_ (table, hash, key, value);
} }
SCM struct scm *
hash_table_printer (SCM table) hash_table_printer (struct scm *table)
{ {
fdputs ("#<", __stdout); fdputs ("#<", __stdout);
display_ (struct_ref_ (table, 2)); display_ (struct_ref_ (table, 2));
@ -153,20 +153,20 @@ hash_table_printer (SCM table)
fdputs ("size: ", __stdout); fdputs ("size: ", __stdout);
display_ (struct_ref_ (table, 3)); display_ (struct_ref_ (table, 3));
fdputc (' ', __stdout); fdputc (' ', __stdout);
SCM buckets = struct_ref_ (table, 4); struct scm *buckets = struct_ref_ (table, 4);
fdputs ("buckets: ", __stdout); fdputs ("buckets: ", __stdout);
int i; int i;
for (i = 0; i < LENGTH (buckets); i = i + 1) for (i = 0; i < buckets->length; i = i + 1)
{ {
SCM e = vector_ref_ (buckets, i); struct scm *e = vector_ref_ (buckets, i);
if (e != cell_unspecified) if (e != cell_unspecified)
{ {
fdputc ('[', __stdout); fdputc ('[', __stdout);
while (TYPE (e) == TPAIR) while (e->type == TPAIR)
{ {
write_ (CAAR (e)); write_ (e->car->car);
e = CDR (e); e = e->cdr;
if (TYPE (e) == TPAIR) if (e->type == TPAIR)
fdputc (' ', __stdout); fdputc (' ', __stdout);
} }
fdputs ("]\n ", __stdout); fdputs ("]\n ", __stdout);
@ -175,10 +175,10 @@ hash_table_printer (SCM table)
fdputc ('>', __stdout); fdputc ('>', __stdout);
} }
SCM struct scm *
make_hashq_type () /*:((internal)) */ make_hashq_type () /*:((internal)) */
{ {
SCM fields = cell_nil; struct scm *fields = cell_nil;
fields = cons (cell_symbol_buckets, fields); fields = cons (cell_symbol_buckets, fields);
fields = cons (cell_symbol_size, fields); fields = cons (cell_symbol_size, fields);
fields = cons (fields, cell_nil); fields = cons (fields, cell_nil);
@ -186,15 +186,15 @@ make_hashq_type () /*:((internal)) */
return make_struct (cell_symbol_record_type, fields, cell_unspecified); return make_struct (cell_symbol_record_type, fields, cell_unspecified);
} }
SCM struct scm *
make_hash_table_ (long size) make_hash_table_ (long size)
{ {
if (size == 0) if (size == 0)
size = 100; size = 100;
SCM hashq_type = make_hashq_type (); struct scm *hashq_type = make_hashq_type ();
SCM buckets = make_vector_ (size, cell_unspecified); struct scm *buckets = make_vector_ (size, cell_unspecified);
SCM values = cell_nil; struct scm *values = cell_nil;
values = cons (buckets, values); values = cons (buckets, values);
values = cons (make_number (size), values); values = cons (make_number (size), values);
values = cons (cell_symbol_hashq_table, values); values = cons (cell_symbol_hashq_table, values);
@ -203,14 +203,14 @@ make_hash_table_ (long size)
return make_struct (hashq_type, values, cell_unspecified); return make_struct (hashq_type, values, cell_unspecified);
} }
SCM struct scm *
make_hash_table (SCM x) make_hash_table (struct scm *x)
{ {
long size = 0; long size = 0;
if (TYPE (x) == TPAIR) if (x->type == TPAIR)
{ {
assert_msg (TYPE (x) == TNUMBER, "TYPE (x) == TNUMBER"); assert_msg (x->type == TNUMBER, "x->type == TNUMBER");
size = VALUE (x); size = x->value;
} }
return make_hash_table_ (size); return make_hash_table_ (size);
} }

112
src/lib.c
View file

@ -29,54 +29,54 @@
#include <stdlib.h> #include <stdlib.h>
SCM struct scm *
type_ (SCM x) type_ (struct scm *x)
{ {
return make_number (TYPE (x)); return make_number (x->type);
} }
SCM struct scm *
car_ (SCM x) car_ (struct scm *x)
{ {
SCM a = CAR (x); struct scm *a = x->car;
if (TYPE (x) == TPAIR) if (x->type == TPAIR)
return a; return a;
return make_number (a); return make_number (a);
} }
SCM struct scm *
cdr_ (SCM x) cdr_ (struct scm *x)
{ {
SCM d = CDR (x); struct scm *d = x->cdr;
if (TYPE (x) == TPAIR || TYPE (x) == TCLOSURE) if (x->type == TPAIR || x->type == TCLOSURE)
return d; return d;
return make_number (d); return make_number (d);
} }
SCM struct scm *
xassq (SCM x, SCM a) /* For speed in core. */ xassq (struct scm *x, struct scm *a) /* For speed in core. */
{ {
while (a != cell_nil) while (a != cell_nil)
{ {
if (x == CDAR (a)) if (x == a->car->cdr)
return CAR (a); return a->car;
a = CDR (a); a = a->cdr;
} }
return cell_f; return cell_f;
} }
SCM struct scm *
memq (SCM x, SCM a) memq (struct scm *x, struct scm *a)
{ {
int t = TYPE (x); int t = x->type;
if (t == TCHAR || t == TNUMBER) if (t == TCHAR || t == TNUMBER)
{ {
long v = VALUE (x); long v = x->value;
while (a != cell_nil) while (a != cell_nil)
{ {
if (v == VALUE (CAR (a))) if (v == a->car->value)
return a; return a;
a = CDR (a); a = a->cdr;
} }
return cell_f; return cell_f;
} }
@ -84,53 +84,53 @@ memq (SCM x, SCM a)
{ {
while (a != cell_nil) while (a != cell_nil)
{ {
if (TYPE (CAR (a)) == TKEYWORD) if (a->car->type == TKEYWORD)
if (string_equal_p (x, CAR (a)) == cell_t) if (string_equal_p (x, a->car) == cell_t)
return a; return a;
a = CDR (a); a = a->cdr;
} }
return cell_f; return cell_f;
} }
while (a != cell_nil) while (a != cell_nil)
{ {
if (x == CAR (a)) if (x == a->car)
return a; return a;
a = CDR (a); a = a->cdr;
} }
return cell_f; return cell_f;
} }
SCM struct scm *
equal2_p (SCM a, SCM b) equal2_p (struct scm *a, struct scm *b)
{ {
equal2: equal2:
if (a == b) if (a == b)
return cell_t; return cell_t;
if (TYPE (a) == TPAIR && TYPE (b) == TPAIR) if (a->type == TPAIR && b->type == TPAIR)
{ {
if (equal2_p (CAR (a), CAR (b)) == cell_t) if (equal2_p (a->car, b->car) == cell_t)
{ {
a = CDR (a); a = a->cdr;
b = CDR (b); b = b->cdr;
goto equal2; goto equal2;
} }
return cell_f; return cell_f;
} }
if (TYPE (a) == TSTRING && TYPE (b) == TSTRING) if (a->type == TSTRING && b->type == TSTRING)
return string_equal_p (a, b); return string_equal_p (a, b);
if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR) if (a->type == TVECTOR && b->type == TVECTOR)
{ {
if (LENGTH (a) != LENGTH (b)) if (a->length != b->length)
return cell_f; return cell_f;
long i; long i;
for (i = 0; i < LENGTH (a); i = i + 1) for (i = 0; i < a->length; i = i + 1)
{ {
SCM ai = cell_ref (VECTOR (a), i); struct scm *ai = cell_ref (a->vector, i);
SCM bi = cell_ref (VECTOR (b), i); struct scm *bi = cell_ref (b->vector, i);
if (TYPE (ai) == TREF) if (ai->type == TREF)
ai = REF (ai); ai = ai->ref;
if (TYPE (bi) == TREF) if (bi->type == TREF)
bi = REF (bi); bi = bi->ref;
if (equal2_p (ai, bi) == cell_f) if (equal2_p (ai, bi) == cell_f)
return cell_f; return cell_f;
} }
@ -139,34 +139,34 @@ equal2:
return eq_p (a, b); return eq_p (a, b);
} }
SCM struct scm *
last_pair (SCM x) last_pair (struct scm *x)
{ {
while (x != cell_nil) while (x != cell_nil)
{ {
if (CDR (x) == cell_nil) if (x->cdr == cell_nil)
return x; return x;
x = CDR (x); x = x->cdr;
} }
return x; return x;
} }
SCM struct scm *
pair_p (SCM x) pair_p (struct scm *x)
{ {
if (TYPE (x) == TPAIR) if (x->type == TPAIR)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
SCM struct scm *
char_to_integer (SCM x) char_to_integer (struct scm *x)
{ {
return make_number (VALUE (x)); return make_number (x->value);
} }
SCM struct scm *
integer_to_char (SCM x) integer_to_char (struct scm *x)
{ {
return make_char (VALUE (x)); return make_char (x->value);
} }

16
src/m2.c
View file

@ -21,29 +21,29 @@
#include "mes/lib.h" #include "mes/lib.h"
#include "mes/mes.h" #include "mes/mes.h"
SCM struct scm *
apply_builtin0 (SCM fn) apply_builtin0 (struct scm *fn)
{ {
FUNCTION fp = builtin_function (fn); FUNCTION fp = builtin_function (fn);
return fp (); return fp ();
} }
SCM struct scm *
apply_builtin1 (SCM fn, SCM x) apply_builtin1 (struct scm *fn, struct scm *x)
{ {
FUNCTION fp = builtin_function (fn); FUNCTION fp = builtin_function (fn);
return fp (x); return fp (x);
} }
SCM struct scm *
apply_builtin2 (SCM fn, SCM x, SCM y) apply_builtin2 (struct scm *fn, struct scm *x, struct scm *y)
{ {
FUNCTION fp = builtin_function (fn); FUNCTION fp = builtin_function (fn);
return fp (x, y); return fp (x, y);
} }
SCM struct scm *
apply_builtin3 (SCM fn, SCM x, SCM y, SCM z) apply_builtin3 (struct scm *fn, struct scm *x, struct scm *y, struct scm *z)
{ {
FUNCTION fp = builtin_function (fn); FUNCTION fp = builtin_function (fn);
return fp (x, y, z); return fp (x, y, z);

134
src/math.c
View file

@ -28,28 +28,28 @@
#include <string.h> #include <string.h>
void void
assert_number (char const *name, SCM x) assert_number (char const *name, struct scm *x)
{ {
if (TYPE (x) != TNUMBER) if (x->type != TNUMBER)
{ {
eputs (name); eputs (name);
error (cell_symbol_not_a_number, x); error (cell_symbol_not_a_number, x);
} }
} }
SCM struct scm *
greater_p (SCM x) /*:((name . ">") (arity . n)) */ greater_p (struct scm *x) /*:((name . ">") (arity . n)) */
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
assert_number ("greater_p", CAR (x)); assert_number ("greater_p", x->car);
long n = VALUE (CAR (x)); long n = x->car->value;
x = CDR (x); x = x->cdr;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("greater_p", CAR (x)); assert_number ("greater_p", x->car);
SCM i = car (x); struct scm *i = car (x);
long v = VALUE (i); long v = i->value;
if (v >= n) if (v >= n)
return cell_f; return cell_f;
n = v; n = v;
@ -58,19 +58,19 @@ greater_p (SCM x) /*:((name . ">") (arity . n)) */
return cell_t; return cell_t;
} }
SCM struct scm *
less_p (SCM x) /*:((name . "<") (arity . n)) */ less_p (struct scm *x) /*:((name . "<") (arity . n)) */
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
assert_number ("less_p", CAR (x)); assert_number ("less_p", x->car);
long n = VALUE (CAR (x)); long n = x->car->value;
x = CDR (x); x = x->cdr;
while (x != cell_nil) while (x != cell_nil)
{ {
assert_number ("less_p", CAR (x)); assert_number ("less_p", x->car);
SCM i = car (x); struct scm *i = car (x);
long v = VALUE (i); long v = i->value;
if (v <= n) if (v <= n)
return cell_f; return cell_f;
n = v; n = v;
@ -79,18 +79,18 @@ less_p (SCM x) /*:((name . "<") (arity . n)) */
return cell_t; return cell_t;
} }
SCM struct scm *
is_p (SCM x) /*:((name . "=") (arity . n)) */ is_p (struct scm *x) /*:((name . "=") (arity . n)) */
{ {
if (x == cell_nil) if (x == cell_nil)
return cell_t; return cell_t;
assert_number ("is_p", CAR (x)); assert_number ("is_p", x->car);
long n = VALUE (CAR (x)); long n = x->car->value;
x = cdr (x); x = cdr (x);
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
long v = VALUE (i); long v = i->value;
if (v != n) if (v != n)
return cell_f; return cell_f;
x = cdr (x); x = cdr (x);
@ -98,57 +98,57 @@ is_p (SCM x) /*:((name . "=") (arity . n)) */
return cell_t; return cell_t;
} }
SCM struct scm *
minus (SCM x) /*:((name . "-") (arity . n)) */ minus (struct scm *x) /*:((name . "-") (arity . n)) */
{ {
assert_number ("minus", CAR (x)); assert_number ("minus", x->car);
long n = VALUE (CAR (x)); long n = x->car->value;
x = cdr (x); x = cdr (x);
if (x == cell_nil) if (x == cell_nil)
n = -n; n = -n;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("minus", i); assert_number ("minus", i);
long v = VALUE (i); long v = i->value;
n = n - v; n = n - v;
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
SCM struct scm *
plus (SCM x) /*:((name . "+") (arity . n)) */ plus (struct scm *x) /*:((name . "+") (arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("plus", i); assert_number ("plus", i);
long v = VALUE (i); long v = i->value;
n = n + v; n = n + v;
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
SCM struct scm *
divide (SCM x) /*:((name . "/") (arity . n)) */ divide (struct scm *x) /*:((name . "/") (arity . n)) */
{ {
long n = 1; long n = 1;
if (x != cell_nil) if (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("divide", i); assert_number ("divide", i);
long v = VALUE (i); long v = i->value;
n = v; n = v;
x = cdr (x); x = cdr (x);
} }
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("divide", i); assert_number ("divide", i);
long v = VALUE (i); long v = i->value;
if (v == 0) if (v == 0)
error (cstring_to_symbol ("divide-by-zero"), x); error (cstring_to_symbol ("divide-by-zero"), x);
if (n == 0) if (n == 0)
@ -159,13 +159,13 @@ divide (SCM x) /*:((name . "/") (arity . n)) */
return make_number (n); return make_number (n);
} }
SCM struct scm *
modulo (SCM a, SCM b) modulo (struct scm *a, struct scm *b)
{ {
assert_number ("modulo", a); assert_number ("modulo", a);
assert_number ("modulo", b); assert_number ("modulo", b);
long x = VALUE (a); long x = a->value;
long y = VALUE (b); long y = b->value;
if (y == 0) if (y == 0)
error (cstring_to_symbol ("divide-by-zero"), a); error (cstring_to_symbol ("divide-by-zero"), a);
while (x < 0) while (x < 0)
@ -176,81 +176,81 @@ modulo (SCM a, SCM b)
return make_number (x); return make_number (x);
} }
SCM struct scm *
multiply (SCM x) /*:((name . "*") (arity . n)) */ multiply (struct scm *x) /*:((name . "*") (arity . n)) */
{ {
long n = 1; long n = 1;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("multiply", i); assert_number ("multiply", i);
long v = VALUE (i); long v = i->value;
n = n * v; n = n * v;
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
SCM struct scm *
logand (SCM x) /*:((arity . n)) */ logand (struct scm *x) /*:((arity . n)) */
{ {
long n = -1; long n = -1;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("multiply", i); assert_number ("multiply", i);
long v = VALUE (i); long v = i->value;
n = n & v; n = n & v;
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
SCM struct scm *
logior (SCM x) /*:((arity . n)) */ logior (struct scm *x) /*:((arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("logior", i); assert_number ("logior", i);
long v = VALUE (i); long v = i->value;
n = n | v; n = n | v;
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
SCM struct scm *
lognot (SCM x) lognot (struct scm *x)
{ {
assert_number ("lognot", x); assert_number ("lognot", x);
long n = ~VALUE (x); long n = ~x->value;
return make_number (n); return make_number (n);
} }
SCM struct scm *
logxor (SCM x) /*:((arity . n)) */ logxor (struct scm *x) /*:((arity . n)) */
{ {
long n = 0; long n = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM i = car (x); struct scm *i = car (x);
assert_number ("logxor", i); assert_number ("logxor", i);
long v = VALUE (i); long v = i->value;
n = n ^ v; n = n ^ v;
x = cdr (x); x = cdr (x);
} }
return make_number (n); return make_number (n);
} }
SCM struct scm *
ash (SCM n, SCM count) ash (struct scm *n, struct scm *count)
{ {
assert_number ("ash", n); assert_number ("ash", n);
assert_number ("ash", count); assert_number ("ash", count);
long cn = VALUE (n); long cn = n->value;
long ccount = VALUE (count); long ccount = count->value;
long result; long result;
if (ccount < 0) if (ccount < 0)
result = cn >> -ccount; result = cn >> -ccount;

18
src/mes.c
View file

@ -28,10 +28,8 @@
#include <sys/time.h> #include <sys/time.h>
#include <time.h> #include <time.h>
// char const *MES_PKGDATADIR = "mes"; struct scm *
mes_g_stack (struct scm *a) /*:((internal)) */
SCM
mes_g_stack (SCM a) /*:((internal)) */
{ {
g_stack = STACK_SIZE; g_stack = STACK_SIZE;
R0 = a; R0 = a;
@ -41,10 +39,10 @@ mes_g_stack (SCM a) /*:((internal)) */
return R0; return R0;
} }
SCM struct scm *
mes_environment (int argc, char **argv) mes_environment (int argc, char **argv)
{ {
SCM a = init_symbols (); struct scm *a = init_symbols ();
char *compiler = "gnuc"; char *compiler = "gnuc";
#if __MESC__ #if __MESC__
@ -67,7 +65,7 @@ mes_environment (int argc, char **argv)
a = acons (cell_symbol_arch, make_string0 (arch), a); a = acons (cell_symbol_arch, make_string0 (arch), a);
#if !MES_MINI #if !MES_MINI
SCM lst = cell_nil; struct scm *lst = cell_nil;
int i; int i;
for (i = argc - 1; i >= 0; i = i - 1) for (i = argc - 1; i >= 0; i = i - 1)
lst = cons (make_string0 (argv[i]), lst); lst = cons (make_string0 (argv[i]), lst);
@ -150,7 +148,7 @@ open_boot ()
} }
} }
SCM struct scm *
read_boot () /*:((internal)) */ read_boot () /*:((internal)) */
{ {
R2 = read_input_file_env (R0); R2 = read_input_file_env (R0);
@ -187,7 +185,7 @@ main (int argc, char **argv, char **envp)
{ {
init (envp); init (envp);
SCM a = mes_environment (argc, argv); struct scm *a = mes_environment (argc, argv);
a = mes_builtins (a); a = mes_builtins (a);
a = init_time (a); a = init_time (a);
M0 = make_initial_module (a); M0 = make_initial_module (a);
@ -196,7 +194,7 @@ main (int argc, char **argv, char **envp)
if (g_debug > 5) if (g_debug > 5)
module_printer (M0); module_printer (M0);
SCM program = read_boot (); struct scm *program = read_boot ();
R0 = acons (cell_symbol_program, program, R0); R0 = acons (cell_symbol_program, program, R0);
push_cc (R2, cell_unspecified, R0, cell_unspecified); push_cc (R2, cell_unspecified, R0, cell_unspecified);

64
src/module.c
View file

@ -21,10 +21,10 @@
#include "mes/lib.h" #include "mes/lib.h"
#include "mes/mes.h" #include "mes/mes.h"
SCM struct scm *
make_module_type () /*:(internal)) */ make_module_type () /*:(internal)) */
{ {
SCM fields = cell_nil; struct scm *fields = cell_nil;
fields = cons (cstring_to_symbol ("globals"), fields); fields = cons (cstring_to_symbol ("globals"), fields);
fields = cons (cstring_to_symbol ("locals"), fields); fields = cons (cstring_to_symbol ("locals"), fields);
fields = cons (cstring_to_symbol ("name"), fields); fields = cons (cstring_to_symbol ("name"), fields);
@ -33,40 +33,40 @@ make_module_type () /*:(internal)) */
return make_struct (cell_symbol_record_type, fields, cell_unspecified); return make_struct (cell_symbol_record_type, fields, cell_unspecified);
} }
SCM struct scm *
make_initial_module (SCM a) /*:((internal)) */ make_initial_module (struct scm *a) /*:((internal)) */
{ {
SCM module_type = make_module_type (); struct scm *module_type = make_module_type ();
a = acons (cell_symbol_module, module_type, a); a = acons (cell_symbol_module, module_type, a);
SCM hashq_type = make_hashq_type (); struct scm *hashq_type = make_hashq_type ();
a = acons (cell_symbol_hashq_table, hashq_type, a); a = acons (cell_symbol_hashq_table, hashq_type, a);
SCM name = cons (cstring_to_symbol ("boot"), cell_nil); struct scm *name = cons (cstring_to_symbol ("boot"), cell_nil);
SCM globals = make_hash_table_ (0); struct scm *globals = make_hash_table_ (0);
SCM locals = cell_nil; struct scm *locals = cell_nil;
SCM values = cell_nil; struct scm *values = cell_nil;
values = cons (globals, values); values = cons (globals, values);
values = cons (locals, values); values = cons (locals, values);
values = cons (name, values); values = cons (name, values);
values = cons (cell_symbol_module, values); values = cons (cell_symbol_module, values);
SCM module = make_struct (module_type, values, cstring_to_symbol ("module-printer")); struct scm *module = make_struct (module_type, values, cstring_to_symbol ("module-printer"));
R0 = cell_nil; R0 = cell_nil;
R0 = cons (CADR (a), R0); R0 = cons (a->cdr->car, R0);
R0 = cons (CAR (a), R0); R0 = cons (a->car, R0);
M0 = module; M0 = module;
while (TYPE (a) == TPAIR) while (a->type == TPAIR)
{ {
module_define_x (module, CAAR (a), CDAR (a)); module_define_x (module, a->car->car, a->car->cdr);
a = CDR (a); a = a->cdr;
} }
return module; return module;
} }
SCM struct scm *
module_printer (SCM module) module_printer (struct scm *module)
{ {
fdputs ("#<", __stdout); fdputs ("#<", __stdout);
display_ (struct_ref_ (module, 2)); display_ (struct_ref_ (module, 2));
@ -77,40 +77,40 @@ module_printer (SCM module)
fdputs ("locals: ", __stdout); fdputs ("locals: ", __stdout);
display_ (struct_ref_ (module, 4)); display_ (struct_ref_ (module, 4));
fdputc (' ', __stdout); fdputc (' ', __stdout);
SCM table = struct_ref_ (module, 5); struct scm *table = struct_ref_ (module, 5);
fdputs ("globals:\n ", __stdout); fdputs ("globals:\n ", __stdout);
display_ (table); display_ (table);
fdputc ('>', __stdout); fdputc ('>', __stdout);
} }
SCM struct scm *
module_variable (SCM module, SCM name) module_variable (struct scm *module, struct scm *name)
{ {
/*SCM locals = struct_ref_ (module, 3);*/ /*struct scm *locals = struct_ref_ (module, 3);*/
SCM locals = module; struct scm *locals = module;
SCM x = assq (name, locals); struct scm *x = assq (name, locals);
if (x == cell_f) if (x == cell_f)
{ {
module = M0; module = M0;
SCM globals = struct_ref_ (module, 5); struct scm *globals = struct_ref_ (module, 5);
x = hashq_get_handle (globals, name, cell_f); x = hashq_get_handle (globals, name, cell_f);
} }
return x; return x;
} }
SCM struct scm *
module_ref (SCM module, SCM name) module_ref (struct scm *module, struct scm *name)
{ {
SCM x = module_variable (module, name); struct scm *x = module_variable (module, name);
if (x == cell_f) if (x == cell_f)
return cell_undefined; return cell_undefined;
return CDR (x); return x->cdr;
} }
SCM struct scm *
module_define_x (SCM module, SCM name, SCM value) module_define_x (struct scm *module, struct scm *name, struct scm *value)
{ {
module = M0; module = M0;
SCM globals = struct_ref_ (module, 5); struct scm *globals = struct_ref_ (module, 5);
return hashq_set_x (globals, name, value); return hashq_set_x (globals, name, value);
} }

250
src/posix.c
View file

@ -33,11 +33,11 @@
#include <sys/wait.h> #include <sys/wait.h>
#include <unistd.h> #include <unistd.h>
SCM struct scm *
exit_ (SCM x) /*:((name . "exit")) */ exit_ (struct scm *x) /*:((name . "exit")) */
{ {
assert_msg (TYPE (x) == TNUMBER, "TYPE (x) == TNUMBER"); assert_msg (x->type == TNUMBER, "x->type == TNUMBER");
exit (VALUE (x)); exit (x->value);
} }
int int
@ -49,12 +49,12 @@ peekchar ()
unreadchar (c); unreadchar (c);
return c; return c;
} }
SCM port = current_input_port (); struct scm *port = current_input_port ();
SCM string = STRING (port); struct scm *string = port->string;
size_t length = LENGTH (string); size_t length = string->length;
if (length == 0) if (length == 0)
return -1; return -1;
char const *p = cell_bytes (STRING (string)); char const *p = cell_bytes (string->string);
return p[0]; return p[0];
} }
@ -63,15 +63,15 @@ readchar ()
{ {
if (__stdin >= 0) if (__stdin >= 0)
return fdgetc (__stdin); return fdgetc (__stdin);
SCM port = current_input_port (); struct scm *port = current_input_port ();
SCM string = STRING (port); struct scm *string = port->string;
size_t length = LENGTH (string); size_t length = string->length;
if (length == 0) if (length == 0)
return -1; return -1;
char const *p = cell_bytes (STRING (string)); char const *p = cell_bytes (string->string);
int c = p[0]; int c = p[0];
p = p + 1; p = p + 1;
STRING (port) = make_string (p, length - 1); port->string = make_string (p, length - 1);
return c; return c;
} }
@ -82,243 +82,243 @@ unreadchar (int c)
return fdungetc (c, __stdin); return fdungetc (c, __stdin);
if (c == EOF) /* can't unread EOF */ if (c == EOF) /* can't unread EOF */
return c; return c;
SCM port = current_input_port (); struct scm *port = current_input_port ();
SCM string = STRING (port); struct scm *string = port->string;
size_t length = LENGTH (string); size_t length = string->length;
char *p = cell_bytes (STRING (string)); char *p = cell_bytes (string->string);
p = p - 1; p = p - 1;
string = make_string (p, length + 1); string = make_string (p, length + 1);
p = cell_bytes (STRING (string)); p = cell_bytes (string->string);
p[0] = c; p[0] = c;
STRING (port) = string; port->string = string;
return c; return c;
} }
SCM struct scm *
peek_byte () peek_byte ()
{ {
return make_number (peekchar ()); return make_number (peekchar ());
} }
SCM struct scm *
read_byte () read_byte ()
{ {
return make_number (readchar ()); return make_number (readchar ());
} }
SCM struct scm *
unread_byte (SCM i) unread_byte (struct scm *i)
{ {
unreadchar (VALUE (i)); unreadchar (i->value);
return i; return i;
} }
SCM struct scm *
peek_char () peek_char ()
{ {
return make_char (peekchar ()); return make_char (peekchar ());
} }
SCM struct scm *
read_char (SCM port) /*:((arity . n)) */ read_char (struct scm *port) /*:((arity . n)) */
{ {
int fd = __stdin; int fd = __stdin;
if (TYPE (port) == TPAIR) if (port->type == TPAIR)
if (TYPE (CAR (port)) == TNUMBER) if (port->car->type == TNUMBER)
__stdin = VALUE (CAR (port)); __stdin = port->car->value;
SCM c = make_char (readchar ()); struct scm *c = make_char (readchar ());
__stdin = fd; __stdin = fd;
return c; return c;
} }
SCM struct scm *
unread_char (SCM i) unread_char (struct scm *i)
{ {
unreadchar (VALUE (i)); unreadchar (i->value);
return i; return i;
} }
SCM struct scm *
write_char (SCM i) /*:((arity . n)) */ write_char (struct scm *i) /*:((arity . n)) */
{ {
write_byte (i); write_byte (i);
return i; return i;
} }
SCM struct scm *
write_byte (SCM x) /*:((arity . n)) */ write_byte (struct scm *x) /*:((arity . n)) */
{ {
SCM c = car (x); struct scm *c = car (x);
SCM p = cdr (x); struct scm *p = cdr (x);
int fd = __stdout; int fd = __stdout;
if (TYPE (p) == TPAIR) if (p->type == TPAIR)
{ {
SCM f = CAR (p); struct scm *f = p->car;
if (TYPE (f) == TNUMBER) if (f->type == TNUMBER)
{ {
long v = VALUE (f); long v = f->value;
if (v != 1) if (v != 1)
fd = v; fd = v;
if (v == 2) if (v == 2)
fd = __stderr; fd = __stderr;
} }
} }
char cc = VALUE (c); char cc = c->value;
write (fd, &cc, 1); write (fd, &cc, 1);
#if !__MESC__ #if !__MESC__
assert_msg (TYPE (c) == TNUMBER || TYPE (c) == TCHAR, "TYPE (c) == TNUMBER || TYPE (c) == TCHAR"); assert_msg (c->type == TNUMBER || c->type == TCHAR, "c->type == TNUMBER || c->type == TCHAR");
#endif #endif
return c; return c;
} }
SCM struct scm *
getenv_ (SCM s) /*:((name . "getenv")) */ getenv_ (struct scm *s) /*:((name . "getenv")) */
{ {
char *p; char *p;
p = getenv (cell_bytes (STRING (s))); p = getenv (cell_bytes (s->string));
if (p != 0) if (p != 0)
return make_string0 (p); return make_string0 (p);
return cell_f; return cell_f;
} }
SCM struct scm *
setenv_ (SCM s, SCM v) /*:((name . "setenv")) */ setenv_ (struct scm *s, struct scm *v) /*:((name . "setenv")) */
{ {
char *buf = __setenv_buf; char *buf = __setenv_buf;
strcpy (buf, cell_bytes (STRING (s))); strcpy (buf, cell_bytes (s->string));
setenv (buf, cell_bytes (STRING (v)), 1); setenv (buf, cell_bytes (v->string), 1);
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
access_p (SCM file_name, SCM mode) access_p (struct scm *file_name, struct scm *mode)
{ {
int result = access (cell_bytes (STRING (file_name)), VALUE (mode)); int result = access (cell_bytes (file_name->string), mode->value);
if (result == 0) if (result == 0)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
SCM struct scm *
current_input_port () current_input_port ()
{ {
if (__stdin >= 0) if (__stdin >= 0)
return make_number (__stdin); return make_number (__stdin);
SCM x = g_ports; struct scm *x = g_ports;
while (x != 0) while (x != 0)
{ {
SCM a = CAR (x); struct scm *a = x->car;
if (PORT (a) == __stdin) if (a->port == __stdin)
return a; return a;
x = CDR (x); x = x->cdr;
} }
return CAR (x); return x->car;
} }
SCM struct scm *
open_input_file (SCM file_name) open_input_file (struct scm *file_name)
{ {
int filedes = mes_open (cell_bytes (STRING (file_name)), O_RDONLY, 0); int filedes = mes_open (cell_bytes (file_name->string), O_RDONLY, 0);
if (filedes == -1) if (filedes == -1)
error (cell_symbol_system_error, cons (make_string0 ("No such file or directory"), file_name)); error (cell_symbol_system_error, cons (make_string0 ("No such file or directory"), file_name));
return make_number (filedes); return make_number (filedes);
} }
SCM struct scm *
open_input_string (SCM string) open_input_string (struct scm *string)
{ {
SCM port = make_string_port (string); struct scm *port = make_string_port (string);
g_ports = cons (port, g_ports); g_ports = cons (port, g_ports);
return port; return port;
} }
SCM struct scm *
set_current_input_port (SCM port) set_current_input_port (struct scm *port)
{ {
SCM prev = current_input_port (); struct scm *prev = current_input_port ();
if (TYPE (port) == TNUMBER) if (port->type == TNUMBER)
{ {
int p = VALUE (port); int p = port->value;
if (p != 0) if (p != 0)
__stdin = p; __stdin = p;
else else
__stdin = STDIN; __stdin = STDIN;
} }
else if (TYPE (port) == TPORT) else if (port->type == TPORT)
__stdin = PORT (port); __stdin = port->port;
return prev; return prev;
} }
SCM struct scm *
current_output_port () current_output_port ()
{ {
return make_number (__stdout); return make_number (__stdout);
} }
SCM struct scm *
current_error_port () current_error_port ()
{ {
return make_number (__stderr); return make_number (__stderr);
} }
SCM struct scm *
open_output_file (SCM x) /*:((arity . n)) */ open_output_file (struct scm *x) /*:((arity . n)) */
{ {
SCM file_name = car (x); struct scm *file_name = car (x);
x = cdr (x); x = cdr (x);
int mode = S_IRUSR | S_IWUSR; int mode = S_IRUSR | S_IWUSR;
if (TYPE (x) == TPAIR) if (x->type == TPAIR)
{ {
SCM i = car (x); struct scm *i = car (x);
if (TYPE (i) == TNUMBER) if (i->type == TNUMBER)
mode = VALUE (i); mode = i->value;
} }
return make_number (mes_open (cell_bytes (STRING (file_name)), O_WRONLY | O_CREAT | O_TRUNC, mode)); return make_number (mes_open (cell_bytes (file_name->string), O_WRONLY | O_CREAT | O_TRUNC, mode));
} }
SCM struct scm *
set_current_output_port (SCM port) set_current_output_port (struct scm *port)
{ {
if (VALUE (port) != 0) if (port->value != 0)
__stdout = VALUE (port); __stdout = port->value;
else else
__stdout = STDOUT; __stdout = STDOUT;
return current_output_port (); return current_output_port ();
} }
SCM struct scm *
set_current_error_port (SCM port) set_current_error_port (struct scm *port)
{ {
if (VALUE (port) != 0) if (port->value != 0)
__stderr = VALUE (port); __stderr = port->value;
else else
__stderr = STDERR; __stderr = STDERR;
return current_error_port (); return current_error_port ();
} }
SCM struct scm *
chmod_ (SCM file_name, SCM mode) /*:((name . "chmod")) */ chmod_ (struct scm *file_name, struct scm *mode) /*:((name . "chmod")) */
{ {
chmod (cell_bytes (STRING (file_name)), VALUE (mode)); chmod (cell_bytes (file_name->string), mode->value);
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
isatty_p (SCM port) isatty_p (struct scm *port)
{ {
if (isatty (VALUE (port)) != 0) if (isatty (port->value) != 0)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
SCM struct scm *
primitive_fork () primitive_fork ()
{ {
return make_number (fork ()); return make_number (fork ());
} }
SCM struct scm *
execl_ (SCM file_name, SCM args) /*:((name . "execl")) */ execl_ (struct scm *file_name, struct scm *args) /*:((name . "execl")) */
{ {
char **c_argv = __execl_c_argv; char **c_argv = __execl_c_argv;
int i = 0; int i = 0;
@ -326,15 +326,15 @@ execl_ (SCM file_name, SCM args) /*:((name . "execl")) */
if (length__ (args) > 1000) if (length__ (args) > 1000)
error (cell_symbol_system_error, error (cell_symbol_system_error,
cons (file_name, cons (make_string0 ("too many arguments"), cons (file_name, args)))); cons (file_name, cons (make_string0 ("too many arguments"), cons (file_name, args))));
c_argv[i] = cell_bytes (STRING (file_name)); c_argv[i] = cell_bytes (file_name->string);
i = i + 1; i = i + 1;
while (args != cell_nil) while (args != cell_nil)
{ {
assert_msg (TYPE (CAR (args)) == TSTRING, "TYPE (CAR (args)) == TSTRING"); assert_msg (args->car->type == TSTRING, "args->car->type == TSTRING");
SCM arg = CAR (args); struct scm *arg = args->car;
c_argv[i] = cell_bytes (STRING (arg)); c_argv[i] = cell_bytes (arg->string);
i = i + 1; i = i + 1;
args = CDR (args); args = args->cdr;
if (g_debug > 2) if (g_debug > 2)
{ {
eputs ("arg["); eputs ("arg[");
@ -348,11 +348,11 @@ execl_ (SCM file_name, SCM args) /*:((name . "execl")) */
return make_number (execv (c_argv[0], c_argv)); return make_number (execv (c_argv[0], c_argv));
} }
SCM struct scm *
waitpid_ (SCM pid, SCM options) waitpid_ (struct scm *pid, struct scm *options)
{ {
int status; int status;
int child = waitpid (VALUE (pid), &status, VALUE (options)); int child = waitpid (pid->value, &status, options->value);
return cons (make_number (child), make_number (status)); return cons (make_number (child), make_number (status));
} }
@ -366,20 +366,20 @@ waitpid_ (SCM pid, SCM options)
#define TIME_UNITS_PER_SECOND 1000 #define TIME_UNITS_PER_SECOND 1000
#endif #endif
SCM struct scm *
init_time (SCM a) /*:((internal)) */ init_time (struct scm *a) /*:((internal)) */
{ {
clock_gettime (CLOCK_PROCESS_CPUTIME_ID, g_start_time); clock_gettime (CLOCK_PROCESS_CPUTIME_ID, g_start_time);
a = acons (cell_symbol_internal_time_units_per_second, make_number (TIME_UNITS_PER_SECOND), a); a = acons (cell_symbol_internal_time_units_per_second, make_number (TIME_UNITS_PER_SECOND), a);
} }
SCM struct scm *
current_time () current_time ()
{ {
return make_number (time (0)); return make_number (time (0));
} }
SCM struct scm *
gettimeofday_ () /*:((name . "gettimeofday")) */ gettimeofday_ () /*:((name . "gettimeofday")) */
{ {
struct timeval *time = __gettimeofday_time; struct timeval *time = __gettimeofday_time;
@ -393,7 +393,7 @@ seconds_and_nanoseconds_to_long (long s, long ns)
return s * TIME_UNITS_PER_SECOND + ns / (1000000000 / TIME_UNITS_PER_SECOND); return s * TIME_UNITS_PER_SECOND + ns / (1000000000 / TIME_UNITS_PER_SECOND);
} }
SCM struct scm *
get_internal_run_time () get_internal_run_time ()
{ {
struct timespec *ts = __get_internal_run_time_ts; struct timespec *ts = __get_internal_run_time_ts;
@ -403,29 +403,29 @@ get_internal_run_time ()
return make_number (time); return make_number (time);
} }
SCM struct scm *
getcwd_ () /*:((name . "getcwd")) */ getcwd_ () /*:((name . "getcwd")) */
{ {
char *buf = __getcwd_buf; char *buf = __getcwd_buf;
return make_string0 (getcwd (buf, PATH_MAX)); return make_string0 (getcwd (buf, PATH_MAX));
} }
SCM struct scm *
dup_ (SCM port) /*:((name . "dup")) */ dup_ (struct scm *port) /*:((name . "dup")) */
{ {
return make_number (dup (VALUE (port))); return make_number (dup (port->value));
} }
SCM struct scm *
dup2_ (SCM old, SCM new) /*:((name . "dup2")) */ dup2_ (struct scm *old, struct scm *new) /*:((name . "dup2")) */
{ {
dup2 (VALUE (old), VALUE (new)); dup2 (old->value, new->value);
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
delete_file (SCM file_name) delete_file (struct scm *file_name)
{ {
unlink (cell_bytes (STRING (file_name))); unlink (cell_bytes (file_name->string));
return cell_unspecified; return cell_unspecified;
} }

68
src/reader.c
View file

@ -26,16 +26,16 @@
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
SCM struct scm *
read_input_file_env_ (SCM e, SCM a) read_input_file_env_ (struct scm *e, struct scm *a)
{ {
if (e == cell_nil) if (e == cell_nil)
return e; return e;
return cons (e, read_input_file_env_ (read_env (a), a)); return cons (e, read_input_file_env_ (read_env (a), a));
} }
SCM struct scm *
read_input_file_env (SCM a) read_input_file_env (struct scm *a)
{ {
return read_input_file_env_ (read_env (cell_nil), cell_nil); return read_input_file_env_ (read_env (cell_nil), cell_nil);
} }
@ -52,9 +52,9 @@ reader_read_line_comment (int c)
error (cell_symbol_system_error, make_string0 ("reader_read_line_comment")); error (cell_symbol_system_error, make_string0 ("reader_read_line_comment"));
} }
SCM reader_read_block_comment (int s, int c); struct scm *reader_read_block_comment (int s, int c);
SCM reader_read_hash (int c, SCM a); struct scm *reader_read_hash (int c, struct scm *a);
SCM reader_read_list (int c, SCM a); struct scm *reader_read_list (int c, struct scm *a);
int int
reader_identifier_p (int c) reader_identifier_p (int c)
@ -68,7 +68,7 @@ reader_end_of_word_p (int c)
return (c == '"' || c == ';' || c == '(' || c == ')' || isspace (c) || c == EOF); return (c == '"' || c == ';' || c == '(' || c == ')' || isspace (c) || c == EOF);
} }
SCM struct scm *
reader_read_identifier_or_number (int c) reader_read_identifier_or_number (int c)
{ {
int i = 0; int i = 0;
@ -110,8 +110,8 @@ reader_read_identifier_or_number (int c)
return cstring_to_symbol (g_buf); return cstring_to_symbol (g_buf);
} }
SCM struct scm *
reader_read_sexp_ (int c, SCM a) reader_read_sexp_ (int c, struct scm *a)
{ {
reset_reader: reset_reader:
if (c == EOF) if (c == EOF)
@ -173,30 +173,30 @@ reader_eat_whitespace (int c)
return c; return c;
} }
SCM struct scm *
reader_read_list (int c, SCM a) reader_read_list (int c, struct scm *a)
{ {
c = reader_eat_whitespace (c); c = reader_eat_whitespace (c);
if (c == ')') if (c == ')')
return cell_nil; return cell_nil;
if (c == EOF) if (c == EOF)
error (cell_symbol_not_a_pair, make_string0 ("EOF in list")); error (cell_symbol_not_a_pair, make_string0 ("EOF in list"));
SCM s = reader_read_sexp_ (c, a); struct scm *s = reader_read_sexp_ (c, a);
if (s == cell_dot) if (s == cell_dot)
{ {
s = reader_read_list (readchar (), a); s = reader_read_list (readchar (), a);
return CAR (s); return s->car;
} }
return cons (s, reader_read_list (readchar (), a)); return cons (s, reader_read_list (readchar (), a));
} }
SCM struct scm *
read_env (SCM a) read_env (struct scm *a)
{ {
return reader_read_sexp_ (readchar (), a); return reader_read_sexp_ (readchar (), a);
} }
SCM struct scm *
reader_read_block_comment (int s, int c) reader_read_block_comment (int s, int c)
{ {
if (c == s) if (c == s)
@ -205,8 +205,8 @@ reader_read_block_comment (int s, int c)
return reader_read_block_comment (s, readchar ()); return reader_read_block_comment (s, readchar ());
} }
SCM struct scm *
reader_read_hash (int c, SCM a) reader_read_hash (int c, struct scm *a)
{ {
if (c == '!') if (c == '!')
{ {
@ -238,9 +238,9 @@ reader_read_hash (int c, SCM a)
return cons (cell_symbol_quasisyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil)); return cons (cell_symbol_quasisyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
if (c == ':') if (c == ':')
{ {
SCM x = reader_read_identifier_or_number (readchar ()); struct scm *x = reader_read_identifier_or_number (readchar ());
SCM msg = make_string0 ("keyword perifx ':' not followed by a symbol: "); struct scm *msg = make_string0 ("keyword perifx ':' not followed by a symbol: ");
if (TYPE (x) == TNUMBER) if (x->type == TNUMBER)
error (cell_symbol_system_error, cons (msg, x)); error (cell_symbol_system_error, cons (msg, x));
return symbol_to_keyword (x); return symbol_to_keyword (x);
} }
@ -262,13 +262,13 @@ reader_read_hash (int c, SCM a)
return reader_read_sexp_ (readchar (), a); return reader_read_sexp_ (readchar (), a);
} }
SCM struct scm *
reader_read_sexp (SCM c, SCM s, SCM a) reader_read_sexp (struct scm *c, struct scm *s, struct scm *a)
{ {
return reader_read_sexp_ (VALUE (c), a); return reader_read_sexp_ (c->value, a);
} }
SCM struct scm *
reader_read_character () reader_read_character ()
{ {
int c = readchar (); int c = readchar ();
@ -286,8 +286,8 @@ reader_read_character ()
} }
else if (c == 'x' && ((p >= '0' && p <= '9') || (p >= 'a' && p <= 'f') || (p >= 'F' && p <= 'F'))) else if (c == 'x' && ((p >= '0' && p <= '9') || (p >= 'a' && p <= 'f') || (p >= 'F' && p <= 'F')))
{ {
SCM n = reader_read_hex (); struct scm *n = reader_read_hex ();
c = VALUE (n); c = n->value;
eputs ("reading hex c="); eputs ("reading hex c=");
eputs (itoa (c)); eputs (itoa (c));
eputs ("\n"); eputs ("\n");
@ -354,7 +354,7 @@ reader_read_character ()
return make_char (c); return make_char (c);
} }
SCM struct scm *
reader_read_binary () reader_read_binary ()
{ {
long n = 0; long n = 0;
@ -378,7 +378,7 @@ reader_read_binary ()
return make_number (n); return make_number (n);
} }
SCM struct scm *
reader_read_octal () reader_read_octal ()
{ {
long n = 0; long n = 0;
@ -402,7 +402,7 @@ reader_read_octal ()
return make_number (n); return make_number (n);
} }
SCM struct scm *
reader_read_hex () reader_read_hex ()
{ {
long n = 0; long n = 0;
@ -431,7 +431,7 @@ reader_read_hex ()
return make_number (n); return make_number (n);
} }
SCM struct scm *
reader_read_string () reader_read_string ()
{ {
size_t i = 0; size_t i = 0;
@ -472,8 +472,8 @@ reader_read_string ()
c = 27; c = 27;
else if (c == 'x') else if (c == 'x')
{ {
SCM n = reader_read_hex (); struct scm *n = reader_read_hex ();
c = VALUE (n); c = n->value;
} }
} }
g_buf[i] = c; g_buf[i] = c;

46
src/stack.c
View file

@ -24,8 +24,8 @@
#include <stdlib.h> #include <stdlib.h>
SCM struct scm *
frame_printer (SCM frame) frame_printer (struct scm *frame)
{ {
fdputs ("#<", __stdout); fdputs ("#<", __stdout);
display_ (struct_ref_ (frame, 2)); display_ (struct_ref_ (frame, 2));
@ -35,22 +35,22 @@ frame_printer (SCM frame)
fdputc ('>', __stdout); fdputc ('>', __stdout);
} }
SCM struct scm *
make_frame_type () /*:((internal)) */ make_frame_type () /*:((internal)) */
{ {
SCM fields = cell_nil; struct scm *fields = cell_nil;
fields = cons (cell_symbol_procedure, fields); fields = cons (cell_symbol_procedure, fields);
fields = cons (fields, cell_nil); fields = cons (fields, cell_nil);
fields = cons (cell_symbol_frame, fields); fields = cons (cell_symbol_frame, fields);
return make_struct (cell_symbol_record_type, fields, cell_unspecified); return make_struct (cell_symbol_record_type, fields, cell_unspecified);
} }
SCM struct scm *
make_frame (SCM stack, long index) make_frame (struct scm *stack, long index)
{ {
SCM frame_type = make_frame_type (); struct scm *frame_type = make_frame_type ();
long array_index = 0; long array_index = 0;
SCM procedure = 0; struct scm *procedure = 0;
if (index != 0) if (index != 0)
{ {
array_index = (STACK_SIZE - (index * FRAME_SIZE)); array_index = (STACK_SIZE - (index * FRAME_SIZE));
@ -58,50 +58,50 @@ make_frame (SCM stack, long index)
} }
if (procedure == 0) if (procedure == 0)
procedure = cell_f; procedure = cell_f;
SCM values = cell_nil; struct scm *values = cell_nil;
values = cons (procedure, values); values = cons (procedure, values);
values = cons (cell_symbol_frame, values); values = cons (cell_symbol_frame, values);
return make_struct (frame_type, values, cstring_to_symbol ("frame-printer")); return make_struct (frame_type, values, cstring_to_symbol ("frame-printer"));
} }
SCM struct scm *
make_stack_type () /*:((internal)) */ make_stack_type () /*:((internal)) */
{ {
SCM fields = cell_nil; struct scm *fields = cell_nil;
fields = cons (cstring_to_symbol ("frames"), fields); fields = cons (cstring_to_symbol ("frames"), fields);
fields = cons (fields, cell_nil); fields = cons (fields, cell_nil);
fields = cons (cell_symbol_stack, fields); fields = cons (cell_symbol_stack, fields);
return make_struct (cell_symbol_record_type, fields, cell_unspecified); return make_struct (cell_symbol_record_type, fields, cell_unspecified);
} }
SCM struct scm *
make_stack (SCM stack) /*:((arity . n)) */ make_stack (struct scm *stack) /*:((arity . n)) */
{ {
SCM stack_type = make_stack_type (); struct scm *stack_type = make_stack_type ();
long size = (STACK_SIZE - g_stack) / FRAME_SIZE; long size = (STACK_SIZE - g_stack) / FRAME_SIZE;
SCM frames = make_vector_ (size, cell_unspecified); struct scm *frames = make_vector_ (size, cell_unspecified);
long i; long i;
for (i = 0; i < size; i = i + 1) for (i = 0; i < size; i = i + 1)
{ {
SCM frame = make_frame (stack, i); struct scm *frame = make_frame (stack, i);
vector_set_x_ (frames, i, frame); vector_set_x_ (frames, i, frame);
} }
SCM values = cell_nil; struct scm *values = cell_nil;
values = cons (frames, values); values = cons (frames, values);
values = cons (cell_symbol_stack, values); values = cons (cell_symbol_stack, values);
return make_struct (stack_type, values, cell_unspecified); return make_struct (stack_type, values, cell_unspecified);
} }
SCM struct scm *
stack_length (SCM stack) stack_length (struct scm *stack)
{ {
SCM frames = struct_ref_ (stack, 3); struct scm *frames = struct_ref_ (stack, 3);
return vector_length (frames); return vector_length (frames);
} }
SCM struct scm *
stack_ref (SCM stack, SCM index) stack_ref (struct scm *stack, struct scm *index)
{ {
SCM frames = struct_ref_ (stack, 3); struct scm *frames = struct_ref_ (stack, 3);
return vector_ref (frames, index); return vector_ref (frames, index);
} }

126
src/string.c
View file

@ -40,7 +40,7 @@ assert_max_string (size_t i, char const *msg, char *string)
} }
char const * char const *
list_to_cstring (SCM list, size_t *size) list_to_cstring (struct scm *list, size_t *size)
{ {
size_t i = 0; size_t i = 0;
char *p = g_buf; char *p = g_buf;
@ -48,8 +48,8 @@ list_to_cstring (SCM list, size_t *size)
{ {
if (i > MAX_STRING) if (i > MAX_STRING)
assert_max_string (i, "list_to_string", g_buf); assert_max_string (i, "list_to_string", g_buf);
SCM x = car (list); struct scm *x = car (list);
g_buf[i] = VALUE (x); g_buf[i] = x->value;
i = i + 1; i = i + 1;
list = cdr (list); list = cdr (list);
} }
@ -59,16 +59,16 @@ list_to_cstring (SCM list, size_t *size)
return g_buf; return g_buf;
} }
SCM struct scm *
string_equal_p (SCM a, SCM b) /*:((name . "string=?")) */ string_equal_p (struct scm *a, struct scm *b) /*:((name . "string=?")) */
{ {
if (!((TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD))) if (!((a->type == TSTRING && b->type == TSTRING) || (a->type == TKEYWORD || b->type == TKEYWORD)))
{ {
eputs ("type a: "); eputs ("type a: ");
eputs (itoa (TYPE (a))); eputs (itoa (a->type));
eputs ("\n"); eputs ("\n");
eputs ("type b: "); eputs ("type b: ");
eputs (itoa (TYPE (b))); eputs (itoa (b->type));
eputs ("\n"); eputs ("\n");
eputs ("a= "); eputs ("a= ");
write_error_ (a); write_error_ (a);
@ -76,60 +76,60 @@ string_equal_p (SCM a, SCM b) /*:((name . "string=?")) */
eputs ("b= "); eputs ("b= ");
write_error_ (b); write_error_ (b);
eputs ("\n"); eputs ("\n");
assert_msg ((TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD), "(TYPE (a) == TSTRING && TYPE (b) == TSTRING) || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)"); assert_msg ((a->type == TSTRING && b->type == TSTRING) || (a->type == TKEYWORD || b->type == TKEYWORD), "(a->type == TSTRING && b->type == TSTRING) || (a->type == TKEYWORD || b->type == TKEYWORD)");
} }
if (a == b) if (a == b)
return cell_t; return cell_t;
if (STRING (a) == STRING (b)) if (a->string == b->string)
return cell_t; return cell_t;
if (LENGTH (a) == 0 && LENGTH (b) == 0) if (a->length == 0 && b->length == 0)
return cell_t; return cell_t;
if (LENGTH (a) == LENGTH (b)) if (a->length == b->length)
if (memcmp (cell_bytes (STRING (a)), cell_bytes (STRING (b)), LENGTH (a)) == 0) if (memcmp (cell_bytes (a->string), cell_bytes (b->string), a->length) == 0)
return cell_t; return cell_t;
return cell_f; return cell_f;
} }
SCM struct scm *
symbol_to_string (SCM symbol) symbol_to_string (struct scm *symbol)
{ {
return make_cell (TSTRING, CAR (symbol), CDR (symbol)); return make_cell (TSTRING, symbol->car, symbol->cdr);
} }
SCM struct scm *
symbol_to_keyword (SCM symbol) symbol_to_keyword (struct scm *symbol)
{ {
return make_cell (TKEYWORD, CAR (symbol), CDR (symbol)); return make_cell (TKEYWORD, symbol->car, symbol->cdr);
} }
SCM struct scm *
keyword_to_string (SCM keyword) keyword_to_string (struct scm *keyword)
{ {
return make_cell (TSTRING, CAR (keyword), CDR (keyword)); return make_cell (TSTRING, keyword->car, keyword->cdr);
} }
SCM struct scm *
string_to_symbol (SCM string) string_to_symbol (struct scm *string)
{ {
SCM x = hash_ref (g_symbols, string, cell_f); struct scm *x = hash_ref (g_symbols, string, cell_f);
if (x == cell_f) if (x == cell_f)
x = make_symbol (string); x = make_symbol (string);
return x; return x;
} }
SCM struct scm *
make_symbol (SCM string) make_symbol (struct scm *string)
{ {
SCM x = make_cell (TSYMBOL, LENGTH (string), STRING (string)); struct scm *x = make_cell (TSYMBOL, string->length, string->string);
hash_set_x (g_symbols, string, x); hash_set_x (g_symbols, string, x);
return x; return x;
} }
SCM struct scm *
bytes_to_list (char const *s, size_t i) bytes_to_list (char const *s, size_t i)
{ {
SCM p = cell_nil; struct scm *p = cell_nil;
while (i != 0) while (i != 0)
{ {
i = i - 1; i = i - 1;
@ -139,42 +139,42 @@ bytes_to_list (char const *s, size_t i)
return p; return p;
} }
SCM struct scm *
cstring_to_list (char const *s) cstring_to_list (char const *s)
{ {
return bytes_to_list (s, strlen (s)); return bytes_to_list (s, strlen (s));
} }
SCM struct scm *
cstring_to_symbol (char const *s) cstring_to_symbol (char const *s)
{ {
SCM string = make_string0 (s); struct scm *string = make_string0 (s);
return string_to_symbol (string); return string_to_symbol (string);
} }
SCM struct scm *
string_to_list (SCM string) string_to_list (struct scm *string)
{ {
return bytes_to_list (cell_bytes (STRING (string)), LENGTH (string)); return bytes_to_list (cell_bytes (string->string), string->length);
} }
SCM struct scm *
list_to_string (SCM list) list_to_string (struct scm *list)
{ {
size_t size; size_t size;
char const *s = list_to_cstring (list, &size); char const *s = list_to_cstring (list, &size);
return make_string (s, size); return make_string (s, size);
} }
SCM struct scm *
read_string (SCM port) /*:((arity . n)) */ read_string (struct scm *port) /*:((arity . n)) */
{ {
int fd = __stdin; int fd = __stdin;
if (TYPE (port) == TPAIR) if (port->type == TPAIR)
{ {
SCM p = car (port); struct scm *p = car (port);
if (TYPE (p) == TNUMBER) if (p->type == TNUMBER)
__stdin = VALUE (p); __stdin = p->value;
} }
int c = readchar (); int c = readchar ();
size_t i = 0; size_t i = 0;
@ -191,42 +191,42 @@ read_string (SCM port) /*:((arity . n)) */
return make_string (g_buf, i); return make_string (g_buf, i);
} }
SCM struct scm *
string_append (SCM x) /*:((arity . n)) */ string_append (struct scm *x) /*:((arity . n)) */
{ {
char *p = g_buf; char *p = g_buf;
g_buf[0] = 0; g_buf[0] = 0;
size_t size = 0; size_t size = 0;
while (x != cell_nil) while (x != cell_nil)
{ {
SCM string = CAR (x); struct scm *string = x->car;
assert_msg (TYPE (string) == TSTRING, "TYPE (string) == TSTRING"); assert_msg (string->type == TSTRING, "string->type == TSTRING");
memcpy (p, cell_bytes (STRING (string)), LENGTH (string) + 1); memcpy (p, cell_bytes (string->string), string->length + 1);
p = p + LENGTH (string); p = p + string->length;
size = size + LENGTH (string); size = size + string->length;
if (size > MAX_STRING) if (size > MAX_STRING)
assert_max_string (size, "string_append", g_buf); assert_max_string (size, "string_append", g_buf);
x = CDR (x); x = x->cdr;
} }
return make_string (g_buf, size); return make_string (g_buf, size);
} }
SCM struct scm *
string_length (SCM string) string_length (struct scm *string)
{ {
assert_msg (TYPE (string) == TSTRING, "TYPE (string) == TSTRING"); assert_msg (string->type == TSTRING, "string->type == TSTRING");
return make_number (LENGTH (string)); return make_number (string->length);
} }
SCM struct scm *
string_ref (SCM str, SCM k) string_ref (struct scm *str, struct scm *k)
{ {
assert_msg (TYPE (str) == TSTRING, "TYPE (str) == TSTRING"); assert_msg (str->type == TSTRING, "str->type == TSTRING");
assert_msg (TYPE (k) == TNUMBER, "TYPE (k) == TNUMBER"); assert_msg (k->type == TNUMBER, "k->type == TNUMBER");
size_t size = LENGTH (str); size_t size = str->length;
size_t i = VALUE (k); size_t i = k->value;
if (i > size) if (i > size)
error (cell_symbol_system_error, cons (make_string0 ("value out of range"), k)); error (cell_symbol_system_error, cons (make_string0 ("value out of range"), k));
char const *p = cell_bytes (STRING (str)); char const *p = cell_bytes (str->string);
return make_char (p[i]); return make_char (p[i]);
} }

72
src/struct.c
View file

@ -21,70 +21,70 @@
#include "mes/lib.h" #include "mes/lib.h"
#include "mes/mes.h" #include "mes/mes.h"
SCM struct scm *
make_struct (SCM type, SCM fields, SCM printer) make_struct (struct scm *type, struct scm *fields, struct scm *printer)
{ {
long size = 2 + length__ (fields); long size = 2 + length__ (fields);
SCM x = alloc (1); struct scm *x = alloc (1);
SCM v = alloc (size); struct scm *v = alloc (size);
TYPE (x) = TSTRUCT; x->type = TSTRUCT;
LENGTH (x) = size; x->length = size;
STRUCT (x) = v; x->structure = v;
copy_cell (v, vector_entry (type)); copy_cell (v, vector_entry (type));
copy_cell (cell_ref (v, 1), vector_entry (printer)); copy_cell (cell_ref (v, 1), vector_entry (printer));
long i; long i;
for (i = 2; i < size; i = i + 1) for (i = 2; i < size; i = i + 1)
{ {
SCM e = cell_unspecified; struct scm *e = cell_unspecified;
if (fields != cell_nil) if (fields != cell_nil)
{ {
e = CAR (fields); e = fields->car;
fields = CDR (fields); fields = fields->cdr;
} }
copy_cell (cell_ref (v, i), vector_entry (e)); copy_cell (cell_ref (v, i), vector_entry (e));
} }
return x; return x;
} }
SCM struct scm *
struct_length (SCM x) struct_length (struct scm *x)
{ {
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT"); assert_msg (x->type == TSTRUCT, "x->type == TSTRUCT");
return make_number (LENGTH (x)); return make_number (x->length);
} }
SCM struct scm *
struct_ref_ (SCM x, long i) struct_ref_ (struct scm *x, long i)
{ {
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT"); assert_msg (x->type == TSTRUCT, "x->type == TSTRUCT");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < x->length, "i < x->length");
SCM e = cell_ref (STRUCT (x), i); struct scm *e = cell_ref (x->structure, i);
if (TYPE (e) == TREF) if (e->type == TREF)
e = REF (e); e = e->ref;
if (TYPE (e) == TCHAR) if (e->type == TCHAR)
e = make_char (VALUE (e)); e = make_char (e->value);
if (TYPE (e) == TNUMBER) if (e->type == TNUMBER)
e = make_number (VALUE (e)); e = make_number (e->value);
return e; return e;
} }
SCM struct scm *
struct_set_x_ (SCM x, long i, SCM e) struct_set_x_ (struct scm *x, long i, struct scm *e)
{ {
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT"); assert_msg (x->type == TSTRUCT, "x->type == TSTRUCT");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < x->length, "i < x->length");
copy_cell (cell_ref (STRUCT (x), i), vector_entry (e)); copy_cell (cell_ref (x->structure, i), vector_entry (e));
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
struct_ref (SCM x, SCM i) struct_ref (struct scm *x, struct scm *i)
{ {
return struct_ref_ (x, VALUE (i)); return struct_ref_ (x, i->value);
} }
SCM struct scm *
struct_set_x (SCM x, SCM i, SCM e) struct_set_x (struct scm *x, struct scm *i, struct scm *e)
{ {
return struct_set_x_ (x, VALUE (i), e); return struct_set_x_ (x, i->value, e);
} }

18
src/symbol.c
View file

@ -33,20 +33,20 @@
// CONSTANT M2_CELL_SIZE 12 // CONSTANT M2_CELL_SIZE 12
#endif #endif
SCM g_symbol; struct scm *g_symbol;
SCM struct scm *
init_symbol (SCM x, long type, char const *name) init_symbol (struct scm *x, long type, char const *name)
{ {
TYPE (x) = type; x->type = type;
if (g_symbols == 0) if (g_symbols == 0)
g_free = g_free + M2_CELL_SIZE; g_free = g_free + M2_CELL_SIZE;
else else
{ {
int length = strlen (name); int length = strlen (name);
SCM string = make_string (name, length); struct scm *string = make_string (name, length);
CAR (x) = length; x->car = length;
CDR (x) = STRING (string); x->cdr = string->string;
hash_set_x (g_symbols, string, x); hash_set_x (g_symbols, string, x);
} }
g_symbol = g_symbol + M2_CELL_SIZE; g_symbol = g_symbol + M2_CELL_SIZE;
@ -177,7 +177,7 @@ init_symbols_ () /*:((internal)) */
cell_symbol_test = init_symbol (g_symbol, TSYMBOL, "%%test"); cell_symbol_test = init_symbol (g_symbol, TSYMBOL, "%%test");
} }
SCM struct scm *
init_symbols () /*:((internal)) */ init_symbols () /*:((internal)) */
{ {
g_free = g_cells + M2_CELL_SIZE; g_free = g_cells + M2_CELL_SIZE;
@ -190,7 +190,7 @@ init_symbols () /*:((internal)) */
init_symbols_ (); init_symbols_ ();
g_ports = cell_nil; g_ports = cell_nil;
SCM a = cell_nil; struct scm *a = cell_nil;
a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a); a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a); a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
a = acons (cell_symbol_current_module, cell_symbol_current_module, a); a = acons (cell_symbol_current_module, cell_symbol_current_module, a);

40
src/test/gc.c
View file

@ -46,17 +46,17 @@ test_setup ()
M0 = cell_zero; M0 = cell_zero;
memset (g_arena + sizeof (struct scm), 0, ARENA_SIZE * sizeof (struct scm)); memset (g_arena + sizeof (struct scm), 0, ARENA_SIZE * sizeof (struct scm));
TYPE (cell_zero) = TCHAR; cell_zero->type = TCHAR;
VALUE (cell_zero) = 'c'; cell_zero->value = 'c';
g_free = cell_f; g_free = cell_f;
} }
void void
print_arena (long length) print_arena (long length)
{ {
SCM v = cell_arena; struct scm *v = cell_arena;
TYPE (v) = TVECTOR; v->type = TVECTOR;
LENGTH (v) = length; v->length = length;
eputs ("arena["); eputs (ntoab (g_cells, 16, 0)); eputs ("]: "); write_ (v); eputs ("\n"); eputs ("arena["); eputs (ntoab (g_cells, 16, 0)); eputs ("]: "); write_ (v); eputs ("\n");
} }
@ -72,19 +72,19 @@ test_gc (char const *name)
eputs ("\n"); eputs ("\n");
gc_ (); gc_ ();
VALUE (cell_zero) = 'd'; cell_zero->value = 'd';
print_arena (gc_free () - 1); print_arena (gc_free () - 1);
gc_stats_ ("2"); gc_stats_ ("2");
eputs ("\n"); eputs ("\n");
gc_ (); gc_ ();
VALUE (cell_zero) = 'e'; cell_zero->value = 'e';
print_arena (gc_free () - 1); print_arena (gc_free () - 1);
gc_stats_ ("3"); gc_stats_ ("3");
eputs ("\n"); eputs ("\n");
gc_ (); gc_ ();
VALUE (cell_zero) = 'f'; cell_zero->value = 'f';
print_arena (gc_free () - 1); print_arena (gc_free () - 1);
gc_stats_ ("3"); gc_stats_ ("3");
eputs ("\n"); eputs ("\n");
@ -113,8 +113,8 @@ void
test_cons () test_cons ()
{ {
test_setup (); test_setup ();
SCM a = make_number (42); struct scm *a = make_number (42);
SCM d = make_number (101); struct scm *d = make_number (101);
cons (a, d); cons (a, d);
g_free = g_symbol_max + M2_CELL_SIZE; g_free = g_symbol_max + M2_CELL_SIZE;
@ -125,9 +125,9 @@ void
test_list () test_list ()
{ {
test_setup (); test_setup ();
SCM a = make_number (42); struct scm *a = make_number (42);
SCM d = make_number (101); struct scm *d = make_number (101);
SCM lst = cons (d, cell_nil); struct scm *lst = cons (d, cell_nil);
cons (a, lst); cons (a, lst);
g_free = g_symbol_max + M2_CELL_SIZE; g_free = g_symbol_max + M2_CELL_SIZE;
@ -138,7 +138,7 @@ void
test_string () test_string ()
{ {
test_setup (); test_setup ();
SCM s = make_string0 ("hello"); struct scm *s = make_string0 ("hello");
g_free = g_symbol_max + M2_CELL_SIZE; g_free = g_symbol_max + M2_CELL_SIZE;
test_gc ("string"); test_gc ("string");
@ -148,9 +148,9 @@ void
test_vector () test_vector ()
{ {
test_setup (); test_setup ();
SCM v = make_vector_ (4, cell_zero); struct scm *v = make_vector_ (4, cell_zero);
SCM one = make_number (1); struct scm *one = make_number (1);
SCM two = make_number (2); struct scm *two = make_number (2);
vector_set_x_ (v, 1, one); vector_set_x_ (v, 1, one);
vector_set_x_ (v, 2, two); vector_set_x_ (v, 2, two);
@ -162,9 +162,9 @@ void
test_struct () test_struct ()
{ {
test_setup (); test_setup ();
SCM type = make_char ('t'); struct scm *type = make_char ('t');
SCM printer = make_char ('p'); struct scm *printer = make_char ('p');
SCM fields = cons (make_char ('f'), cell_nil); struct scm *fields = cons (make_char ('f'), cell_nil);
make_struct (type, fields, printer); make_struct (type, fields, printer);
g_free = g_symbol_max + M2_CELL_SIZE; g_free = g_symbol_max + M2_CELL_SIZE;

108
src/vector.c
View file

@ -29,14 +29,14 @@
// CONSTANT M2_CELL_SIZE 12 // CONSTANT M2_CELL_SIZE 12
#endif #endif
SCM struct scm *
make_vector_ (long k, SCM e) make_vector_ (long k, struct scm *e)
{ {
SCM x = alloc (1); struct scm *x = alloc (1);
SCM v = alloc (k); struct scm *v = alloc (k);
TYPE (x) = TVECTOR; x->type = TVECTOR;
LENGTH (x) = k; x->length = k;
VECTOR (x) = v; x->vector = v;
long i; long i;
for (i = 0; i < k; i = i + 1) for (i = 0; i < k; i = i + 1)
copy_cell (cell_ref (v, i), vector_entry (e)); copy_cell (cell_ref (v, i), vector_entry (e));
@ -44,75 +44,75 @@ make_vector_ (long k, SCM e)
return x; return x;
} }
SCM struct scm *
make_vector (SCM x) /*:((arity . n)) */ make_vector (struct scm *x) /*:((arity . n)) */
{ {
SCM k = CAR (x); struct scm *k = x->car;
assert_number ("make-vector", k); assert_number ("make-vector", k);
long n = VALUE (k); long n = k->value;
SCM e = cell_unspecified; struct scm *e = cell_unspecified;
if (CDR (x) != cell_nil) if (x->cdr != cell_nil)
e = CADR (x); e = x->cdr->car;
return make_vector_ (n, e); return make_vector_ (n, e);
} }
SCM struct scm *
vector_length (SCM x) vector_length (struct scm *x)
{ {
assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR"); assert_msg (x->type == TVECTOR, "x->type == TVECTOR");
return make_number (LENGTH (x)); return make_number (x->length);
} }
SCM struct scm *
vector_ref_ (SCM x, long i) vector_ref_ (struct scm *x, long i)
{ {
assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR"); assert_msg (x->type == TVECTOR, "x->type == TVECTOR");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < x->length, "i < x->length");
SCM e = cell_ref (VECTOR (x), i); struct scm *e = cell_ref (x->vector, i);
if (TYPE (e) == TREF) if (e->type == TREF)
e = REF (e); e = e->ref;
if (TYPE (e) == TCHAR) if (e->type == TCHAR)
e = make_char (VALUE (e)); e = make_char (e->value);
if (TYPE (e) == TNUMBER) if (e->type == TNUMBER)
e = make_number (VALUE (e)); e = make_number (e->value);
return e; return e;
} }
SCM struct scm *
vector_ref (SCM x, SCM i) vector_ref (struct scm *x, struct scm *i)
{ {
return vector_ref_ (x, VALUE (i)); return vector_ref_ (x, i->value);
} }
SCM struct scm *
vector_entry (SCM x) vector_entry (struct scm *x)
{ {
if (TYPE (x) != TCHAR && TYPE (x) != TNUMBER) if (x->type != TCHAR && x->type != TNUMBER)
x = make_ref (x); x = make_ref (x);
return x; return x;
} }
SCM struct scm *
vector_set_x_ (SCM x, long i, SCM e) vector_set_x_ (struct scm *x, long i, struct scm *e)
{ {
assert_msg (TYPE (x) == TVECTOR, "TYPE (x) == TVECTOR"); assert_msg (x->type == TVECTOR, "x->type == TVECTOR");
assert_msg (i < LENGTH (x), "i < LENGTH (x)"); assert_msg (i < x->length, "i < x->length");
copy_cell (cell_ref (VECTOR (x), i), vector_entry (e)); copy_cell (cell_ref (x->vector, i), vector_entry (e));
return cell_unspecified; return cell_unspecified;
} }
SCM struct scm *
vector_set_x (SCM x, SCM i, SCM e) vector_set_x (struct scm *x, struct scm *i, struct scm *e)
{ {
return vector_set_x_ (x, VALUE (i), e); return vector_set_x_ (x, i->value, e);
} }
SCM struct scm *
list_to_vector (SCM x) list_to_vector (struct scm *x)
{ {
SCM v = make_vector_ (length__ (x), cell_unspecified); struct scm *v = make_vector_ (length__ (x), cell_unspecified);
SCM p = VECTOR (v); struct scm *p = v->vector;
while (x != cell_nil) while (x != cell_nil)
{ {
copy_cell (p, vector_entry (car (x))); copy_cell (p, vector_entry (car (x)));
@ -122,16 +122,16 @@ list_to_vector (SCM x)
return v; return v;
} }
SCM struct scm *
vector_to_list (SCM v) vector_to_list (struct scm *v)
{ {
SCM x = cell_nil; struct scm *x = cell_nil;
long i; long i;
for (i = LENGTH (v); i; i = i - 1) for (i = v->length; i; i = i - 1)
{ {
SCM e = cell_ref (VECTOR (v), i - 1); struct scm *e = cell_ref (v->vector, i - 1);
if (TYPE (e) == TREF) if (e->type == TREF)
e = REF (e); e = e->ref;
x = cons (e, x); x = cons (e, x);
} }
return x; return x;