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/builtins.h \
include/m2/lib.h \
include/mes/m2.h \
src/builtins.c \
src/cc.c \
src/core.c \

280
include/mes/builtins.h
View file

@ -22,159 +22,159 @@
#define __MES_BUILTINS_H
/* src/builtins.c */
SCM make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function);
SCM builtin_name (SCM builtin);
SCM builtin_arity (SCM builtin);
SCM builtin_p (SCM x);
SCM builtin_printer (SCM builtin);
struct scm *make_builtin (struct scm *builtin_type, struct scm *name, struct scm *arity, struct scm *function);
struct scm *builtin_name (struct scm *builtin);
struct scm *builtin_arity (struct scm *builtin);
struct scm *builtin_p (struct scm *x);
struct scm *builtin_printer (struct scm *builtin);
/* src/core.c */
SCM car (SCM x);
SCM cdr (SCM x);
SCM list (SCM x);
SCM null_p (SCM x);
SCM eq_p (SCM x, SCM y);
SCM values (SCM x);
SCM acons (SCM key, SCM value, SCM alist);
SCM length (SCM x);
SCM error (SCM key, SCM x);
SCM append2 (SCM x, SCM y);
SCM append_reverse (SCM x, SCM y);
SCM reverse_x_ (SCM x, SCM t);
SCM assq (SCM x, SCM a);
SCM assoc (SCM x, SCM a);
struct scm *car (struct scm *x);
struct scm *cdr (struct scm *x);
struct scm *list (struct scm *x);
struct scm *null_p (struct scm *x);
struct scm *eq_p (struct scm *x, struct scm *y);
struct scm *values (struct scm *x);
struct scm *acons (struct scm *key, struct scm *value, struct scm *alist);
struct scm *length (struct scm *x);
struct scm *error (struct scm *key, struct scm *x);
struct scm *append2 (struct scm *x, struct scm *y);
struct scm *append_reverse (struct scm *x, struct scm *y);
struct scm *reverse_x_ (struct scm *x, struct scm *t);
struct scm *assq (struct scm *x, struct scm *a);
struct scm *assoc (struct scm *x, struct scm *a);
/* src/display.c */
SCM display_ (SCM x);
SCM display_error_ (SCM x);
SCM display_port_ (SCM x, SCM p);
SCM write_ (SCM x);
SCM write_error_ (SCM x);
SCM write_port_ (SCM x, SCM p);
struct scm *display_ (struct scm *x);
struct scm *display_error_ (struct scm *x);
struct scm *display_port_ (struct scm *x, struct scm *p);
struct scm *write_ (struct scm *x);
struct scm *write_error_ (struct scm *x);
struct scm *write_port_ (struct scm *x, struct scm *p);
/* src/eval-apply.c */
SCM pairlis (SCM x, SCM y, SCM a);
SCM set_car_x (SCM x, SCM e);
SCM set_cdr_x (SCM x, SCM e);
SCM set_env_x (SCM x, SCM e, SCM a);
SCM add_formals (SCM formals, SCM x);
SCM eval_apply ();
struct scm *pairlis (struct scm *x, struct scm *y, struct scm *a);
struct scm *set_car_x (struct scm *x, struct scm *e);
struct scm *set_cdr_x (struct scm *x, struct scm *e);
struct scm *set_env_x (struct scm *x, struct scm *e, struct scm *a);
struct scm *add_formals (struct scm *formals, struct scm *x);
struct scm *eval_apply ();
/* src/gc.c */
SCM cons (SCM x, SCM y);
SCM gc_check ();
SCM gc ();
struct scm *cons (struct scm *x, struct scm *y);
struct scm *gc_check ();
struct scm *gc ();
/* src/hash.c */
SCM hashq (SCM x, SCM size);
SCM hash (SCM x, SCM size);
SCM hashq_get_handle (SCM table, SCM key, SCM dflt);
SCM hashq_ref (SCM table, SCM key, SCM dflt);
SCM hash_ref (SCM table, SCM key, SCM dflt);
SCM hashq_set_x (SCM table, SCM key, SCM value);
SCM hash_set_x (SCM table, SCM key, SCM value);
SCM hash_table_printer (SCM table);
SCM make_hash_table (SCM x);
struct scm *hashq (struct scm *x, struct scm *size);
struct scm *hash (struct scm *x, struct scm *size);
struct scm *hashq_get_handle (struct scm *table, struct scm *key, struct scm *dflt);
struct scm *hashq_ref (struct scm *table, struct scm *key, struct scm *dflt);
struct scm *hash_ref (struct scm *table, struct scm *key, struct scm *dflt);
struct scm *hashq_set_x (struct scm *table, struct scm *key, struct scm *value);
struct scm *hash_set_x (struct scm *table, struct scm *key, struct scm *value);
struct scm *hash_table_printer (struct scm *table);
struct scm *make_hash_table (struct scm *x);
/* src/lib.c */
SCM type_ (SCM x);
SCM car_ (SCM x);
SCM cdr_ (SCM x);
SCM xassq (SCM x, SCM a);
SCM memq (SCM x, SCM a);
SCM equal2_p (SCM a, SCM b);
SCM last_pair (SCM x);
SCM pair_p (SCM x);
SCM char_to_integer (SCM x);
SCM integer_to_char (SCM x);
struct scm *type_ (struct scm *x);
struct scm *car_ (struct scm *x);
struct scm *cdr_ (struct scm *x);
struct scm *xassq (struct scm *x, struct scm *a);
struct scm *memq (struct scm *x, struct scm *a);
struct scm *equal2_p (struct scm *a, struct scm *b);
struct scm *last_pair (struct scm *x);
struct scm *pair_p (struct scm *x);
struct scm *char_to_integer (struct scm *x);
struct scm *integer_to_char (struct scm *x);
/* src/math.c */
SCM greater_p (SCM x);
SCM less_p (SCM x);
SCM is_p (SCM x);
SCM minus (SCM x);
SCM plus (SCM x);
SCM divide (SCM x);
SCM modulo (SCM a, SCM b);
SCM multiply (SCM x);
SCM logand (SCM x);
SCM logior (SCM x);
SCM lognot (SCM x);
SCM logxor (SCM x);
SCM ash (SCM n, SCM count);
struct scm *greater_p (struct scm *x);
struct scm *less_p (struct scm *x);
struct scm *is_p (struct scm *x);
struct scm *minus (struct scm *x);
struct scm *plus (struct scm *x);
struct scm *divide (struct scm *x);
struct scm *modulo (struct scm *a, struct scm *b);
struct scm *multiply (struct scm *x);
struct scm *logand (struct scm *x);
struct scm *logior (struct scm *x);
struct scm *lognot (struct scm *x);
struct scm *logxor (struct scm *x);
struct scm *ash (struct scm *n, struct scm *count);
/* src/module.c */
SCM make_module_type ();
SCM module_printer (SCM module);
SCM module_variable (SCM module, SCM name);
SCM module_ref (SCM module, SCM name);
SCM module_define_x (SCM module, SCM name, SCM value);
struct scm *make_module_type ();
struct scm *module_printer (struct scm *module);
struct scm *module_variable (struct scm *module, struct scm *name);
struct scm *module_ref (struct scm *module, struct scm *name);
struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value);
/* src/posix.c */
SCM exit_ (SCM x);
SCM peek_byte ();
SCM read_byte ();
SCM unread_byte (SCM i);
SCM peek_char ();
SCM read_char (SCM port);
SCM unread_char (SCM i);
SCM write_char (SCM i);
SCM write_byte (SCM x);
SCM getenv_ (SCM s);
SCM setenv_ (SCM s, SCM v);
SCM access_p (SCM file_name, SCM mode);
SCM current_input_port ();
SCM open_input_file (SCM file_name);
SCM open_input_string (SCM string);
SCM set_current_input_port (SCM port);
SCM current_output_port ();
SCM current_error_port ();
SCM open_output_file (SCM x);
SCM set_current_output_port (SCM port);
SCM set_current_error_port (SCM port);
SCM chmod_ (SCM file_name, SCM mode);
SCM isatty_p (SCM port);
SCM primitive_fork ();
SCM execl_ (SCM file_name, SCM args);
SCM waitpid_ (SCM pid, SCM options);
SCM current_time ();
SCM gettimeofday_ ();
SCM get_internal_run_time ();
SCM getcwd_ ();
SCM dup_ (SCM port);
SCM dup2_ (SCM old, SCM new);
SCM delete_file (SCM file_name);
struct scm *exit_ (struct scm *x);
struct scm *peek_byte ();
struct scm *read_byte ();
struct scm *unread_byte (struct scm *i);
struct scm *peek_char ();
struct scm *read_char (struct scm *port);
struct scm *unread_char (struct scm *i);
struct scm *write_char (struct scm *i);
struct scm *write_byte (struct scm *x);
struct scm *getenv_ (struct scm *s);
struct scm *setenv_ (struct scm *s, struct scm *v);
struct scm *access_p (struct scm *file_name, struct scm *mode);
struct scm *current_input_port ();
struct scm *open_input_file (struct scm *file_name);
struct scm *open_input_string (struct scm *string);
struct scm *set_current_input_port (struct scm *port);
struct scm *current_output_port ();
struct scm *current_error_port ();
struct scm *open_output_file (struct scm *x);
struct scm *set_current_output_port (struct scm *port);
struct scm *set_current_error_port (struct scm *port);
struct scm *chmod_ (struct scm *file_name, struct scm *mode);
struct scm *isatty_p (struct scm *port);
struct scm *primitive_fork ();
struct scm *execl_ (struct scm *file_name, struct scm *args);
struct scm *waitpid_ (struct scm *pid, struct scm *options);
struct scm *current_time ();
struct scm *gettimeofday_ ();
struct scm *get_internal_run_time ();
struct scm *getcwd_ ();
struct scm *dup_ (struct scm *port);
struct scm *dup2_ (struct scm *old, struct scm *new);
struct scm *delete_file (struct scm *file_name);
/* src/reader.c */
SCM read_input_file_env_ (SCM e, SCM a);
SCM read_input_file_env (SCM a);
SCM read_env (SCM a);
SCM reader_read_sexp (SCM c, SCM s, SCM a);
SCM reader_read_character ();
SCM reader_read_binary ();
SCM reader_read_octal ();
SCM reader_read_hex ();
SCM reader_read_string ();
struct scm *read_input_file_env_ (struct scm *e, struct scm *a);
struct scm *read_input_file_env (struct scm *a);
struct scm *read_env (struct scm *a);
struct scm *reader_read_sexp (struct scm *c, struct scm *s, struct scm *a);
struct scm *reader_read_character ();
struct scm *reader_read_binary ();
struct scm *reader_read_octal ();
struct scm *reader_read_hex ();
struct scm *reader_read_string ();
/* src/stack.c */
SCM frame_printer (SCM frame);
SCM make_stack (SCM stack);
SCM stack_length (SCM stack);
SCM stack_ref (SCM stack, SCM index);
struct scm *frame_printer (struct scm *frame);
struct scm *make_stack (struct scm *stack);
struct scm *stack_length (struct scm *stack);
struct scm *stack_ref (struct scm *stack, struct scm *index);
/* src/string.c */
SCM string_equal_p (SCM a, SCM b);
SCM symbol_to_string (SCM symbol);
SCM symbol_to_keyword (SCM symbol);
SCM keyword_to_string (SCM keyword);
SCM string_to_symbol (SCM string);
SCM make_symbol (SCM string);
SCM string_to_list (SCM string);
SCM list_to_string (SCM list);
SCM read_string (SCM port);
SCM string_append (SCM x);
SCM string_length (SCM string);
SCM string_ref (SCM str, SCM k);
struct scm *string_equal_p (struct scm *a, struct scm *b);
struct scm *symbol_to_string (struct scm *symbol);
struct scm *symbol_to_keyword (struct scm *symbol);
struct scm *keyword_to_string (struct scm *keyword);
struct scm *string_to_symbol (struct scm *string);
struct scm *make_symbol (struct scm *string);
struct scm *string_to_list (struct scm *string);
struct scm *list_to_string (struct scm *list);
struct scm *read_string (struct scm *port);
struct scm *string_append (struct scm *x);
struct scm *string_length (struct scm *string);
struct scm *string_ref (struct scm *str, struct scm *k);
/* src/struct.c */
SCM make_struct (SCM type, SCM fields, SCM printer);
SCM struct_length (SCM x);
SCM struct_ref (SCM x, SCM i);
SCM struct_set_x (SCM x, SCM i, SCM e);
struct scm *make_struct (struct scm *type, struct scm *fields, struct scm *printer);
struct scm *struct_length (struct scm *x);
struct scm *struct_ref (struct scm *x, struct scm *i);
struct scm *struct_set_x (struct scm *x, struct scm *i, struct scm *e);
/* src/vector.c */
SCM make_vector (SCM x);
SCM vector_length (SCM x);
SCM vector_ref (SCM x, SCM i);
SCM vector_entry (SCM x);
SCM vector_set_x (SCM x, SCM i, SCM e);
SCM list_to_vector (SCM x);
SCM vector_to_list (SCM v);
struct scm *make_vector (struct scm *x);
struct scm *vector_length (struct scm *x);
struct scm *vector_ref (struct scm *x, struct scm *i);
struct scm *vector_entry (struct scm *x);
struct scm *vector_set_x (struct scm *x, struct scm *i, struct scm *e);
struct scm *list_to_vector (struct scm *x);
struct scm *vector_to_list (struct scm *v);
#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;
union
{
SCM car;
struct scm *car;
char *bytes;
long length;
SCM ref;
SCM variable;
SCM macro;
struct scm *ref;
struct scm *variable;
struct scm *macro;
long port;
};
union
{
SCM cdr;
SCM closure;
SCM continuation;
struct scm *cdr;
struct scm *closure;
struct scm *continuation;
char *name;
SCM string;
SCM structure;
struct scm *string;
struct scm *structure;
long value;
SCM vector;
struct scm *vector;
};
};
@ -54,24 +54,24 @@ struct scm
char *g_datadir;
int g_debug;
char *g_buf;
SCM g_continuations;
SCM g_symbols;
SCM g_symbol_max;
struct scm *g_continuations;
struct scm *g_symbols;
struct scm *g_symbol_max;
int g_mini;
/* a/env */
SCM R0;
struct scm *R0;
/* param 1 */
SCM R1;
struct scm *R1;
/* save 2 */
SCM R2;
struct scm *R2;
/* continuation */
SCM R3;
struct scm *R3;
/* current-module */
SCM M0;
struct scm *M0;
/* macro */
SCM g_macros;
SCM g_ports;
struct scm *g_macros;
struct scm *g_ports;
/* gc */
long ARENA_SIZE;
@ -81,13 +81,13 @@ long JAM_SIZE;
long GC_SAFETY;
long MAX_STRING;
char *g_arena;
SCM cell_arena;
SCM cell_zero;
struct scm *cell_arena;
struct scm *cell_zero;
SCM g_free;
SCM g_symbol;
struct scm *g_free;
struct scm *g_symbol;
SCM *g_stack_array;
struct scm **g_stack_array;
struct scm *g_cells;
struct scm *g_news;
long g_stack;
@ -102,54 +102,54 @@ struct timespec *g_start_time;
struct timeval *__gettimeofday_time;
struct timespec *__get_internal_run_time_ts;
SCM alloc (long n);
SCM apply (SCM f, SCM x, SCM a);
SCM apply_builtin (SCM fn, SCM x);
SCM apply_builtin0 (SCM fn);
SCM apply_builtin1 (SCM fn, SCM x);
SCM apply_builtin2 (SCM fn, SCM x, SCM y);
SCM apply_builtin3 (SCM fn, SCM x, SCM y, SCM z);
SCM builtin_name (SCM builtin);
SCM cstring_to_list (char const *s);
SCM cstring_to_symbol (char const *s);
SCM cell_ref (SCM cell, long index);
SCM fdisplay_ (SCM, int, int);
SCM init_symbols ();
SCM init_time (SCM a);
SCM make_builtin_type ();
SCM make_bytes (char const *s, size_t length);
SCM make_cell (long type, SCM car, SCM cdr);
SCM make_char (int n);
SCM make_continuation (long n);
SCM make_hash_table_ (long size);
SCM make_hashq_type ();
SCM make_initial_module (SCM a);
SCM make_macro (SCM name, SCM x);
SCM make_number (long n);
SCM make_ref (SCM x);
SCM make_string (char const *s, size_t length);
SCM make_string0 (char const *s);
SCM make_string_port (SCM x);
SCM make_vector_ (long k, SCM e);
SCM mes_builtins (SCM a);
SCM push_cc (SCM p1, SCM p2, SCM a, SCM c);
SCM struct_ref_ (SCM x, long i);
SCM struct_set_x_ (SCM x, long i, SCM e);
SCM vector_ref_ (SCM x, long i);
SCM vector_set_x_ (SCM x, long i, SCM e);
FUNCTION builtin_function (SCM builtin);
char *cell_bytes (SCM x);
char *news_bytes (SCM x);
struct scm *alloc (long n);
struct scm *apply (struct scm *f, struct scm *x, struct scm *a);
struct scm *apply_builtin (struct scm *fn, struct scm *x);
struct scm *apply_builtin0 (struct scm *fn);
struct scm *apply_builtin1 (struct scm *fn, struct scm *x);
struct scm *apply_builtin2 (struct scm *fn, struct scm *x, struct scm *y);
struct scm *apply_builtin3 (struct scm *fn, struct scm *x, struct scm *y, struct scm *z);
struct scm *builtin_name (struct scm *builtin);
struct scm *cstring_to_list (char const *s);
struct scm *cstring_to_symbol (char const *s);
struct scm *cell_ref (struct scm *cell, long index);
struct scm *fdisplay_ (struct scm *, int, int);
struct scm *init_symbols ();
struct scm *init_time (struct scm *a);
struct scm *make_builtin_type ();
struct scm *make_bytes (char const *s, size_t length);
struct scm *make_cell (long type, struct scm *car, struct scm *cdr);
struct scm *make_char (int n);
struct scm *make_continuation (long n);
struct scm *make_hash_table_ (long size);
struct scm *make_hashq_type ();
struct scm *make_initial_module (struct scm *a);
struct scm *make_macro (struct scm *name, struct scm *x);
struct scm *make_number (long n);
struct scm *make_ref (struct scm *x);
struct scm *make_string (char const *s, size_t length);
struct scm *make_string0 (char const *s);
struct scm *make_string_port (struct scm *x);
struct scm *make_vector_ (long k, struct scm *e);
struct scm *mes_builtins (struct scm *a);
struct scm *push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c);
struct scm *struct_ref_ (struct scm *x, long i);
struct scm *struct_set_x_ (struct scm *x, long i, struct scm *e);
struct scm *vector_ref_ (struct scm *x, long i);
struct scm *vector_set_x_ (struct scm *x, long i, struct scm *e);
FUNCTION builtin_function (struct scm *builtin);
char *cell_bytes (struct scm *x);
char *news_bytes (struct scm *x);
int peekchar ();
int readchar ();
int unreadchar ();
long gc_free ();
long length__ (SCM x);
long length__ (struct scm *x);
size_t bytes_cells (size_t length);
void assert_max_string (size_t i, char const *msg, char *string);
void assert_msg (int check, char *msg);
void assert_number (char const *name, SCM x);
void copy_cell (SCM to, SCM from);
void assert_number (char const *name, struct scm *x);
void copy_cell (struct scm *to, struct scm *from);
void gc_ ();
void gc_dump_arena (struct scm *cells, long size);
void gc_init ();
@ -161,7 +161,6 @@ void init_symbols_ ();
#include "mes/builtins.h"
#include "mes/constants.h"
#include "mes/macros.h"
#include "mes/symbols.h"
#endif /* __MES_MES_H */

226
include/mes/symbols.h
View file

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

7
kaem.run
View file

@ -19,12 +19,6 @@
# Usage:
# 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}
stage0_cpu=${stage0_cpu:-x86}
@ -55,7 +49,6 @@ M2-Planet \
-f lib/mes/eputc.c \
\
-f include/mes/mes.h \
-f include/mes/m2.h \
-f include/mes/builtins.h \
-f include/mes/constants.h \
-f include/mes/symbols.h \

1
simple.make
View file

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

52
src/builtins.c
View file

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

24
src/cc.c
View file

@ -21,30 +21,30 @@
#include "mes/lib.h"
#include "mes/mes.h"
SCM
apply_builtin0 (SCM fn)
struct scm *
apply_builtin0 (struct scm *fn)
{
SCM (*fp) (void) = (function0_t) builtin_function (fn);
struct scm *(*fp) (void) = (function0_t) builtin_function (fn);
return fp ();
}
SCM
apply_builtin1 (SCM fn, SCM x)
struct scm *
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);
}
SCM
apply_builtin2 (SCM fn, SCM x, SCM y)
struct scm *
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);
}
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 (*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);
}

164
src/core.c
View file

@ -29,127 +29,127 @@
#include <stdlib.h>
SCM
assoc_string (SCM x, SCM a) /*:((internal)) */
struct scm *
assoc_string (struct scm *x, struct scm *a) /*:((internal)) */
{
SCM b;
struct scm *b;
while (a != cell_nil)
{
b = CAR (a);
if (TYPE (CAR (b)) == TSTRING)
if (string_equal_p (x, CAR (b)) == cell_t)
b = a->car;
if (b->car->type == TSTRING)
if (string_equal_p (x, b->car) == cell_t)
return b;
a = CDR (a);
a = a->cdr;
}
if (a != cell_nil)
return CAR (a);
return a->car;
return cell_f;
}
SCM
car (SCM x)
struct scm *
car (struct scm *x)
{
#if !__MESC_MES__
if (TYPE (x) != TPAIR)
if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
#endif
return CAR (x);
return x->car;
}
SCM
cdr (SCM x)
struct scm *
cdr (struct scm *x)
{
#if !__MESC_MES__
if (TYPE (x) != TPAIR)
if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
#endif
return CDR (x);
return x->cdr;
}
SCM
list (SCM x) /*:((arity . n)) */
struct scm *
list (struct scm *x) /*:((arity . n)) */
{
return x;
}
SCM
null_p (SCM x)
struct scm *
null_p (struct scm *x)
{
if (x == cell_nil)
return cell_t;
return cell_f;
}
SCM
eq_p (SCM x, SCM y)
struct scm *
eq_p (struct scm *x, struct scm *y)
{
if (x == y)
return cell_t;
int t = TYPE (x);
int t = x->type;
if (t == TKEYWORD)
{
if (TYPE (y) == TKEYWORD)
if (y->type == TKEYWORD)
return string_equal_p (x, y);
return cell_f;
}
if (t == TCHAR)
{
if (TYPE (y) != TCHAR)
if (y->type != TCHAR)
return cell_f;
if (VALUE (x) == VALUE (y))
if (x->value == y->value)
return cell_t;
return cell_f;
}
if (t == TNUMBER)
{
if (TYPE (y) != TNUMBER)
if (y->type != TNUMBER)
return cell_f;
if (VALUE (x) == VALUE (y))
if (x->value == y->value)
return cell_t;
return cell_f;
}
return cell_f;
}
SCM
values (SCM x) /*:((arity . n)) */
struct scm *
values (struct scm *x) /*:((arity . n)) */
{
SCM v = cons (0, x);
TYPE (v) = TVALUES;
struct scm *v = cons (0, x);
v->type = TVALUES;
return v;
}
SCM
acons (SCM key, SCM value, SCM alist)
struct scm *
acons (struct scm *key, struct scm *value, struct scm *alist)
{
return cons (cons (key, value), alist);
}
long
length__ (SCM x) /*:((internal)) */
length__ (struct scm *x) /*:((internal)) */
{
long n = 0;
while (x != cell_nil)
{
n = n + 1;
if (TYPE (x) != TPAIR)
if (x->type != TPAIR)
return -1;
x = CDR (x);
x = x->cdr;
}
return n;
}
SCM
length (SCM x)
struct scm *
length (struct scm *x)
{
return make_number (length__ (x));
}
SCM
error (SCM key, SCM x)
struct scm *
error (struct scm *key, struct scm *x)
{
#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)
return apply (throw, cons (key, cons (x, cell_nil)), R0);
#endif
@ -161,107 +161,107 @@ error (SCM key, SCM x)
exit (1);
}
SCM
append2 (SCM x, SCM y)
struct scm *
append2 (struct scm *x, struct scm *y)
{
if (x == cell_nil)
return y;
if (TYPE (x) != TPAIR)
if (x->type != TPAIR)
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)
{
r = cons (CAR (x), r);
x = CDR (x);
r = cons (x->car, r);
x = x->cdr;
}
return reverse_x_ (r, y);
}
SCM
append_reverse (SCM x, SCM y)
struct scm *
append_reverse (struct scm *x, struct scm *y)
{
if (x == cell_nil)
return y;
if (TYPE (x) != TPAIR)
if (x->type != TPAIR)
error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse")));
while (x != cell_nil)
{
y = cons (CAR (x), y);
x = CDR (x);
y = cons (x->car, y);
x = x->cdr;
}
return y;
}
SCM
reverse_x_ (SCM x, SCM t)
struct scm *
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!")));
SCM r = t;
struct scm *r = t;
while (x != cell_nil)
{
t = CDR (x);
CDR (x) = r;
t = x->cdr;
x->cdr = r;
r = x;
x = t;
}
return r;
}
SCM
assq (SCM x, SCM a)
struct scm *
assq (struct scm *x, struct scm *a)
{
if (TYPE (a) != TPAIR)
if (a->type != TPAIR)
return cell_f;
int t = TYPE (x);
int t = x->type;
if (t == TSYMBOL || t == TSPECIAL)
while (a != cell_nil)
{
if (x == CAAR (a))
return CAR (a);
a = CDR (a);
if (x == a->car->car)
return a->car;
a = a->cdr;
}
else if (t == TCHAR || t == TNUMBER)
{
long v = VALUE (x);
long v = x->value;
while (a != cell_nil)
{
if (v == VALUE (CAAR (a)))
return CAR (a);
a = CDR (a);
if (v == a->car->car->value)
return a->car;
a = a->cdr;
}
}
else if (t == TKEYWORD)
{
while (a != cell_nil)
{
if (string_equal_p (x, CAAR (a)) == cell_t)
return CAR (a);
a = CDR (a);
if (string_equal_p (x, a->car->car) == cell_t)
return a->car;
a = a->cdr;
}
}
else
/* pointer equality, e.g. on strings. */
while (a != cell_nil)
{
if (x == CAAR (a))
return CAR (a);
a = CDR (a);
if (x == a->car->car)
return a->car;
a = a->cdr;
}
return cell_f;
}
SCM
assoc (SCM x, SCM a)
struct scm *
assoc (struct scm *x, struct scm *a)
{
if (TYPE (x) == TSTRING)
if (x->type == TSTRING)
return assoc_string (x, a);
while (a != cell_nil)
{
if (equal2_p (x, CAAR (a)) == cell_t)
return CAR (a);
a = CDR (a);
if (equal2_p (x, a->car->car) == cell_t)
return a->car;
a = a->cdr;
}
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);
}
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
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)
{
fdputs (sep, fd);
if (g_depth == 0)
return cell_unspecified;
g_depth = g_depth - 1;
int t = TYPE (x);
int t = x->type;
if (t == TCHAR)
{
if (write_p == 0)
fdputc (VALUE (x), fd);
fdputc (x->value, fd);
else
{
fdputs ("#", fd);
fdwrite_char (VALUE (x), fd);
fdwrite_char (x->value, fd);
}
}
else if (t == TCLOSURE)
{
fdputs ("#<closure ", fd);
SCM circ = CADR (x);
SCM name = CADR (circ);
SCM args = CAR (CDDR (x));
display_helper (CAR (name), 0, "", fd, 0);
struct scm *circ = x->cdr->car;
struct scm *name = circ->cdr->car;
struct scm *args = x->cdr->cdr->car;
display_helper (name->car, 0, "", fd, 0);
fdputc (' ', fd);
display_helper (args, 0, "", fd, 0);
fdputs (">", fd);
@ -133,48 +133,48 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
else if (t == TMACRO)
{
fdputs ("#<macro ", fd);
display_helper (CDR (x), cont, "", fd, 0);
display_helper (x->cdr, cont, "", fd, 0);
fdputs (">", fd);
}
else if (t == TVARIABLE)
{
fdputs ("#<variable ", fd);
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
display_helper (x->variable->car, cont, "", fd, 0);
fdputs (">", fd);
}
else if (t == TNUMBER)
{
fdputs (itoa (VALUE (x)), fd);
fdputs (itoa (x->value), fd);
}
else if (t == TPAIR)
{
if (cont == 0)
fdputs ("(", fd);
if (CAR (x) == cell_circular && CADR (x) != cell_closure)
if (x->car == cell_circular && x->cdr->car != cell_closure)
{
fdputs ("(*circ* . ", fd);
int i = 0;
x = CDR (x);
x = x->cdr;
while (x != cell_nil && i < 10)
{
i = i + 1;
fdisplay_ (CAAR (x), fd, write_p);
fdisplay_ (x->car->car, fd, write_p);
fdputs (" ", fd);
x = CDR (x);
x = x->cdr;
}
fdputs (" ...)", fd);
}
else
{
if (x != 0 && x != cell_nil)
fdisplay_ (CAR (x), fd, write_p);
if (CDR (x) != 0 && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ", fd, write_p);
else if (CDR (x) != 0 && CDR (x) != cell_nil)
fdisplay_ (x->car, fd, write_p);
if (x->cdr != 0 && x->cdr->type == TPAIR)
display_helper (x->cdr, 1, " ", fd, write_p);
else if (x->cdr != 0 && x->cdr != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
if (x->cdr->type != TPAIR)
fdputs (" . ", fd);
fdisplay_ (CDR (x), fd, write_p);
fdisplay_ (x->cdr, fd, write_p);
}
}
if (cont == 0)
@ -183,52 +183,52 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
else if (t == TPORT)
{
fdputs ("#<port ", fd);
fdputs (itoa (PORT (x)), fd);
fdputs (itoa (x->port), fd);
fdputs (" ", fd);
x = STRING (x);
x = x->string;
fdputc ('"', fd);
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd);
fdwrite_string (cell_bytes (x->string), x->length, fd);
fdputc ('"', fd);
fdputs (">", fd);
}
else if (t == TKEYWORD)
{
fdputs ("#:", fd);
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd);
fdwrite_string (cell_bytes (x->string), x->length, fd);
}
else if (t == TSTRING)
{
if (write_p == 1)
{
fdputc ('"', fd);
fdwrite_string (cell_bytes (STRING (x)), LENGTH (x), fd);
fdwrite_string (cell_bytes (x->string), x->length, fd);
fdputc ('"', fd);
}
else
fdputs (cell_bytes (STRING (x)), fd);
fdputs (cell_bytes (x->string), fd);
}
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)
fdisplay_ (REF (x), fd, write_p);
fdisplay_ (x->ref, fd, write_p);
else if (t == TSTRUCT)
{
SCM printer = struct_ref_ (x, STRUCT_PRINTER);
if (TYPE (printer) == TREF)
printer = REF (printer);
if (TYPE (printer) == TCLOSURE || builtin_p (printer) == cell_t)
struct scm *printer = struct_ref_ (x, STRUCT_PRINTER);
if (printer->type == TREF)
printer = printer->ref;
if (printer->type == TCLOSURE || builtin_p (printer) == cell_t)
apply (printer, cons (x, cell_nil), R0);
else
{
fdputs ("#<", fd);
fdisplay_ (STRUCT (x), fd, write_p);
SCM t = CAR (x);
long size = LENGTH (x);
fdisplay_ (x->structure, fd, write_p);
struct scm *t = x->car;
long size = x->length;
long i;
for (i = 2; i < size; i = i + 1)
{
fdputc (' ', fd);
fdisplay_ (cell_ref (STRUCT (x), i), fd, write_p);
fdisplay_ (cell_ref (x->structure, i), fd, write_p);
}
fdputc ('>', fd);
}
@ -236,13 +236,13 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
else if (t == TVECTOR)
{
fdputs ("#(", fd);
SCM t = CAR (x);
struct scm *t = x->car;
long i;
for (i = 0; i < LENGTH (x); i = i + 1)
for (i = 0; i < x->length; i = i + 1)
{
if (i != 0)
fdputc (' ', fd);
fdisplay_ (cell_ref (VECTOR (x), i), fd, write_p);
fdisplay_ (cell_ref (x->vector, i), fd, write_p);
}
fdputc (')', fd);
}
@ -257,50 +257,50 @@ display_helper (SCM x, int cont, char *sep, int fd, int write_p)
return cell_unspecified;
}
SCM
display_ (SCM x)
struct scm *
display_ (struct scm *x)
{
g_depth = 5;
return display_helper (x, 0, "", __stdout, 0);
}
SCM
display_error_ (SCM x)
struct scm *
display_error_ (struct scm *x)
{
g_depth = 5;
return display_helper (x, 0, "", __stderr, 0);
}
SCM
display_port_ (SCM x, SCM p)
struct scm *
display_port_ (struct scm *x, struct scm *p)
{
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER");
return fdisplay_ (x, VALUE (p), 0);
assert_msg (p->type == TNUMBER, "p->type == TNUMBER");
return fdisplay_ (x, p->value, 0);
}
SCM
write_ (SCM x)
struct scm *
write_ (struct scm *x)
{
g_depth = 5;
return display_helper (x, 0, "", __stdout, 1);
}
SCM
write_error_ (SCM x)
struct scm *
write_error_ (struct scm *x)
{
g_depth = 5;
return display_helper (x, 0, "", __stderr, 1);
}
SCM
write_port_ (SCM x, SCM p)
struct scm *
write_port_ (struct scm *x, struct scm *p)
{
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER");
return fdisplay_ (x, VALUE (p), 1);
assert_msg (p->type == TNUMBER, "p->type == TNUMBER");
return fdisplay_ (x, p->value, 1);
}
SCM
fdisplay_ (SCM x, int fd, int write_p) /*:((internal)) */
struct scm *
fdisplay_ (struct scm *x, int fd, int write_p) /*:((internal)) */
{
g_depth = 5;
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
char *
cell_bytes (SCM x)
cell_bytes (struct scm *x)
{
char *p = x;
return p + (2 * sizeof (long));
}
char *
news_bytes (SCM x)
news_bytes (struct scm *x)
{
char *p = x;
return p + (2 * sizeof (long));
@ -98,12 +98,12 @@ gc_init ()
g_cells = g_cells + M2_CELL_SIZE; /* Hmm? */
TYPE (cell_arena) = TVECTOR;
LENGTH (cell_arena) = 1000;
VECTOR (cell_arena) = cell_zero;
cell_arena->type = TVECTOR;
cell_arena->length = 1000;
cell_arena->vector = cell_zero;
TYPE (cell_zero) = TCHAR;
VALUE (cell_zero) = 'c';
cell_zero->type = TCHAR;
cell_zero->value = 'c';
g_free = g_cells + M2_CELL_SIZE;
@ -128,10 +128,10 @@ gc_stats_ (char const* where)
eputs ("]\n");
}
SCM
struct scm *
alloc (long n)
{
SCM x = g_free;
struct scm *x = g_free;
g_free = g_free + (n * M2_CELL_SIZE);
long i = g_free - g_cells;
i = i / M2_CELL_SIZE;
@ -141,51 +141,51 @@ alloc (long n)
return x;
}
SCM
make_cell (long type, SCM car, SCM cdr)
struct scm *
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;
long i = g_free - g_cells;
i = i / M2_CELL_SIZE;
if (i > ARENA_SIZE)
assert_msg (0, "alloc: out of memory");
TYPE (x) = type;
CAR (x) = car;
CDR (x) = cdr;
x->type = type;
x->car = car;
x->cdr = cdr;
return x;
}
void
copy_cell (SCM to, SCM from)
copy_cell (struct scm *to, struct scm *from)
{
TYPE (to) = TYPE (from);
CAR (to) = CAR (from);
CDR (to) = CDR (from);
to->type = from->type;
to->car = from->car;
to->cdr = from->cdr;
}
void
copy_news (SCM to, SCM from)
copy_news (struct scm *to, struct scm *from)
{
NTYPE (to) = TYPE (from);
NCAR (to) = CAR (from);
NCDR (to) = CDR (from);
to->type = from->type;
to->car = from->car;
to->cdr = from->cdr;
}
void
copy_stack (long index, SCM from)
copy_stack (long index, struct scm *from)
{
g_stack_array[index] = from;
}
SCM
cell_ref (SCM cell, long index)
struct scm *
cell_ref (struct scm *cell, long index)
{
return cell + (index * M2_CELL_SIZE);
}
SCM
cons (SCM x, SCM y)
struct scm *
cons (struct scm *x, struct scm *y)
{
return make_cell (TPAIR, x, y);
}
@ -193,16 +193,16 @@ cons (SCM x, SCM y)
size_t
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)
{
size_t size = bytes_cells (length);
SCM x = alloc (size);
TYPE (x) = TBYTES;
LENGTH (x) = length;
struct scm *x = alloc (size);
x->type = TBYTES;
x->length = length;
char *p = cell_bytes (x);
if (length == 0)
p[0] = 0;
@ -212,55 +212,55 @@ make_bytes (char const *s, size_t length)
return x;
}
SCM
struct scm *
make_char (int n)
{
return make_cell (TCHAR, 0, n);
}
SCM
struct scm *
make_continuation (long n)
{
return make_cell (TCONTINUATION, n, g_stack);
}
SCM
make_macro (SCM name, SCM x) /*:((internal)) */
struct scm *
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)
{
return make_cell (TNUMBER, 0, n);
}
SCM
make_ref (SCM x) /*:((internal)) */
struct scm *
make_ref (struct scm *x) /*:((internal)) */
{
return make_cell (TREF, x, 0);
}
SCM
struct scm *
make_string (char const *s, size_t length)
{
if (length > MAX_STRING)
assert_max_string (length, "make_string", s);
SCM x = make_cell (TSTRING, length, 0);
SCM v = make_bytes (s, length + 1);
CDR (x) = v;
struct scm *x = make_cell (TSTRING, length, 0);
struct scm *v = make_bytes (s, length + 1);
x->cdr = v;
return x;
}
SCM
struct scm *
make_string0 (char const *s)
{
return make_string (s, strlen (s));
}
SCM
make_string_port (SCM x) /*:((internal)) */
struct scm *
make_string_port (struct scm *x) /*:((internal)) */
{
return make_cell (TPORT, -length__ (g_ports) - 2, x);
}
@ -269,17 +269,17 @@ void
gc_init_news ()
{
g_news = g_free;
SCM ncell_arena = g_news;
SCM ncell_zero = ncell_arena + M2_CELL_SIZE;
struct scm *ncell_arena = g_news;
struct scm *ncell_zero = ncell_arena + M2_CELL_SIZE;
g_news = g_news + M2_CELL_SIZE;
NTYPE (ncell_arena) = TVECTOR;
NLENGTH (ncell_arena) = LENGTH (cell_arena);
NVECTOR (ncell_arena) = g_news;
ncell_arena->type = TVECTOR;
ncell_arena->length = cell_arena->length;
ncell_arena->vector = g_news;
NTYPE (ncell_zero) = TCHAR;
NVALUE (ncell_zero) = 'n';
ncell_zero->type = TCHAR;
ncell_zero->value = 'n';
}
void
@ -311,7 +311,7 @@ gc_up_arena ()
exit (1);
}
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;
}
@ -423,29 +423,29 @@ gc_flip ()
gc_stats_ (";;; => jam");
}
SCM
gc_copy (SCM old) /*:((internal)) */
struct scm *
gc_copy (struct scm *old) /*:((internal)) */
{
if (TYPE (old) == TBROKEN_HEART)
return CAR (old);
SCM new = g_free;
if (old->type == TBROKEN_HEART)
return old->car;
struct scm *new = g_free;
g_free = g_free + M2_CELL_SIZE;
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;
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;
}
}
else if (NTYPE (new) == TBYTES)
else if (new->type == TBYTES)
{
char const *src = cell_bytes (old);
char *dest = news_bytes (new);
size_t length = NLENGTH (new);
size_t length = new->length;
memcpy (dest, src, length);
g_free = g_free + ((bytes_cells (length) - 1) * M2_CELL_SIZE);
@ -455,43 +455,43 @@ gc_copy (SCM old) /*:((internal)) */
eputs (src);
eputs ("\n");
eputs (" length: ");
eputs (ltoa (LENGTH (old)));
eputs (ltoa (old->length));
eputs ("\n");
eputs (" nlength: ");
eputs (ltoa (NLENGTH (new)));
eputs (ltoa (new->length));
eputs ("\n");
eputs (" ==> ");
eputs (dest);
eputs ("\n");
}
}
TYPE (old) = TBROKEN_HEART;
CAR (old) = new;
old->type = TBROKEN_HEART;
old->car = new;
return new;
}
SCM
gc_relocate_car (SCM new, SCM car) /*:((internal)) */
struct scm *
gc_relocate_car (struct scm *new, struct scm *car) /*:((internal)) */
{
NCAR (new) = car;
new->car = car;
return cell_unspecified;
}
SCM
gc_relocate_cdr (SCM new, SCM cdr) /*:((internal)) */
struct scm *
gc_relocate_cdr (struct scm *new, struct scm *cdr) /*:((internal)) */
{
NCDR (new) = cdr;
new->cdr = cdr;
return cell_unspecified;
}
void
gc_loop (SCM scan)
gc_loop (struct scm *scan)
{
SCM car;
SCM cdr;
struct scm *car;
struct scm *cdr;
while (scan < g_free)
{
long t = NTYPE (scan);
long t = scan->type;
if (t == TBROKEN_HEART)
assert_msg (0, "gc_loop: broken heart");
/* *INDENT-OFF* */
@ -501,7 +501,7 @@ gc_loop (SCM scan)
|| t == TVARIABLE)
/* *INDENT-ON* */
{
car = gc_copy (NCAR (scan));
car = gc_copy (scan->car);
gc_relocate_car (scan, car);
}
/* *INDENT-OFF* */
@ -520,18 +520,18 @@ gc_loop (SCM scan)
)
/* *INDENT-ON* */
{
cdr = gc_copy (NCDR (scan));
cdr = gc_copy (scan->cdr);
gc_relocate_cdr (scan, cdr);
}
if (t == TBYTES)
scan = scan + (bytes_cells (NLENGTH (scan)) * M2_CELL_SIZE);
scan = scan + (bytes_cells (scan->length) * M2_CELL_SIZE);
else
scan = scan + M2_CELL_SIZE;
}
gc_flip ();
}
SCM
struct scm *
gc_check ()
{
long used = ((g_free - g_cells) / M2_CELL_SIZE) + GC_SAFETY;
@ -574,8 +574,8 @@ gc_ ()
gc_up_arena ();
}
SCM new_cell_nil = g_free;
SCM s;
struct scm *new_cell_nil = g_free;
struct scm *s;
for (s = cell_nil; s < g_symbol_max; s = s + M2_CELL_SIZE)
gc_copy (s);
@ -591,7 +591,7 @@ gc_ ()
gc_loop (new_cell_nil);
}
SCM
struct scm *
gc ()
{
if (getenv ("MES_DUMP") != 0)
@ -665,7 +665,7 @@ dumps (char const *s)
}
void
gc_dump_register (char const* n, SCM r)
gc_dump_register (char const* n, struct scm *r)
{
dumps (n); dumps (": ");
long i = r;
@ -706,7 +706,7 @@ gc_dump_stack ()
void
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;
if (g_dump_filedes == 0)
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');
gc_dump_state ();
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;
size = size - 1;

136
src/hash.c
View file

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

112
src/lib.c
View file

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

134
src/math.c
View file

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

18
src/mes.c
View file

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

64
src/module.c
View file

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

250
src/posix.c
View file

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

68
src/reader.c
View file

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

46
src/stack.c
View file

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

126
src/string.c
View file

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

72
src/struct.c
View file

@ -21,70 +21,70 @@
#include "mes/lib.h"
#include "mes/mes.h"
SCM
make_struct (SCM type, SCM fields, SCM printer)
struct scm *
make_struct (struct scm *type, struct scm *fields, struct scm *printer)
{
long size = 2 + length__ (fields);
SCM x = alloc (1);
SCM v = alloc (size);
TYPE (x) = TSTRUCT;
LENGTH (x) = size;
STRUCT (x) = v;
struct scm *x = alloc (1);
struct scm *v = alloc (size);
x->type = TSTRUCT;
x->length = size;
x->structure = v;
copy_cell (v, vector_entry (type));
copy_cell (cell_ref (v, 1), vector_entry (printer));
long i;
for (i = 2; i < size; i = i + 1)
{
SCM e = cell_unspecified;
struct scm *e = cell_unspecified;
if (fields != cell_nil)
{
e = CAR (fields);
fields = CDR (fields);
e = fields->car;
fields = fields->cdr;
}
copy_cell (cell_ref (v, i), vector_entry (e));
}
return x;
}
SCM
struct_length (SCM x)
struct scm *
struct_length (struct scm *x)
{
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT");
return make_number (LENGTH (x));
assert_msg (x->type == TSTRUCT, "x->type == TSTRUCT");
return make_number (x->length);
}
SCM
struct_ref_ (SCM x, long i)
struct scm *
struct_ref_ (struct scm *x, long i)
{
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT");
assert_msg (i < LENGTH (x), "i < LENGTH (x)");
SCM e = cell_ref (STRUCT (x), i);
if (TYPE (e) == TREF)
e = REF (e);
if (TYPE (e) == TCHAR)
e = make_char (VALUE (e));
if (TYPE (e) == TNUMBER)
e = make_number (VALUE (e));
assert_msg (x->type == TSTRUCT, "x->type == TSTRUCT");
assert_msg (i < x->length, "i < x->length");
struct scm *e = cell_ref (x->structure, i);
if (e->type == TREF)
e = e->ref;
if (e->type == TCHAR)
e = make_char (e->value);
if (e->type == TNUMBER)
e = make_number (e->value);
return e;
}
SCM
struct_set_x_ (SCM x, long i, SCM e)
struct scm *
struct_set_x_ (struct scm *x, long i, struct scm *e)
{
assert_msg (TYPE (x) == TSTRUCT, "TYPE (x) == TSTRUCT");
assert_msg (i < LENGTH (x), "i < LENGTH (x)");
copy_cell (cell_ref (STRUCT (x), i), vector_entry (e));
assert_msg (x->type == TSTRUCT, "x->type == TSTRUCT");
assert_msg (i < x->length, "i < x->length");
copy_cell (cell_ref (x->structure, i), vector_entry (e));
return cell_unspecified;
}
SCM
struct_ref (SCM x, SCM i)
struct scm *
struct_ref (struct scm *x, struct scm *i)
{
return struct_ref_ (x, VALUE (i));
return struct_ref_ (x, i->value);
}
SCM
struct_set_x (SCM x, SCM i, SCM e)
struct scm *
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
#endif
SCM g_symbol;
struct scm *g_symbol;
SCM
init_symbol (SCM x, long type, char const *name)
struct scm *
init_symbol (struct scm *x, long type, char const *name)
{
TYPE (x) = type;
x->type = type;
if (g_symbols == 0)
g_free = g_free + M2_CELL_SIZE;
else
{
int length = strlen (name);
SCM string = make_string (name, length);
CAR (x) = length;
CDR (x) = STRING (string);
struct scm *string = make_string (name, length);
x->car = length;
x->cdr = string->string;
hash_set_x (g_symbols, string, x);
}
g_symbol = g_symbol + M2_CELL_SIZE;
@ -177,7 +177,7 @@ init_symbols_ () /*:((internal)) */
cell_symbol_test = init_symbol (g_symbol, TSYMBOL, "%%test");
}
SCM
struct scm *
init_symbols () /*:((internal)) */
{
g_free = g_cells + M2_CELL_SIZE;
@ -190,7 +190,7 @@ init_symbols () /*:((internal)) */
init_symbols_ ();
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_boot_module, cell_symbol_boot_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;
memset (g_arena + sizeof (struct scm), 0, ARENA_SIZE * sizeof (struct scm));
TYPE (cell_zero) = TCHAR;
VALUE (cell_zero) = 'c';
cell_zero->type = TCHAR;
cell_zero->value = 'c';
g_free = cell_f;
}
void
print_arena (long length)
{
SCM v = cell_arena;
TYPE (v) = TVECTOR;
LENGTH (v) = length;
struct scm *v = cell_arena;
v->type = TVECTOR;
v->length = length;
eputs ("arena["); eputs (ntoab (g_cells, 16, 0)); eputs ("]: "); write_ (v); eputs ("\n");
}
@ -72,19 +72,19 @@ test_gc (char const *name)
eputs ("\n");
gc_ ();
VALUE (cell_zero) = 'd';
cell_zero->value = 'd';
print_arena (gc_free () - 1);
gc_stats_ ("2");
eputs ("\n");
gc_ ();
VALUE (cell_zero) = 'e';
cell_zero->value = 'e';
print_arena (gc_free () - 1);
gc_stats_ ("3");
eputs ("\n");
gc_ ();
VALUE (cell_zero) = 'f';
cell_zero->value = 'f';
print_arena (gc_free () - 1);
gc_stats_ ("3");
eputs ("\n");
@ -113,8 +113,8 @@ void
test_cons ()
{
test_setup ();
SCM a = make_number (42);
SCM d = make_number (101);
struct scm *a = make_number (42);
struct scm *d = make_number (101);
cons (a, d);
g_free = g_symbol_max + M2_CELL_SIZE;
@ -125,9 +125,9 @@ void
test_list ()
{
test_setup ();
SCM a = make_number (42);
SCM d = make_number (101);
SCM lst = cons (d, cell_nil);
struct scm *a = make_number (42);
struct scm *d = make_number (101);
struct scm *lst = cons (d, cell_nil);
cons (a, lst);
g_free = g_symbol_max + M2_CELL_SIZE;
@ -138,7 +138,7 @@ void
test_string ()
{
test_setup ();
SCM s = make_string0 ("hello");
struct scm *s = make_string0 ("hello");
g_free = g_symbol_max + M2_CELL_SIZE;
test_gc ("string");
@ -148,9 +148,9 @@ void
test_vector ()
{
test_setup ();
SCM v = make_vector_ (4, cell_zero);
SCM one = make_number (1);
SCM two = make_number (2);
struct scm *v = make_vector_ (4, cell_zero);
struct scm *one = make_number (1);
struct scm *two = make_number (2);
vector_set_x_ (v, 1, one);
vector_set_x_ (v, 2, two);
@ -162,9 +162,9 @@ void
test_struct ()
{
test_setup ();
SCM type = make_char ('t');
SCM printer = make_char ('p');
SCM fields = cons (make_char ('f'), cell_nil);
struct scm *type = make_char ('t');
struct scm *printer = make_char ('p');
struct scm *fields = cons (make_char ('f'), cell_nil);
make_struct (type, fields, printer);
g_free = g_symbol_max + M2_CELL_SIZE;

108
src/vector.c
View file

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