├── .gitignore ├── todos.txt ├── tests └── README.md ├── stdlib └── README.md ├── docs ├── schem-r5rscn.pdf └── syntaxs.scm ├── src ├── gc.h ├── fun.h ├── lib │ ├── builtinlib.c │ ├── libpcc32.h │ ├── builtinlib.h │ └── libpcc32.c ├── char.h ├── read.h ├── system.h ├── str.h ├── vector.h ├── print.h ├── number.h ├── bool.h ├── error.h ├── env.h ├── hashtable.h ├── symbol.h ├── main.c ├── fun.c ├── list.h ├── cc │ ├── unicc.c │ ├── cc.h │ └── pcc32.c ├── port.h ├── hashtable.c ├── bool.c ├── env.c ├── symbol.c ├── eval.h ├── scm.h ├── vector.c ├── error.c ├── port.c ├── system.c ├── char.c ├── print.c ├── list.c ├── str.c ├── number.c ├── read.c └── eval.c ├── makefile ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | /cmake-build-debug/ -------------------------------------------------------------------------------- /todos.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hulang1024/Scheme/HEAD/todos.txt -------------------------------------------------------------------------------- /tests/README.md: -------------------------------------------------------------------------------- 1 | [tests/](https://github.com/hlpp/Lisp-code/tree/master/scheme/) 2 | -------------------------------------------------------------------------------- /stdlib/README.md: -------------------------------------------------------------------------------- 1 | [stdlib/](https://github.com/hlpp/Lisp-code/tree/master/scheme/stdlib/) -------------------------------------------------------------------------------- /docs/schem-r5rscn.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hulang1024/Scheme/HEAD/docs/schem-r5rscn.pdf -------------------------------------------------------------------------------- /src/gc.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_GC_H 2 | #define SCHEME_GC_H 3 | 4 | #include "scm.h" 5 | 6 | #endif //SCHEME_GC_H 7 | -------------------------------------------------------------------------------- /src/fun.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_FUN_H 2 | #define SCHEME_FUN_H 3 | 4 | #include "scm.h" 5 | 6 | void scm_init_fun(scm_env *); 7 | 8 | #endif //SCHEME_FUN_H 9 | -------------------------------------------------------------------------------- /src/lib/builtinlib.c: -------------------------------------------------------------------------------- 1 | #include "builtinlib.h" 2 | #include "libpcc32.h" 3 | 4 | void scm_init_builtin_lib(scm_env *env) 5 | { 6 | scm_init_libpcc32(env); 7 | } 8 | -------------------------------------------------------------------------------- /src/lib/libpcc32.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_LIBPCC32_H 2 | #define SCHEME_LIBPCC32_H 3 | 4 | #include "../scm.h" 5 | 6 | void scm_init_libpcc32(scm_env *env); 7 | 8 | #endif // SCHEME_LIBPCC32_H 9 | -------------------------------------------------------------------------------- /src/lib/builtinlib.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_BUILTINLIB_H 2 | #define SCHEME_BUILTINLIB_H 3 | 4 | #include "../scm.h" 5 | 6 | void scm_init_builtin_lib(scm_env *env); 7 | 8 | #endif //SCHEME_BUILTINLIB_H 9 | -------------------------------------------------------------------------------- /src/char.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_CHAR_H 2 | #define SCHEME_CHAR_H 3 | 4 | #include "scm.h" 5 | 6 | void scm_init_char(scm_env *); 7 | scm_object* scm_make_char(char); 8 | 9 | #endif //SCHEME_CHAR_H 10 | -------------------------------------------------------------------------------- /src/read.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_READ_H 2 | #define SCHEME_READ_H 3 | 4 | #include "port.h" 5 | 6 | void scm_init_read(scm_env *); 7 | scm_object* scm_read(scm_object *port); 8 | 9 | #endif //SCHEME_READ_H 10 | -------------------------------------------------------------------------------- /src/system.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_SYSTEM_H 2 | #define SCHEME_SYSTEM_H 3 | 4 | #include "scm.h" 5 | 6 | extern char *scm_g_repl_prompt; 7 | 8 | void scm_init_system(scm_env *); 9 | int scm_load_file(const char *); 10 | 11 | #endif //SCHEME_SYSTEM_H 12 | -------------------------------------------------------------------------------- /src/str.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_STR_H 2 | #define SCHEME_STR_H 3 | 4 | #include "scm.h" 5 | 6 | extern scm_object scm_empty_string[]; 7 | 8 | void scm_init_string(scm_env *); 9 | scm_object* scm_make_string(const char *, int); 10 | 11 | #endif //SCHEME_STR_H 12 | -------------------------------------------------------------------------------- /src/vector.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_VECTOR_H 2 | #define SCHEME_VECTOR_H 3 | 4 | #include "scm.h" 5 | 6 | void scm_init_vector(scm_env *env); 7 | scm_object* scm_make_vector(scm_object **, int); 8 | scm_object* scm_list_to_vector(scm_object *, int); 9 | 10 | #endif //SCHEME_VECTOR_H 11 | -------------------------------------------------------------------------------- /src/print.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_PRINT_H 2 | #define SCHEME_PRINT_H 3 | 4 | #include 5 | #include "scm.h" 6 | #include "port.h" 7 | 8 | void scm_init_print(scm_env *); 9 | void scm_write(scm_object *port, scm_object *); 10 | void scm_display(scm_object *port, scm_object *); 11 | 12 | #endif //SCHEME_PRINT_H 13 | -------------------------------------------------------------------------------- /src/number.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_NUMBER_H 2 | #define SCHEME_NUMBER_H 3 | 4 | #include "scm.h" 5 | 6 | #define is_exact_nonnegative_integer(o) (SCM_INTEGERP(o) && SCM_INT_VAL(o) >= 0) 7 | 8 | void scm_init_number(scm_env *); 9 | scm_object* scm_make_integer(long); 10 | scm_object* scm_make_float(double); 11 | 12 | #endif //SCHEME_NUMBER_H 13 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | CC = gcc 2 | CCFLAGS = -std=c99 3 | 4 | SRCS = $(wildcard src/*.c src/*/*.c) 5 | OBJS = $(SRCS:.c=.o) 6 | 7 | OUTPUT = scheme 8 | 9 | 10 | all: $(OUTPUT) 11 | 12 | 13 | $(OUTPUT): $(OBJS) 14 | $(CC) -o $@ $(notdir $^) 15 | 16 | %.o: %.c 17 | $(CC) -c $< $(CCFLAGS) -o $(notdir $@) 18 | 19 | 20 | .PHONY: clean 21 | clean: 22 | -rm -rf *.o 23 | -------------------------------------------------------------------------------- /src/bool.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_BOOL_H 2 | #define SCHEME_BOOL_H 3 | 4 | #include "scm.h" 5 | 6 | #define SCM_BOOL(b) ((b) ? scm_true : scm_false) 7 | 8 | extern scm_object scm_true[]; 9 | extern scm_object scm_false[]; 10 | extern scm_object scm_void[]; 11 | 12 | int scm_eq(scm_object *, scm_object *); 13 | int scm_eqv(scm_object *, scm_object *); 14 | int scm_equal(scm_object *, scm_object *); 15 | 16 | void scm_init_bool(scm_env *env); 17 | 18 | #endif //SCHEME_BOOL_H 19 | -------------------------------------------------------------------------------- /src/error.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_ERROR_H 2 | #define SCHEME_ERROR_H 3 | 4 | #include "scm.h" 5 | 6 | void scm_print_error(const char *); 7 | 8 | scm_object* scm_wrong_contract(const char *, const char *, int, int, scm_object *[]); 9 | scm_object* scm_mismatch_arity(scm_object *, int, int, int, int, scm_object *[]); 10 | scm_object* scm_undefined_identifier(scm_symbol *); 11 | scm_object* scm_out_of_range(const char *, scm_object *, int, int, int); 12 | 13 | void scm_throw_eval_error(); 14 | 15 | #endif //SCHEME_ERROR_H 16 | -------------------------------------------------------------------------------- /src/env.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_ENV_H 2 | #define SCHEME_ENV_H 3 | 4 | #include "scm.h" 5 | #include "hashtable.h" 6 | 7 | struct scm_env { 8 | hashtable *bindings; 9 | scm_env *parent; 10 | }; 11 | 12 | scm_env* scm_basic_env(); 13 | scm_env* scm_env_new_frame(int size, scm_env *); 14 | void scm_env_add_binding(scm_env *, scm_symbol *, scm_object *); 15 | int scm_env_update_binding(scm_env *, scm_symbol *, scm_object *); 16 | scm_object* scm_env_lookup(scm_env *, scm_symbol *); 17 | void scm_add_prim(scm_env *, const char *, scm_prim, int, int); 18 | 19 | #endif //SCHEME_ENV_H 20 | -------------------------------------------------------------------------------- /src/hashtable.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef HASHTABLE_H 3 | #define HASHTABLE_H 4 | 5 | /* key相等比较函数 */ 6 | typedef int (*hashtable_key_equal_fn)(void *x, void *y); 7 | 8 | /* 哈希函数 */ 9 | typedef int (*hashtable_hash_fn)(void *key); 10 | 11 | struct hashtable; 12 | typedef struct hashtable hashtable; 13 | 14 | struct hashtable_entry; 15 | typedef struct hashtable_entry hashtable_entry; 16 | 17 | struct hashtable_iter; 18 | typedef struct hashtable_iter hashtable_iter; 19 | 20 | hashtable* hashtable_new(int size, hashtable_key_equal_fn, hashtable_hash_fn); 21 | void hashtable_set(hashtable *, void *key, void *val); 22 | void* hashtable_get(hashtable *, void *key); 23 | int hashtable_count(hashtable *); 24 | 25 | hashtable_iter* hashtable_iter_get(hashtable *); 26 | hashtable_iter* hashtable_iter_next(hashtable *, hashtable_iter *); 27 | void* hashtable_iter_key(hashtable *, hashtable_iter *); 28 | 29 | #endif -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Hu Lang 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/symbol.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_SYMBOL_H 2 | #define SCHEME_SYMBOL_H 3 | 4 | #include "scm.h" 5 | 6 | scm_symbol *scm_quote_symbol; 7 | scm_symbol *scm_dot_symbol; 8 | scm_symbol *scm_if_symbol; 9 | scm_symbol *scm_define_symbol; 10 | scm_symbol *scm_assignment_symbol; 11 | scm_symbol *scm_lambda_symbol; 12 | scm_symbol *scm_begin_symbol; 13 | 14 | scm_symbol *scm_cond_symbol; 15 | scm_symbol *scm_case_symbol; 16 | scm_symbol *scm_else_symbol; 17 | scm_symbol *scm_not_symbol; 18 | scm_symbol *scm_and_symbol; 19 | scm_symbol *scm_or_symbol; 20 | scm_symbol *scm_when_symbol; 21 | scm_symbol *scm_unless_symbol; 22 | 23 | scm_symbol *scm_let_symbol; 24 | 25 | scm_symbol *scm_do_symbol; 26 | scm_symbol *scm_while_symbol; 27 | scm_symbol *scm_for_symbol; 28 | 29 | scm_symbol *scm_inc_assign_symbol; 30 | scm_symbol *scm_dec_assign_symbol; 31 | 32 | scm_symbol *scm_plus_symbol; 33 | scm_symbol *scm_minus_symbol; 34 | scm_symbol *scm_mul_symbol; 35 | scm_symbol *scm_div_symbol; 36 | scm_symbol *scm_lt_symbol; 37 | 38 | scm_symbol *scm_memv_symbol; 39 | 40 | 41 | void scm_init_symbol(scm_env *); 42 | scm_symbol* scm_get_intern_symbol(const char *); 43 | scm_object* scm_gen_symbol(); 44 | 45 | #endif //SCHEME_SYMBOL_H 46 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "scm.h" 4 | #include "port.h" 5 | #include "print.h" 6 | #include "read.h" 7 | #include "system.h" 8 | #include "eval.h" 9 | 10 | char *scm_g_repl_prompt = "> "; 11 | 12 | void repl() 13 | { 14 | puts("Welcome to Scheme. github.com/hulang1024/scheme, (?) for help"); 15 | 16 | scm_object *exp, *val; 17 | 18 | while (1) { 19 | printf("%s", scm_g_repl_prompt); 20 | exp = scm_read(scm_stdin_port); 21 | if (exp) { 22 | val = scm_eval(exp); 23 | if (val && !SCM_VOIDP(val)) { 24 | scm_write(scm_stdout_port, val); 25 | putchar('\n'); 26 | } 27 | } 28 | } 29 | } 30 | 31 | void eval_src_string(char *src) { 32 | scm_object *val = scm_eval_src_string(src); 33 | if (val) 34 | scm_write(scm_stdout_port, val); 35 | } 36 | 37 | int main(int argc, char *argv[]) 38 | { 39 | scm_init(); 40 | if (argc == 1) { 41 | // do repl 42 | repl(); 43 | } else if (argc > 1) { 44 | if (strcmp(argv[1], "--e") == 0) { 45 | if (argc > 2) { 46 | eval_src_string(argv[2]); 47 | } 48 | } else { 49 | // load files 50 | int i; 51 | for (i = 1; i < argc; i++) { 52 | scm_load_file(argv[i]); 53 | } 54 | } 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /src/fun.c: -------------------------------------------------------------------------------- 1 | #include "fun.h" 2 | #include "eval.h" 3 | #include "bool.h" 4 | #include "list.h" 5 | #include "env.h" 6 | #include "error.h" 7 | 8 | static scm_object* procedure_p_prim(int, scm_object *[]); 9 | static scm_object* apply_prim(int, scm_object *[]); 10 | static scm_object* void_prim(int, scm_object *[]); 11 | static scm_object* void_p_prim(int, scm_object *[]); 12 | 13 | void scm_init_fun(scm_env *env) 14 | { 15 | scm_add_prim(env, "procedure?", procedure_p_prim, 1, 1); 16 | scm_add_prim(env, "apply", apply_prim, 2, -1); 17 | scm_add_prim(env, "void", void_prim, 0, 0); 18 | scm_add_prim(env, "void?", void_p_prim, 1, 1); 19 | } 20 | 21 | static scm_object* procedure_p_prim(int argc, scm_object *argv[]) 22 | { 23 | return SCM_BOOL(SCM_PROCEDUREP(argv[0])); 24 | } 25 | 26 | static scm_object* apply_prim(int argc, scm_object *argv[]) 27 | { 28 | if (!SCM_PROCEDUREP(argv[0])) 29 | return scm_wrong_contract("apply", "procedure?", 0, argc, argv); 30 | 31 | scm_object *list = argv[1]; 32 | scm_object **args = malloc(sizeof(scm_object *) * scm_list_length(list)); 33 | int args_cnt = 0; 34 | while (!SCM_NULLP(list)) { 35 | if (SCM_PAIRP(list)) { 36 | args[args_cnt++] = SCM_CAR(list); 37 | list = SCM_CDR(list); 38 | } else { 39 | if (!SCM_NULLP(list)) 40 | return scm_wrong_contract("apply", "list?", 1, argc, argv); 41 | } 42 | } 43 | return scm_apply(argv[0], args_cnt, args); 44 | } 45 | 46 | static scm_object* void_prim(int argc, scm_object *argv[]) 47 | { 48 | return scm_void; 49 | } 50 | 51 | static scm_object* void_p_prim(int argc, scm_object *argv[]) 52 | { 53 | return SCM_BOOL(SCM_VOIDP(argv[0])); 54 | } 55 | -------------------------------------------------------------------------------- /src/list.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_LIST_H 2 | #define SCHEME_LIST_H 3 | 4 | #include "scm.h" 5 | 6 | #define cons(car, cdr) scm_make_pair(car, cdr) 7 | #define SCM_CONS(car, cdr) cons(car, cdr) 8 | #define SCM_LCONS(car, cdr) scm_make_list_pair(car, cdr) 9 | #define SCM_LIST1(a) SCM_LCONS(a, scm_null) 10 | #define SCM_LIST2(a, b) SCM_LCONS(a, SCM_LIST1(b)) 11 | #define SCM_LIST3(a, b, c) SCM_LCONS(a, SCM_LIST2(b, c)) 12 | #define SCM_LIST4(a, b, c, d) SCM_LCONS(a, SCM_LIST3(b, c, d)) 13 | #define SCM_CAAR(o) SCM_CAR(SCM_CAR(o)) 14 | #define SCM_CADR(o) SCM_CAR(SCM_CDR(o)) 15 | #define SCM_CDDR(o) SCM_CDR(SCM_CDR(o)) 16 | #define SCM_CDAR(o) SCM_CDR(SCM_CAR(o)) 17 | #define SCM_CAADR(o) SCM_CAR(SCM_CADR(o)) 18 | #define SCM_CADAR(o) SCM_CAR(SCM_CDAR(o)) 19 | #define SCM_CADDR(o) SCM_CAR(SCM_CDDR(o)) 20 | #define SCM_CDDDR(o) SCM_CDR(SCM_CDDR(o)) 21 | #define SCM_CDADR(o) SCM_CDR(SCM_CADR(o)) 22 | #define SCM_CDDAR(o) SCM_CDR(SCM_CDAR(o)) 23 | #define SCM_CADDDR(o) SCM_CAR(SCM_CDDDR(o)) 24 | #define SCM_CDDDDR(o) SCM_CDR(SCM_CDDDR(o)) 25 | #define SCM_CAADDR(o) SCM_CAR(SCM_CADDR(o)) 26 | #define SCM_CDADDR(o) SCM_CDR(SCM_CADDR(o)) 27 | #define SCM_CADDAR(o) SCM_CAR(SCM_CDDAR(o)) 28 | 29 | /* 30 | * iterate over a list 31 | * @list the proper list variable 32 | */ 33 | #define scm_list_for_each(list) \ 34 | assert(scm_is_list(list)); \ 35 | for (; !SCM_NULLP(list); list = SCM_CDR(list)) 36 | 37 | extern scm_object scm_null[]; 38 | 39 | void scm_init_list(scm_env *env); 40 | scm_object* scm_make_pair(scm_object *, scm_object *); 41 | scm_object* scm_make_list_pair(scm_object *, scm_object *); 42 | scm_object* scm_build_list(int, scm_object **); 43 | scm_object* scm_append_list2(scm_object *, scm_object *); 44 | int scm_list_length(scm_object *); 45 | int scm_is_list(scm_object *); 46 | 47 | #endif //SCHEME_LIST_H 48 | -------------------------------------------------------------------------------- /docs/syntaxs.scm: -------------------------------------------------------------------------------- 1 | (define-syntax case 2 | (syntax-rules (else) 3 | ((_ key ((datum ...) exp1 ...) ...) 4 | (let ((v key)) 5 | (cond ((memv v '(datum ...)) exp1 ...) 6 | ...))) 7 | ((_ key ((datum ...) exp1 ...) ... (else exp2 ...)) 8 | (let ((v key)) 9 | (cond ((memv v '(datum ...)) exp1 ...) 10 | ... 11 | (else exp2 ...)))))) 12 | 13 | (define-syntax when 14 | (syntax-rules () 15 | ((_ test body ...) 16 | (if test 17 | (begin body ...))))) 18 | 19 | (define-syntax unless 20 | (syntax-rules () 21 | ((_ test body ...) 22 | (if (not test) 23 | (begin body ...))))) 24 | 25 | (define-syntax or 26 | (syntax-rules () 27 | ((or) #f) 28 | ((or e) e) 29 | ((or e1 e2 ...) 30 | (let ((temp e1)) 31 | (if temp 32 | temp 33 | (or e2 ...)))))) 34 | 35 | (define-syntax do 36 | (syntax-rules (variable init) 37 | ((do ((variable init step) ...) 38 | (test expression ...) 39 | command ...) 40 | (let iter ((variable init)) 41 | (if test 42 | (begin expression ...) 43 | (begin command ... 44 | (iter step ...))))))) 45 | 46 | ;C like style's while 47 | (define-syntax while 48 | (syntax-rules () 49 | ((_ test body ...) 50 | (let loop () 51 | (when test 52 | body ... 53 | (loop)))))) 54 | 55 | (define-syntax for 56 | (syntax-rules (to) 57 | ;; loop in sequence 58 | ;; (for i (0 to 10) do something...) 59 | ((_ i in (from to end) body ...) 60 | (let loop ((i from)) 61 | (when (< i end) 62 | body ... 63 | (loop (+ i 1))))) 64 | ;; loop in list 65 | ;; (for i in '(a b c) do something...) 66 | ((_ i in lst body ...) 67 | (let loop ((l lst)) 68 | (unless (null? l) 69 | (let ((i (car l))) 70 | body ... 71 | (loop (cdr l)))))))) 72 | -------------------------------------------------------------------------------- /src/cc/unicc.c: -------------------------------------------------------------------------------- 1 | /************************************************** 2 | * Author: HuLang * 3 | * Notes: Some functions about Console Control. * 4 | * License: Copyleft. Enjoy it Just for fun. * 5 | * Date: 2008-12-17 00:28:39 * 6 | ***************************************************/ 7 | 8 | #ifndef _WIN32 9 | #include "cc.h" 10 | 11 | void delayMS(uint32 d) 12 | { 13 | return ; 14 | } 15 | 16 | void clearText(void) 17 | { 18 | return ; 19 | } 20 | 21 | int setTextColor(uint8 fColor) 22 | { 23 | return 0; 24 | } 25 | 26 | PCCOLOR getTextColor(void) 27 | { 28 | return 0; 29 | } 30 | 31 | int setBackColor(uint8 bColor) 32 | { 33 | return 0; 34 | } 35 | 36 | PCCOLOR getBackColor(void) 37 | { 38 | return 0; 39 | } 40 | 41 | int setColors(uint8 fColor, uint8 bColor) 42 | { 43 | return 0; 44 | } 45 | 46 | int setSwapColors(int b) 47 | { 48 | return 0; 49 | } 50 | 51 | int setUnderLine(int b) 52 | { 53 | return 0; 54 | } 55 | 56 | uint8 getLineWidth(void) 57 | { 58 | return 0; 59 | } 60 | 61 | uint8 getLineNum(void) 62 | { 63 | return 0; 64 | } 65 | 66 | uint8 getCursorX(void) 67 | { 68 | return 0; 69 | } 70 | 71 | uint8 getCursorY(void) 72 | { 73 | return 0; 74 | } 75 | 76 | int gotoTextPos(uint8 x, uint8 y) 77 | { 78 | return 0; 79 | } 80 | 81 | int setCursorVisible(int b) 82 | { 83 | return 0; 84 | } 85 | 86 | int setCursorSize(uint8 s) 87 | { 88 | return 0; 89 | } 90 | 91 | int getConsoleTitle(char *title, uint8 len) 92 | { 93 | return 0; 94 | } 95 | 96 | int setConsoleTitle(char *title) 97 | { 98 | return 0; 99 | } 100 | 101 | int fixConsoleSize(uint16 width, uint16 height) 102 | { 103 | return 0; 104 | } 105 | 106 | int showConsoleInfo() 107 | { 108 | return 0; 109 | } 110 | 111 | int simpleRing(uint16 freq, uint16 len) 112 | { 113 | return 0; 114 | } 115 | 116 | uint16 jkGetKey(void) 117 | { 118 | return 0; 119 | } 120 | 121 | int jkHasKey(void) 122 | { 123 | return 0; 124 | } 125 | 126 | #endif 127 | //End of pcc32.c 128 | -------------------------------------------------------------------------------- /src/port.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_PORT_H 2 | #define SCHEME_PORT_H 3 | 4 | #include 5 | #include "scm.h" 6 | 7 | #define scm_eofp(ch) ((ch) == EOF) 8 | 9 | #define INPUT_PORT_GETC_FUNC(o) (((scm_input_port *)o)->getc) 10 | #define INPUT_PORT_UNGETC_FUNC(o) (((scm_input_port *)o)->ungetc) 11 | #define OUTPUT_PORT_PUTC_FUNC(o) (((scm_output_port *)o)->putc) 12 | #define OUTPUT_PORT_WRITE_CSTR_FUNC(o) (((scm_output_port *)o)->write_cstr) 13 | #define FILE_INPUT_PORT_FILE(o) (((scm_file_input_port *)o)->f) 14 | #define FILE_OUTPUT_PORT_FILE(o) (((scm_file_output_port *)o)->f) 15 | #define CHAR_STRING_INPUT_PORT_BUF(o) (((scm_char_string_input_port *)o)->buf) 16 | #define CHAR_STRING_OUTPUT_PORT_BUF(o) (((scm_char_string_output_port *)o)->buf) 17 | 18 | struct scm_input_port; 19 | struct scm_output_port; 20 | typedef struct scm_input_port scm_input_port; 21 | typedef struct scm_output_port scm_output_port; 22 | 23 | typedef int (*getc_fn)(scm_input_port *); 24 | typedef int (*ungetc_fn)(scm_input_port *, int); 25 | typedef int (*putc_fn)(scm_output_port *, int); 26 | typedef int (*write_cstr_fn)(scm_output_port *, const char *); 27 | typedef int (*close_fn)(scm_input_port *); 28 | 29 | struct scm_input_port { 30 | scm_object o; 31 | getc_fn getc; 32 | ungetc_fn ungetc; 33 | close_fn close; 34 | }; 35 | 36 | struct scm_output_port { 37 | scm_object o; 38 | putc_fn putc; 39 | write_cstr_fn write_cstr; 40 | }; 41 | 42 | typedef struct { 43 | scm_input_port in; 44 | FILE *f; 45 | } scm_file_input_port; 46 | 47 | typedef struct { 48 | scm_output_port out; 49 | FILE *f; 50 | } scm_file_output_port; 51 | 52 | typedef struct { 53 | scm_input_port in; 54 | char* buf; 55 | int size; 56 | int cnt; 57 | } scm_char_string_input_port; 58 | 59 | typedef struct { 60 | scm_output_port out; 61 | char* buf; 62 | int size; 63 | int cnt; 64 | } scm_char_string_output_port; 65 | 66 | scm_object *scm_stdin_port; 67 | scm_object *scm_stdout_port; 68 | 69 | void scm_init_port(scm_env *); 70 | 71 | int scm_getc(scm_object* port); 72 | int scm_ungetc(int ch, scm_object* port); 73 | int scm_putc(scm_object* port, int c); 74 | int scm_write_cstr(scm_object* port, const char *s); 75 | scm_object* scm_close_output_port(scm_object *); 76 | scm_object* scm_close_input_port(scm_object *); 77 | 78 | scm_object* scm_make_stdout_port(); 79 | scm_object* scm_make_stdin_port(); 80 | 81 | scm_object* scm_make_file_output_port(FILE *); 82 | scm_object* scm_make_file_input_port(FILE *); 83 | 84 | scm_object* scm_make_char_string_output_port(int size); 85 | scm_object* scm_make_char_string_input_port(const char *, int size); 86 | 87 | 88 | #endif //SCHEME_PORT_H 89 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # scheme 2 | Scheme编程语言的一个解释器。 3 | 4 | 5 | ## 用法 6 | 运行`scheme`会开始并给你一个REPL(Read-Eval-Print-Loop)环境。 7 | 调用`load`加载执行源文件: 8 | `(load "file1.scm")` 9 | 执行源文件: 10 | `scheme file1.scm file2.scm` 11 | `--e`选项接收一个代码字符串以执行: 12 | `scheme --e "(define x 1) (+ x 2)"` 13 | ### 例子 14 | 见[/scheme/](https://github.com/hulang1024/Lisp-programs/tree/master/scheme)和[/scheme/tests/pcc32](https://github.com/hulang1024/Lisp-programs/tree/master/scheme/tests/pcc32) 15 | 16 | 17 | ## 特性 18 | * 变量引用 19 | * 局部变量: `let` 20 | * 常量引用: `quote`,`'` 21 | * 过程调用 22 | * 过程(函数): `lambda` 23 | + 可变参数 24 | * 第一级函数 25 | * 静态(词法)作用域 26 | * 闭包 27 | * 动态类型 28 | * 传值调用 29 | * 条件表达式: `if`,`when`,`unless`,`and`,`or`,`cond`,`case` 30 | * 递归 31 | * 尾递归 32 | * 顺序结构: `begin` 33 | * 迭代结构: `let`,`do`,`while`,`for` 34 | * 定义: `define` 35 | * 赋值: `set!`,`inc!`,`dec!` 36 | 37 | * 标准过程 38 | + 相等谓词 39 | `eq?`,`equal?` 40 | + 数值运算和数值输入/输出 41 | `number?`,`=`,`<`,`<`,`>`,`<=`,`>=`,`+`,`*`,`-`,`/`, 42 | `zero?`,`positive?`,`negative?`,`odd?`,`even?`,`abs`,`remainder`,`modulo` 43 | 1. 整数: `integer?` 44 | 2. 实数: `real?` 45 | + 布尔 46 | `boolean?`,`not` 47 | + 序对和表 48 | `pair?`,`null?`,`list?`,`cons`,`car`,`cdr`,`set-car!`,`set-cdr!`, 49 | `caar`,`cadr` `...` `cdddar`,`cddddr` (`car`和`cdr`的组合,默认定义到第四层), 50 | `list`,`length`,`memq`,`memv`,`member`,`list-tail`,`list-ref`,`append`,`reverse` 51 | + 符号 52 | `symbol?` 53 | + 字符 54 | `char?`,`char=?`,`char?`,`char<=?`,`char>=?`, 55 | `char-ci=?`,`char-ci?`,`char-ci<=?`,`char-ci>=?`, 56 | `char-alphabetic?`,`char-numeric?`,`char-whitespace?`,`char-upper-case?`,`char-lower-case?`, 57 | `char->integer`,`integer->char`, 58 | `char-upcase`,`char-downcase` 59 | + 字符串 60 | `string?`,`make-string`,`string`,`string-length`,`string-ref`,`string-set!`,`substring`,`string-append`, 61 | `string->list`,`list->string`,`string-copy`,`string-fill!` 62 | + 向量 63 | `vector?`,`make-vector`,`vector`,`vector-set!`,`vector-ref`,`vector-length`, 64 | `vector->list`,`list->vector`,`vector-fill!` 65 | + 控制特征 66 | `procedure?`,`apply`,`void`,`void?` 67 | + 求值 68 | `eval` 69 | + 输入/输出 70 | `read`,`write`,`newline`,`display` 71 | + 系统接口 72 | `load`,`time`,`clock`,`rand`,`?`,`exit`,`set` 73 | * 注释 74 | 单行注释: `; ...` 75 | 76 | * 扩展 77 | + 中括号`[]`, 大括号`{}` 78 | + 多行注释: `#| ... |#` 79 | 80 | * 内置库 81 | + Windows32 Console Control 82 | 83 | 84 | Author 85 | ------- 86 | [hulang1024](https://github.com/hulang1024) 87 | 88 | 89 | License 90 | ------- 91 | MIT 92 | -------------------------------------------------------------------------------- /src/hashtable.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "hashtable.h" 3 | 4 | struct hashtable_entry { 5 | void *key; 6 | void *val; 7 | }; 8 | 9 | struct hashtable { 10 | int size; 11 | int count; 12 | hashtable_entry *array; 13 | 14 | hashtable_key_equal_fn key_equal_fn; 15 | hashtable_hash_fn hash_fn; 16 | }; 17 | 18 | static void reset(hashtable *ht, int resize) 19 | { 20 | ht->size = resize; 21 | ht->count = 0; 22 | 23 | ht->array = (hashtable_entry *)malloc(ht->size * sizeof(hashtable_entry)); 24 | int i; 25 | for (i = 0; i < resize; i++) 26 | ht->array[i].key = NULL; 27 | } 28 | 29 | static void grow(hashtable *ht) 30 | { 31 | hashtable_entry *old = ht->array; 32 | int oldsize = ht->size; 33 | int i; 34 | 35 | reset(ht, oldsize * 2); 36 | 37 | for (i = 0; i < oldsize; i++) { 38 | if (old[i].key) 39 | hashtable_set(ht, old[i].key, old[i].val); 40 | } 41 | } 42 | 43 | hashtable* hashtable_new(int size, hashtable_key_equal_fn key_equal_fn, hashtable_hash_fn hash_fn) 44 | { 45 | hashtable *ht = malloc(sizeof(hashtable)); 46 | ht->key_equal_fn = key_equal_fn; 47 | ht->hash_fn = hash_fn; 48 | 49 | reset(ht, size); 50 | 51 | return ht; 52 | } 53 | 54 | 55 | void hashtable_set(hashtable *ht, void *key, void *val) 56 | { 57 | int i = ht->hash_fn(key) % ht->size; 58 | 59 | while (1) { 60 | if (!ht->array[i].key) 61 | break; 62 | if (ht->key_equal_fn(ht->array[i].key, key)) { 63 | ht->array[i].val = val; 64 | return; 65 | } 66 | i = (i + 1) % ht->size; 67 | } 68 | 69 | ht->array[i].key = key; 70 | ht->array[i].val = val; 71 | 72 | ht->count++; 73 | 74 | if (ht->count > ht->size * 0.5) 75 | grow(ht); 76 | } 77 | 78 | void* hashtable_get(hashtable *ht, void *key) 79 | { 80 | int i = ht->hash_fn(key) % ht->size; 81 | 82 | while (1) { 83 | if (!ht->array[i].key) 84 | return NULL; 85 | if (ht->key_equal_fn(ht->array[i].key, key)) 86 | return ht->array[i].val; 87 | i = (i + 1) % ht->size; 88 | } 89 | } 90 | 91 | int hashtable_count(hashtable *ht) 92 | { 93 | return ht->count; 94 | } 95 | 96 | 97 | struct hashtable_iter { 98 | int pos; 99 | }; 100 | 101 | hashtable_iter* hashtable_iter_get(hashtable *ht) 102 | { 103 | hashtable_iter *iter = malloc(sizeof(hashtable_iter)); 104 | iter->pos = 0; 105 | 106 | return iter; 107 | } 108 | 109 | hashtable_iter* hashtable_iter_next(hashtable *ht, hashtable_iter *iter) 110 | { 111 | iter->pos++; 112 | if (iter->pos >= ht->size) 113 | return NULL; 114 | else 115 | return iter; 116 | } 117 | 118 | void* hashtable_iter_key(hashtable *ht, hashtable_iter *iter) 119 | { 120 | return ht->array[iter->pos].key; 121 | } 122 | -------------------------------------------------------------------------------- /src/bool.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "bool.h" 3 | #include "list.h" 4 | #include "env.h" 5 | 6 | scm_object scm_true[1]; 7 | scm_object scm_false[1]; 8 | scm_object scm_void[1]; 9 | 10 | static scm_object* boolean_p_prim(int, scm_object *[]); 11 | static scm_object* not_p_prim(int, scm_object *[]); 12 | static scm_object* equal_p_prim(int, scm_object *[]); 13 | static scm_object* eqv_p_prim(int, scm_object *[]); 14 | static scm_object* eq_p_prim(int, scm_object *[]); 15 | 16 | void scm_init_bool(scm_env *env) 17 | { 18 | // initialize types 19 | scm_true->type = scm_true_type; 20 | scm_false->type = scm_false_type; 21 | scm_void->type = scm_void_type; 22 | 23 | scm_add_prim(env, "boolean?", boolean_p_prim, 1, 1); 24 | scm_add_prim(env, "not", not_p_prim, 1, 1); 25 | scm_add_prim(env, "equal?", equal_p_prim, 2, 2); 26 | scm_add_prim(env, "eqv?", eqv_p_prim, 2, 2); 27 | scm_add_prim(env, "eq?", eq_p_prim, 2, 2); 28 | } 29 | 30 | int scm_eq(scm_object *x, scm_object *y) 31 | { 32 | return scm_equal(x, y); 33 | } 34 | 35 | int scm_eqv(scm_object *x, scm_object *y) 36 | { 37 | return scm_equal(x, y); 38 | } 39 | 40 | int scm_equal(scm_object *x, scm_object *y) 41 | { 42 | if (!SCM_SAME_TYPE(SCM_TYPE(x), SCM_TYPE(y))) // types: true, false, void, null, ... 43 | return 0; 44 | 45 | switch (SCM_TYPE(x)) { 46 | case scm_integer_type: 47 | return SCM_INT_VAL(x) == SCM_INT_VAL(y); 48 | case scm_float_type: 49 | return SCM_FLOAT_VAL(x) == SCM_FLOAT_VAL(y); 50 | case scm_char_type: 51 | return SCM_CHAR_VAL(x) == SCM_CHAR_VAL(y); 52 | case scm_string_type: 53 | return strcmp(SCM_CHAR_STR_VAL(x), SCM_CHAR_STR_VAL(y)) == 0; 54 | case scm_symbol_type: 55 | case scm_true_type: 56 | case scm_false_type: 57 | case scm_pair_type: 58 | // TODO: equal of pair 59 | case scm_vector_type: 60 | // TODO: equal of vector 61 | case scm_null_type: 62 | case scm_void_type: 63 | case scm_primitive_type: 64 | case scm_compound_type: 65 | case scm_input_port_type: 66 | case scm_output_port_type: 67 | case scm_namespace_type: 68 | default: 69 | if (!SAME_OBJ(x, y)) 70 | return 0; 71 | else 72 | return 1; 73 | } 74 | return 0; 75 | } 76 | 77 | static scm_object* boolean_p_prim(int argc, scm_object *argv[]) 78 | { 79 | return SCM_BOOL(SCM_BOOLP(argv[0])); 80 | } 81 | 82 | static scm_object* not_p_prim(int argc, scm_object *argv[]) 83 | { 84 | return SCM_FALSEP(argv[0]) ? scm_true : scm_false; 85 | } 86 | 87 | static scm_object* equal_p_prim(int argc, scm_object *argv[]) 88 | { 89 | return SCM_BOOL(scm_equal(argv[0], argv[1])); 90 | } 91 | 92 | static scm_object* eqv_p_prim(int argc, scm_object *argv[]) 93 | { 94 | return SCM_BOOL(scm_equal(argv[0], argv[1])); 95 | } 96 | 97 | static scm_object* eq_p_prim(int argc, scm_object *argv[]) 98 | { 99 | return SCM_BOOL(scm_equal(argv[0], argv[1])); 100 | } 101 | -------------------------------------------------------------------------------- /src/env.c: -------------------------------------------------------------------------------- 1 | #include "env.h" 2 | #include "bool.h" 3 | #include "number.h" 4 | #include "symbol.h" 5 | #include "char.h" 6 | #include "str.h" 7 | #include "list.h" 8 | #include "vector.h" 9 | #include "read.h" 10 | #include "print.h" 11 | #include "fun.h" 12 | #include "eval.h" 13 | #include "system.h" 14 | #include "lib/builtinlib.h" 15 | 16 | #define SCM_SAME_SYMBOL(a, b) SAME_PTR(a, b) 17 | #define SCM_SYMBOL_HASH(sym) ((int)sym) 18 | 19 | int symbol_equal(void *x, void *y) 20 | { 21 | return SCM_SAME_SYMBOL(x, y); 22 | } 23 | 24 | int symbol_hash(void *sym) 25 | { 26 | return SCM_SYMBOL_HASH(sym); 27 | } 28 | 29 | scm_env* scm_basic_env() 30 | { 31 | scm_env *env = scm_env_new_frame(120, NULL); 32 | 33 | scm_init_symbol(env); 34 | scm_init_bool(env); 35 | scm_init_char(env); 36 | scm_init_string(env); 37 | scm_init_number(env); 38 | scm_init_list(env); 39 | scm_init_vector(env); 40 | scm_init_port(env); 41 | scm_init_print(env); 42 | scm_init_read(env); 43 | scm_init_fun(env); 44 | scm_init_eval(env); 45 | scm_init_system(env); 46 | 47 | scm_init_builtin_lib(env); 48 | 49 | return env; 50 | } 51 | 52 | scm_env* scm_env_new_frame(int size, scm_env *parent) 53 | { 54 | scm_env *env = (scm_env *)scm_malloc_object(sizeof(scm_env)); 55 | env->bindings = hashtable_new(size, symbol_equal, symbol_hash); 56 | env->parent = parent; 57 | 58 | return env; 59 | } 60 | 61 | void scm_env_add_binding(scm_env *env, scm_symbol *id, scm_object *val) 62 | { 63 | hashtable_set(env->bindings, id, val); 64 | } 65 | 66 | int scm_env_update_binding(scm_env *env, scm_symbol *id, scm_object *val) 67 | { 68 | scm_env *set_env = env; 69 | 70 | while (hashtable_get(set_env->bindings, id) == NULL) { 71 | set_env = set_env->parent; 72 | if (set_env == NULL) { 73 | return 1; 74 | } 75 | } 76 | 77 | hashtable_set(set_env->bindings, id, val); 78 | 79 | return 0; 80 | } 81 | 82 | scm_object* scm_env_lookup(scm_env *env, scm_symbol *id) 83 | { 84 | scm_object *obj = NULL; 85 | scm_env *parent = env; 86 | 87 | while (((obj = hashtable_get(parent->bindings, id)) == NULL)) { 88 | parent = parent->parent; 89 | if (parent == NULL) { 90 | return NULL; 91 | } 92 | } 93 | 94 | return obj; 95 | } 96 | 97 | void scm_add_prim(scm_env *env, const char *name, scm_prim prim, int min_arity, int max_arity) 98 | { 99 | assert(0 <= min_arity && max_arity >= -1 100 | && (max_arity >= 0 ? min_arity <= max_arity : 1)); 101 | // make primitive procedure 102 | scm_primitive_proc *pprim = (scm_primitive_proc *)scm_malloc_object(sizeof(scm_primitive_proc)); 103 | ((scm_object *)pprim)->type = scm_primitive_type; 104 | pprim->name = name; 105 | pprim->prim = prim; 106 | pprim->min_arity = min_arity; 107 | pprim->max_arity = max_arity; 108 | 109 | scm_env_add_binding(env, scm_get_intern_symbol(name), (scm_object *)pprim); 110 | } 111 | -------------------------------------------------------------------------------- /src/symbol.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "symbol.h" 3 | #include "bool.h" 4 | #include "list.h" 5 | #include "env.h" 6 | #include "error.h" 7 | #include "hashtable.h" 8 | 9 | // TODO: hashtable 10 | static hashtable *symbols = NULL; 11 | static intptr_t gen_sym_id = 0; 12 | 13 | static scm_object* symbol_p_prim(int, scm_object *[]); 14 | 15 | static int symbol_equal(void *x, void *y) 16 | { 17 | return strcmp((char *)x, (char *)y) == 0; 18 | } 19 | 20 | static int symbol_hash(void *s) 21 | { 22 | int ret = 0; 23 | char *sc = s; 24 | while (*sc) { 25 | ret *= 10; 26 | ret += *sc++; 27 | } 28 | 29 | if (ret < 0) ret = -ret; 30 | 31 | return ret; 32 | } 33 | 34 | void scm_init_symbol(scm_env *env) 35 | { 36 | symbols = hashtable_new(1024, symbol_equal, symbol_hash); 37 | 38 | scm_quote_symbol = scm_get_intern_symbol("quote"); 39 | scm_dot_symbol = scm_get_intern_symbol("."); 40 | scm_if_symbol = scm_get_intern_symbol("if"); 41 | scm_define_symbol = scm_get_intern_symbol("define"); 42 | scm_assignment_symbol = scm_get_intern_symbol("set!"); 43 | scm_lambda_symbol = scm_get_intern_symbol("lambda"); 44 | scm_begin_symbol = scm_get_intern_symbol("begin"); 45 | scm_cond_symbol = scm_get_intern_symbol("cond"); 46 | scm_case_symbol = scm_get_intern_symbol("case"); 47 | scm_else_symbol = scm_get_intern_symbol("else"); 48 | scm_not_symbol = scm_get_intern_symbol("not"); 49 | scm_and_symbol = scm_get_intern_symbol("and"); 50 | scm_or_symbol = scm_get_intern_symbol("or"); 51 | scm_when_symbol = scm_get_intern_symbol("when"); 52 | scm_unless_symbol = scm_get_intern_symbol("unless"); 53 | scm_let_symbol = scm_get_intern_symbol("let"); 54 | scm_do_symbol = scm_get_intern_symbol("do"); 55 | scm_while_symbol = scm_get_intern_symbol("while"); 56 | scm_for_symbol = scm_get_intern_symbol("for"); 57 | 58 | scm_inc_assign_symbol = scm_get_intern_symbol("inc!"); 59 | scm_dec_assign_symbol = scm_get_intern_symbol("dec!"); 60 | 61 | scm_plus_symbol = scm_get_intern_symbol("+"); 62 | scm_minus_symbol = scm_get_intern_symbol("-"); 63 | scm_mul_symbol = scm_get_intern_symbol("*"); 64 | scm_div_symbol = scm_get_intern_symbol("/"); 65 | scm_lt_symbol = scm_get_intern_symbol("<"); 66 | 67 | scm_memv_symbol = scm_get_intern_symbol("memv"); 68 | 69 | scm_add_prim(env, "symbol?", symbol_p_prim, 1, 1); 70 | } 71 | 72 | static scm_object* scm_make_symbol(const char *s) 73 | { 74 | scm_object *o = scm_malloc_object(sizeof(scm_symbol)); 75 | o->type = scm_symbol_type; 76 | SCM_SYMBOL_STR_VAL(o) = s; 77 | return o; 78 | } 79 | 80 | scm_symbol* scm_get_intern_symbol(const char *str) 81 | { 82 | assert(symbols != NULL); 83 | 84 | scm_symbol *sym = hashtable_get(symbols, (void *)str); 85 | 86 | if (sym == NULL) { // if not interned 87 | sym = (scm_symbol *) scm_make_symbol((char *)str); 88 | // intern 89 | hashtable_set(symbols, (void *)str, sym); 90 | } 91 | 92 | return sym; 93 | } 94 | 95 | void scm_reset_gen_symbol() 96 | { 97 | gen_sym_id = 0; 98 | } 99 | 100 | scm_object* scm_gen_symbol() 101 | { 102 | gen_sym_id++; 103 | return scm_make_symbol((const char *)gen_sym_id); 104 | } 105 | 106 | static scm_object* symbol_p_prim(int argc, scm_object *argv[]) 107 | { 108 | return SCM_BOOL(SCM_SYMBOLP(argv[0])); 109 | } 110 | -------------------------------------------------------------------------------- /src/eval.h: -------------------------------------------------------------------------------- 1 | #ifndef SCHEME_EVAL_H 2 | #define SCHEME_EVAL_H 3 | 4 | #include "scm.h" 5 | #include "list.h" 6 | #include 7 | 8 | 9 | #define scm_operator SCM_CAR 10 | #define scm_operands SCM_CDR 11 | #define scm_make_app(operator, operands) SCM_LCONS((scm_object *)operator, operands) 12 | #define scm_make_app0(operator) scm_make_app(operator, scm_null) 13 | 14 | #define scm_quoted_object SCM_CADR 15 | #define scm_make_quotation(o) SCM_LIST2((scm_object *)scm_quote_symbol, o) 16 | 17 | #define scm_if_predicate SCM_CADR 18 | #define scm_if_consequent SCM_CADDR 19 | #define scm_if_alternative(exp) (SCM_NULLP(SCM_CDDDR(exp)) ? SCM_CDDDR(exp) : SCM_CADDDR(exp)) 20 | #define scm_make_if(pred, consequent, alternative) \ 21 | SCM_LIST4((scm_object *)scm_if_symbol, pred, consequent, alternative) 22 | #define scm_make_if1(pred, consequent) SCM_LIST3((scm_object *)scm_if_symbol, pred, consequent) 23 | 24 | #define scm_lambda_paramters SCM_CADR 25 | #define scm_lambda_body SCM_CDDR 26 | #define scm_make_lambda(params, body) SCM_LCONS((scm_object *)scm_lambda_symbol, SCM_CONS(params, body)) 27 | 28 | #define scm_definition_var(exp) ((scm_symbol *)(SCM_SYMBOLP(SCM_CADR(exp)) ? \ 29 | SCM_CADR(exp) : SCM_PAIRP(SCM_CADR(exp)) ? \ 30 | SCM_CAADR(exp) : SCM_CADR(exp))) 31 | #define scm_definition_val(exp) (SCM_SYMBOLP(SCM_CADR(exp)) ? \ 32 | SCM_CADDR(exp) : scm_make_lambda(SCM_CDADR(exp), SCM_CDDR(exp))) 33 | #define scm_make_def(var, val) SCM_LIST3((scm_object *)scm_define_symbol, var, val) 34 | 35 | #define scm_assignment_var(exp) SCM_CADR(exp) 36 | #define scm_assignment_val SCM_CADDR 37 | 38 | #define scm_begin_actions SCM_CDR 39 | #define scm_make_begin(seq) SCM_LCONS((scm_object *)scm_begin_symbol, seq) 40 | #define scm_sequence_exp(seq) (SCM_NULLP(seq) ? \ 41 | seq : SCM_NULLP(SCM_CDR(seq)) ? SCM_CAR(seq) : scm_make_begin(seq)) 42 | 43 | #define scm_and_tests SCM_CDR 44 | #define scm_or_tests SCM_CDR 45 | 46 | #define scm_when_test SCM_CADR 47 | #define scm_when_body SCM_CDDR 48 | #define scm_make_when(test, body) SCM_LCONS((scm_object *)scm_when_symbol, SCM_LCONS(test, body)) 49 | #define scm_unless_test SCM_CADR 50 | #define scm_unless_body SCM_CDDR 51 | 52 | #define scm_is_named_let(exp) SCM_SYMBOLP(SCM_CADR(exp)) 53 | #define scm_let_var(exp) SCM_CADR(exp) 54 | #define scm_let_bindings(exp) (scm_is_named_let(exp) ? SCM_CADDR(exp) : SCM_CADR(exp)) 55 | #define scm_let_body(exp) (scm_is_named_let(exp) ? SCM_CDDDR(exp) : SCM_CDDR(exp)) 56 | #define scm_make_let(bindings, body) SCM_LIST3((scm_object *)scm_let_symbol, bindings, body) 57 | #define scm_make_named_let(name, bindings, body) SCM_LIST4((scm_object *)scm_let_symbol, name, bindings, body) 58 | 59 | #define scm_cond_clauses SCM_CDR 60 | #define scm_clause_test SCM_CAR 61 | #define scm_clause_actions SCM_CDR 62 | #define scm_is_else_clause(clause) SAME_OBJ(scm_clause_test(clause), (scm_object *)scm_else_symbol) 63 | #define scm_make_cond(clauses) SCM_LCONS((scm_object *)scm_cond_symbol, clauses) 64 | 65 | #define scm_case_key SCM_CADR 66 | #define scm_case_clauses SCM_CDDR 67 | 68 | #define scm_do_bindings SCM_CADR 69 | #define scm_do_test SCM_CAADDR 70 | #define scm_do_actions SCM_CDADDR 71 | #define scm_do_commands SCM_CDDDR 72 | 73 | #define scm_while_test SCM_CADR 74 | #define scm_while_body SCM_CDDR 75 | 76 | #define scm_for_var SCM_CADR 77 | #define scm_for_list SCM_CADDDR 78 | #define scm_for_list_start(list) SCM_CAR(list) 79 | #define scm_for_list_end(list) SCM_CADDR(list) 80 | #define scm_for_body SCM_CDDDDR 81 | 82 | 83 | extern jmp_buf eval_error_jmp_buf; 84 | 85 | void scm_init(); 86 | void scm_init_eval(scm_env *); 87 | scm_object* scm_eval(scm_object *); 88 | scm_object* scm_apply(scm_object *, int, scm_object *[]); 89 | scm_object* scm_eval_src_string(char *); 90 | #endif //SCHEME_EVAL_H 91 | -------------------------------------------------------------------------------- /src/cc/cc.h: -------------------------------------------------------------------------------- 1 | /************************************************** 2 | * Author: HuLang * 3 | * Notes: Some functions about Console Control. * 4 | * License: Copyleft. Enjoy it Just for fun. * 5 | * Date: 2008-12-17 00:28:39 * 6 | ***************************************************/ 7 | 8 | #ifndef CC_H_INCLUDED 9 | #define CC_H_INCLUDED 10 | 11 | #ifdef _WIN32 12 | #include 13 | #include 14 | #include 15 | #include 16 | #else 17 | #include 18 | #include 19 | #include 20 | #endif 21 | 22 | #ifndef COMMEN_TYPE 23 | #define COMMEN_TYPE 24 | 25 | typedef unsigned char uint8; 26 | typedef unsigned short uint16; 27 | typedef unsigned long uint32; 28 | 29 | #endif // COMMEN_TYPE 30 | 31 | /* 按键定义 */ 32 | #define JK_FUNC_KEY 0x00 33 | #define JK_CTRL_KEY 0xE0 34 | 35 | #define JK_ESC 0x001B 36 | #define JK_ENTER 0x000D 37 | #define JK_SPACE 0x0020 38 | #define JK_BKSPACE 0x0008 39 | #define JK_TAB 0x0009 40 | 41 | #define JK_CTRL_Z 0x001A 42 | #define JK_CTRL_X 0x0018 43 | #define JK_CTRL_C 0x0003 44 | #define JK_CTRL_A 0x0001 45 | #define JK_CTRL_S 0x0013 46 | #define JK_CTRL_D 0x0004 47 | 48 | #define JK_LEFT 0xE04B 49 | #define JK_RIGHT 0xE04D 50 | #define JK_UP 0xE048 51 | #define JK_DOWN 0xE050 52 | #define JK_INSERT 0xE052 53 | #define JK_HOME 0xE047 54 | #define JK_PGUP 0xE049 55 | #define JK_DELETE 0xE053 56 | #define JK_END 0xE04F 57 | #define JK_PGDW 0xE051 58 | 59 | #define JK_F1 0xFF3B 60 | #define JK_F2 0xFF3C 61 | #define JK_F3 0xFF3D 62 | #define JK_F4 0xFF3E 63 | #define JK_F5 0xFF3F 64 | #define JK_F6 0xFF40 65 | #define JK_F7 0xFF41 66 | #define JK_F8 0xFF42 67 | #define JK_F9 0xFF43 68 | #define JK_F10 0xFF44 69 | #define JK_F11 0xE085 70 | #define JK_F12 0xE086 71 | 72 | /* 控制台尺寸定义 */ 73 | #define MIN_CONSOLE_WIDTH 14 74 | #define MIN_CONSOLE_HEIGHT 1 75 | 76 | /* 颜色定义 */ 77 | typedef enum _PCCOLOR 78 | { 79 | BLACK = 0, // 黑色 80 | BLUE = 1, // 蓝色 81 | GREEN = 2, // 绿色 82 | CYAN = 3, // 青色 83 | RED = 4, // 红色 84 | MAGENTA = 5, // 紫色 85 | BROWN = 6, // 褐色 86 | LIGHT_GRAY = 7, // 浅灰 87 | DARK_GRAY = 8, // 深灰 88 | LIGHT_BLUE = 9, // 亮蓝 89 | LIGHT_GREEN = 10, // 亮绿 90 | LIGHT_CYAN = 11, // 浅蓝 91 | LIGHT_RED = 12, // 亮红 92 | LIGHT_MAGENTA = 13, // 亮紫 93 | YELLOW = 14, // 黄色 94 | WHITE = 15 // 白色 95 | }PCCOLOR; 96 | 97 | #ifdef __cplusplus 98 | extern "C" 99 | { 100 | #endif 101 | 102 | /* 延时,以毫秒计 */ 103 | void delayMS(uint32 d); 104 | /* 清除文字 */ 105 | void clearText(void); 106 | /* 暂停,等待用户按键 */ 107 | void pauseHere(void); 108 | /* 发出简单的响铃声(阻塞,慎用) */ 109 | int simpleRing(uint16 freq, uint16 len); 110 | 111 | /* 设置文本颜色,0~15 */ 112 | int setTextColor(uint8 fColor); 113 | /* 获取文本颜色,0~15 */ 114 | PCCOLOR getTextColor(void); 115 | /* 设置文本背景颜色,0~15 */ 116 | int setBackColor(uint8 bColor); 117 | /* 获取文本背景颜色,0~15 */ 118 | PCCOLOR getBackColor(void); 119 | /* 设置文本及其背景颜色,0~15 */ 120 | int setColors(uint8 fColor, uint8 bColor); 121 | /* 设置/取消前/背景颜色的交换解析 */ 122 | int setSwapColors(int b); 123 | /* 设定/取消文字的下划线 */ 124 | int setUnderLine(int b); 125 | 126 | /* 获取控制台文本行的最大长度[默认为80] */ 127 | uint8 getLineWidth(void); 128 | /* 获取控制台文本行的最大行数 */ 129 | uint8 getLineNum(void); 130 | 131 | 132 | /* 获取光标的横坐标[列数] */ 133 | uint8 getCursorX(void); 134 | /* 获取光标的纵坐标[行数] */ 135 | uint8 getCursorY(void); 136 | /* 屏幕光标定位,x为列(横),y为行(纵) */ 137 | int gotoTextPos(uint8 x, uint8 y); 138 | /* 设置光标的可见性 */ 139 | int setCursorVisible(int b); 140 | /* 设置光标的(厚度)尺寸,1-100 */ 141 | int setCursorSize(uint8 s); 142 | 143 | /* 获取控制台的标题字符串 */ 144 | int getConsoleTitle(char *title, uint8 len); 145 | /* 设置控制台的标题字符串 */ 146 | int setConsoleTitle(char *title); 147 | 148 | /* 设置一个没有滚动条的控制台窗口尺寸 */ 149 | int fixConsoleSize(uint16 width, uint16 height); 150 | /* 输出控制台的相关信息(仅作调试用) */ 151 | int showConsoleInfo(); 152 | 153 | /* 获取控制台的键输入 */ 154 | uint16 jkGetKey(void); 155 | /* 判断控制台是否有键按下 */ 156 | int jkHasKey(void); 157 | 158 | #ifdef __cplusplus 159 | } 160 | #endif 161 | 162 | #endif // CC_H_INCLUDED 163 | -------------------------------------------------------------------------------- /src/scm.h: -------------------------------------------------------------------------------- 1 | #ifndef SCM_H 2 | #define SCM_H 3 | 4 | #define NDEBUG 5 | 6 | #include 7 | #include 8 | #include 9 | 10 | enum { 11 | scm_integer_type = 1, 12 | scm_float_type = 2, 13 | 14 | /* bool types */ 15 | scm_true_type, 16 | scm_false_type, 17 | 18 | scm_char_type, 19 | scm_string_type, 20 | 21 | scm_symbol_type, 22 | 23 | scm_pair_type, 24 | scm_null_type, 25 | 26 | scm_vector_type, 27 | 28 | scm_primitive_type, 29 | scm_compound_type, 30 | 31 | /* port types */ 32 | scm_input_port_type, 33 | scm_output_port_type, 34 | 35 | scm_namespace_type, 36 | scm_void_type 37 | }; 38 | 39 | typedef short scm_type; 40 | 41 | typedef struct { 42 | /* 以一个类型标识的字段开始的都是Scheme对象 */ 43 | scm_type type; 44 | } scm_object; 45 | 46 | typedef struct { 47 | scm_object o; 48 | long int_val; 49 | } scm_integer; 50 | 51 | typedef struct { 52 | scm_object o; 53 | double float_val; 54 | } scm_float; 55 | 56 | typedef struct { 57 | scm_object o; 58 | char char_val; 59 | } scm_char; 60 | 61 | typedef struct { 62 | scm_object o; 63 | int len; 64 | char *byte_str_val; 65 | } scm_string; 66 | 67 | typedef struct { 68 | scm_object o; 69 | const char *s; 70 | } scm_symbol; 71 | 72 | typedef struct { 73 | scm_object o; 74 | short flags; 75 | scm_object *car; 76 | scm_object *cdr; 77 | } scm_pair; 78 | 79 | typedef struct { 80 | scm_object o; 81 | int len; 82 | scm_object **elems; 83 | } scm_vector; 84 | 85 | /* Scheme基本过程C函数类型 */ 86 | typedef scm_object* (* scm_prim)(int argc, scm_object *argv[]); 87 | 88 | typedef struct { 89 | scm_object o; 90 | const char *name; 91 | scm_prim prim; 92 | int min_arity; 93 | int max_arity; 94 | } scm_primitive_proc; 95 | 96 | struct scm_env; 97 | typedef struct scm_env scm_env; 98 | 99 | typedef struct { 100 | scm_object o; 101 | const char *name; 102 | scm_env *env; // for closure 103 | scm_object *body; 104 | scm_object **params; 105 | int params_len; 106 | int min_arity; 107 | int max_arity; 108 | } scm_compound_proc; 109 | 110 | #define SAME_PTR(a, b) ((a) == (b)) 111 | #define NOT_SAME_PTR(a, b) ((a) != (b)) 112 | 113 | #define SAME_OBJ(a, b) SAME_PTR(a, b) 114 | #define NOT_SAME_OBJ(a, b) NOT_SAME_PTR(a, b) 115 | 116 | /* param o: scheme object pointer */ 117 | #define SCM_TYPE(o) (((scm_object *)(o))->type) 118 | 119 | /* param a/b: as scheme type */ 120 | #define SCM_SAME_TYPE(a, b) ((scm_type)(a) == (scm_type)(b)) 121 | 122 | #define SCM_INTEGERP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_integer_type) 123 | #define SCM_FLOATP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_float_type) 124 | #define SCM_NUMBERP(o) (SCM_INTEGERP(o) || SCM_FLOATP(o)) 125 | 126 | #define SCM_FALSEP(o) SAME_OBJ(o, scm_false) 127 | #define SCM_TRUEP(o) (!SCM_FALSEP(o)) 128 | #define SCM_BOOLP(o) (SAME_OBJ(o, scm_true) || SAME_OBJ(o, scm_false)) 129 | 130 | #define SCM_CHARP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_char_type) 131 | #define SCM_STRINGP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_string_type) 132 | #define SCM_SYMBOLP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_symbol_type) 133 | 134 | #define SCM_PAIRP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_pair_type) 135 | #define SCM_LISTP(o) scm_is_list(o) 136 | #define SCM_NULLP(o) SAME_OBJ(o, scm_null) 137 | #define SCM_VOIDP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_void_type) 138 | 139 | #define SCM_VECTORP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_vector_type) 140 | 141 | #define SCM_PRIMPROCP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_primitive_type) 142 | #define SCM_COMPROCP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_compound_type) 143 | #define SCM_PROCEDUREP(o) (SCM_PRIMPROCP(o) || SCM_COMPROCP(o)) 144 | #define SCM_NAMESPACEP(o) SCM_SAME_TYPE(SCM_TYPE(o), scm_namespace_type) 145 | 146 | /* accessor macros */ 147 | #define SCM_INT_VAL(o) (((scm_integer *)(o))->int_val) 148 | #define SCM_FLOAT_VAL(o) (((scm_float *)(o))->float_val) 149 | #define SCM_CHAR_VAL(o) (((scm_char *)(o))->char_val) 150 | #define SCM_CHAR_STR_VAL(o) (((scm_string *)(o))->byte_str_val) 151 | #define SCM_SYMBOL_STR_VAL(o) (((scm_symbol *)(o))->s) 152 | #define SCM_STR_LEN(o) (((scm_string *)(o))->len) 153 | 154 | #define SCM_VECTOR_ELEMS(o) (((scm_vector *)(o))->elems) 155 | #define SCM_VECTOR_LEN(o) (((scm_vector *)(o))->len) 156 | 157 | #define SCM_CAR(o) (((scm_pair *)(o))->car) 158 | #define SCM_CDR(o) (((scm_pair *)(o))->cdr) 159 | 160 | #define SCM_PAIR_FLAGS(o) (((scm_pair *)o)->flags) 161 | #define SCM_PAIR_FLAGS_INIT 0 162 | /* proper list flags，加快判断速度 */ 163 | #define SCM_PAIR_IS_LIST 1 164 | #define SCM_PAIR_IS_NON_LIST 2 165 | 166 | 167 | /* memory management macros */ 168 | /* Allocation */ 169 | #define scm_malloc_object(size) ((scm_object *)malloc(size)) 170 | 171 | #endif //SCM_H 172 | -------------------------------------------------------------------------------- /src/vector.c: -------------------------------------------------------------------------------- 1 | #include "vector.h" 2 | #include "number.h" 3 | #include "bool.h" 4 | #include "list.h" 5 | #include "env.h" 6 | #include "error.h" 7 | 8 | static scm_object* vector_p_prim(int, scm_object *[]); 9 | static scm_object* make_vector_prim(int, scm_object *[]); 10 | static scm_object* vector_prim(int, scm_object *[]); 11 | static scm_object* vector_set_prim(int, scm_object *[]); 12 | static scm_object* vector_ref_prim(int, scm_object *[]); 13 | static scm_object* vector_length_prim(int, scm_object *[]); 14 | static scm_object* vector_to_list_prim(int, scm_object *[]); 15 | static scm_object* list_to_vector_prim(int, scm_object *[]); 16 | static scm_object* vector_fill_prim(int, scm_object *[]); 17 | 18 | void scm_init_vector(scm_env *env) 19 | { 20 | scm_add_prim(env, "vector?", vector_p_prim, 1, 1); 21 | scm_add_prim(env, "make-vector", make_vector_prim, 1, 2); 22 | scm_add_prim(env, "vector", vector_prim, 0, -1); 23 | scm_add_prim(env, "vector-set!", vector_set_prim, 3, 3); 24 | scm_add_prim(env, "vector-ref", vector_ref_prim, 2, 2); 25 | scm_add_prim(env, "vector-length", vector_length_prim, 1, 1); 26 | scm_add_prim(env, "vector->list", vector_to_list_prim, 1, 1); 27 | scm_add_prim(env, "list->vector", list_to_vector_prim, 1, 1); 28 | scm_add_prim(env, "vector-fill!", vector_fill_prim, 2, 2); 29 | } 30 | 31 | scm_object* scm_make_vector(scm_object *elems[], int len) 32 | { 33 | scm_object *vec = scm_malloc_object(sizeof(scm_vector)); 34 | 35 | vec->type = scm_vector_type; 36 | SCM_VECTOR_ELEMS(vec) = elems; 37 | SCM_VECTOR_LEN(vec) = len; 38 | 39 | return vec; 40 | } 41 | 42 | scm_object* scm_list_to_vector(scm_object *list, int len) 43 | { 44 | scm_object **elems = malloc(sizeof(scm_object *) * len); 45 | int i = 0; 46 | scm_list_for_each(list) { 47 | elems[i++] = SCM_CAR(list); 48 | } 49 | 50 | return scm_make_vector(elems, len); 51 | } 52 | 53 | static scm_object* vector_p_prim(int argc, scm_object *argv[]) 54 | { 55 | return SCM_BOOL(SCM_VECTORP(argv[0])); 56 | } 57 | 58 | static scm_object* make_vector_prim(int argc, scm_object *argv[]) 59 | { 60 | if (!is_exact_nonnegative_integer(argv[0])) 61 | return scm_wrong_contract("make-vector", "exact-nonnegative-integer?", 0, argc, argv); 62 | 63 | scm_object *obj = argc > 1 ? argv[1] : scm_make_integer(0); 64 | 65 | int len = SCM_INT_VAL(argv[0]); 66 | scm_object **elems = malloc(sizeof(scm_object *) * len); 67 | int i; 68 | for (i = 0; i < len; i++) 69 | elems[i] = obj; 70 | 71 | return scm_make_vector(elems, len); 72 | } 73 | 74 | static scm_object* vector_prim(int argc, scm_object *argv[]) 75 | { 76 | return scm_make_vector(argv, argc); 77 | } 78 | 79 | #define VECTOR_INDEX_CHECK(name) \ 80 | if (!SCM_VECTORP(argv[0])) \ 81 | return scm_wrong_contract(name, "vector?", 0, argc, argv); \ 82 | if (!is_exact_nonnegative_integer(argv[1])) \ 83 | return scm_wrong_contract(name, "exact-nonnegative-integer?", 1, argc, argv); \ 84 | \ 85 | int k = SCM_INT_VAL(argv[1]); \ 86 | if (!(0 <= k && k < SCM_VECTOR_LEN(argv[0]))) \ 87 | return scm_out_of_range(name, argv[0], k, k, 0); 88 | 89 | static scm_object* vector_set_prim(int argc, scm_object *argv[]) 90 | { 91 | VECTOR_INDEX_CHECK("vector-set!"); 92 | 93 | SCM_VECTOR_ELEMS(argv[0])[k] = argv[2]; 94 | 95 | return scm_void; 96 | } 97 | 98 | static scm_object* vector_ref_prim(int argc, scm_object *argv[]) 99 | { 100 | VECTOR_INDEX_CHECK("vector-ref"); 101 | 102 | return SCM_VECTOR_ELEMS(argv[0])[k]; 103 | } 104 | 105 | static scm_object* vector_length_prim(int argc, scm_object *argv[]) 106 | { 107 | if (!SCM_VECTORP(argv[0])) 108 | return scm_wrong_contract("vector-length", "vector?", 0, argc, argv); 109 | 110 | return scm_make_integer(SCM_VECTOR_LEN(argv[0])); 111 | } 112 | 113 | static scm_object* vector_to_list_prim(int argc, scm_object *argv[]) 114 | { 115 | if (!SCM_VECTORP(argv[0])) 116 | return scm_wrong_contract("vector->list", "vector?", 0, argc, argv); 117 | 118 | return scm_build_list(SCM_VECTOR_LEN(argv[0]), SCM_VECTOR_ELEMS(argv[0])); 119 | } 120 | 121 | static scm_object* list_to_vector_prim(int argc, scm_object *argv[]) 122 | { 123 | if (!SCM_LISTP(argv[0])) 124 | return scm_wrong_contract("list->vector", "list?", 0, argc, argv); 125 | 126 | return scm_list_to_vector(argv[0], scm_list_length(argv[0])); 127 | } 128 | 129 | static scm_object* vector_fill_prim(int argc, scm_object *argv[]) 130 | { 131 | if (!SCM_VECTORP(argv[0])) 132 | return scm_wrong_contract("vector-fill", "vector?", 0, argc, argv); 133 | 134 | scm_object **elems = SCM_VECTOR_ELEMS(argv[0]); 135 | int len = SCM_VECTOR_LEN(argv[0]); 136 | scm_object* obj = argv[1]; 137 | 138 | for (len--; len >= 0; len--) 139 | elems[len] = obj; 140 | 141 | return scm_void; 142 | } -------------------------------------------------------------------------------- /src/error.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "error.h" 4 | #include "print.h" 5 | #include "eval.h" 6 | #include 7 | #include "cc/cc.h" 8 | 9 | void scm_print_error(const char *info) 10 | { 11 | int oc = getTextColor(); 12 | setTextColor(LIGHT_RED); 13 | 14 | printf("%s", info); 15 | 16 | setTextColor(oc); 17 | } 18 | 19 | void scm_throw_eval_error() 20 | { 21 | longjmp(eval_error_jmp_buf, 1); 22 | } 23 | 24 | scm_object* scm_wrong_contract(const char *name, const char *expected, int index, int argc, scm_object *argv[]) 25 | { 26 | scm_print_error(name); 27 | scm_print_error(": contract violation;\n"); 28 | scm_print_error(" expected: "); 29 | scm_print_error(expected); 30 | scm_print_error("\n"); 31 | scm_print_error(" given: "); 32 | scm_write(scm_stdout_port, argv[index]); 33 | scm_print_error("\n"); 34 | if (argc > 1) { 35 | scm_print_error(" argument position: "); 36 | char nstr[10] = {0}; 37 | sprintf(nstr, "%d\n", index + 1); 38 | scm_print_error(nstr); 39 | 40 | scm_print_error(" other arguments...:\n"); 41 | int argi; 42 | for (argi = 0; argi < argc; argi++) { 43 | if (argi == index) 44 | continue; 45 | scm_print_error(" "); 46 | scm_write(scm_stdout_port, argv[argi]); 47 | scm_print_error("\n"); 48 | } 49 | } 50 | 51 | scm_throw_eval_error(); 52 | 53 | return NULL; 54 | } 55 | 56 | scm_object* scm_mismatch_arity(scm_object *proc, int is_atleast, int expected_min, int expected_max, int argc, scm_object *argv[]) 57 | { 58 | const char *proc_name; 59 | if (SCM_COMPROCP(proc)) { 60 | proc_name = ((scm_compound_proc *)proc)->name; 61 | } else { 62 | proc_name = ((scm_primitive_proc *)proc)->name; 63 | } 64 | 65 | char expected[30]; 66 | if(expected_max == -1) 67 | sprintf(expected, "%d", expected_min); 68 | else 69 | sprintf(expected, "%d to %d", expected_min, expected_max); 70 | 71 | scm_print_error((char*)proc_name); 72 | scm_print_error(": arity mismatch;\n"); 73 | scm_print_error(" the expected number of arguments does not match the given number\n"); 74 | scm_print_error(" expected: "); 75 | scm_print_error(is_atleast ? "at least " : ""); 76 | scm_print_error(expected); 77 | scm_print_error("\n"); 78 | scm_print_error(" given: "); 79 | char nstr[10] = {0}; 80 | sprintf(nstr, "%d\n", argc); 81 | scm_print_error(nstr); 82 | if (argc > 0) { 83 | scm_print_error(" arguments...:\n"); 84 | int argi; 85 | for (argi = 0; argi < argc; argi++) { 86 | scm_print_error(" "); 87 | scm_write(scm_stdout_port, argv[argi]); 88 | scm_print_error("\n"); 89 | } 90 | } 91 | 92 | scm_throw_eval_error(); 93 | 94 | return NULL; 95 | } 96 | 97 | scm_object* scm_undefined_identifier(scm_symbol *id) 98 | { 99 | scm_print_error((char*)SCM_SYMBOL_STR_VAL(id)); 100 | scm_print_error(": undefined;\n cannot reference undefined identifier\n"); 101 | 102 | scm_throw_eval_error(); 103 | 104 | return NULL; 105 | } 106 | 107 | scm_object* scm_out_of_range(const char *name, scm_object *obj, int start, int end, int isrange) 108 | { 109 | char *type; 110 | size_t len; 111 | 112 | if (SCM_STRINGP(obj)) { 113 | type = "string"; 114 | len = SCM_STR_LEN(obj); 115 | } else if (SCM_VECTORP(obj)) { 116 | type = "vector"; 117 | len = SCM_VECTOR_LEN(obj); 118 | } 119 | 120 | char info[200] = {0}; 121 | sprintf(info, "%s: ", type); 122 | if (len > 0) { 123 | char tmp[100] = {0}; 124 | if (isrange) { 125 | if (!(0 <= start && start <= len)) { 126 | sprintf(tmp, "starting index is out of range\n" 127 | " starting index: %d\n", start); 128 | } else if (!(0 <= end && end <= len)) { 129 | sprintf(tmp, "ending index is out of range\n" 130 | " ending index: %d\n", end); 131 | } else if (start > end) { 132 | sprintf(tmp, "ending index is smaller than starting index\n" 133 | " ending index: %d\n starting index: %d\n", end, start); 134 | } 135 | } else { 136 | sprintf(tmp, "index is out of range\n" 137 | " index: %d\n", start); 138 | } 139 | strcat(info, tmp); 140 | 141 | sprintf(tmp, " valid range: [%d, %d]\n %s: ", 142 | 0, (int)(isrange ? len : len - 1), type); 143 | strcat(info ,tmp); 144 | scm_print_error(info); 145 | scm_write(scm_stdout_port, obj); 146 | scm_print_error("\n"); 147 | } else { 148 | sprintf(info, "%s: index is out of range for empty %s\n" 149 | " index: %d\n", name, type, start); 150 | scm_print_error(info); 151 | } 152 | 153 | scm_throw_eval_error(); 154 | 155 | return NULL; 156 | } 157 | -------------------------------------------------------------------------------- /src/port.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "port.h" 3 | #include "bool.h" 4 | 5 | void scm_init_port(scm_env *env) 6 | { 7 | scm_stdin_port = scm_make_stdin_port(); 8 | scm_stdout_port = scm_make_stdout_port(); 9 | } 10 | 11 | int scm_getc(scm_object* port) 12 | { 13 | return INPUT_PORT_GETC_FUNC(port)((scm_input_port *)port); 14 | } 15 | 16 | int scm_ungetc(int ch, scm_object* port) 17 | { 18 | return INPUT_PORT_UNGETC_FUNC(port)((scm_input_port *)port, ch); 19 | } 20 | 21 | int scm_putc(scm_object* port, int c) 22 | { 23 | return OUTPUT_PORT_PUTC_FUNC(port)((scm_output_port *)port, c); 24 | } 25 | 26 | int scm_write_cstr(scm_object* port, const char *s) 27 | { 28 | return OUTPUT_PORT_WRITE_CSTR_FUNC(port)((scm_output_port *)port, s); 29 | } 30 | 31 | scm_object* scm_close_output_port(scm_object *port) 32 | { 33 | fclose(FILE_OUTPUT_PORT_FILE(port)); 34 | return scm_void; 35 | } 36 | 37 | scm_object* scm_close_input_port(scm_object *port) 38 | { 39 | fclose(FILE_INPUT_PORT_FILE(port)); 40 | return scm_void; 41 | } 42 | 43 | /* std out/in */ 44 | 45 | scm_object* scm_make_stdout_port() 46 | { 47 | return scm_make_file_output_port(stdout); 48 | } 49 | 50 | scm_object* scm_make_stdin_port() 51 | { 52 | return scm_make_file_input_port(stdin); 53 | } 54 | 55 | /* file */ 56 | static int file_getc(scm_input_port *); 57 | static int file_ungetc(scm_input_port *, int); 58 | static int file_putc(scm_output_port *, int); 59 | static int file_write_cstr(scm_output_port *, const char *); 60 | /* char-string */ 61 | static int char_string_getc(scm_input_port *); 62 | static int char_string_ungetc(scm_input_port *, int); 63 | static int char_string_putc(scm_output_port *, int); 64 | static int char_string_write_cstr(scm_output_port *, const char *); 65 | 66 | scm_object* scm_make_file_output_port(FILE *f) 67 | { 68 | scm_object *port = scm_malloc_object(sizeof(scm_file_output_port)); 69 | port->type = scm_output_port_type; 70 | FILE_OUTPUT_PORT_FILE(port) = f; 71 | OUTPUT_PORT_PUTC_FUNC(port) = file_putc; 72 | OUTPUT_PORT_WRITE_CSTR_FUNC(port) = file_write_cstr; 73 | return port; 74 | } 75 | 76 | scm_object* scm_make_file_input_port(FILE *f) 77 | { 78 | scm_object *port = scm_malloc_object(sizeof(scm_file_input_port)); 79 | port->type = scm_input_port_type; 80 | FILE_INPUT_PORT_FILE(port) = f; 81 | INPUT_PORT_GETC_FUNC(port) = file_getc; 82 | INPUT_PORT_UNGETC_FUNC(port) = file_ungetc; 83 | return port; 84 | } 85 | 86 | scm_object* scm_make_char_string_output_port(int size) 87 | { 88 | scm_object *port = scm_malloc_object(sizeof(scm_char_string_output_port)); 89 | port->type = scm_output_port_type; 90 | 91 | size = size > -1 ? size + 1 : 10; 92 | ((scm_char_string_output_port *)port)->size = size; 93 | CHAR_STRING_OUTPUT_PORT_BUF(port) = malloc(size * sizeof(char)); 94 | ((scm_char_string_output_port *)port)->cnt = 0; 95 | 96 | OUTPUT_PORT_PUTC_FUNC(port) = char_string_putc; 97 | OUTPUT_PORT_WRITE_CSTR_FUNC(port) = char_string_write_cstr; 98 | return port; 99 | } 100 | 101 | scm_object* scm_make_char_string_input_port(const char *str, int size) 102 | { 103 | scm_object *port = scm_malloc_object(sizeof(scm_char_string_input_port)); 104 | port->type = scm_input_port_type; 105 | 106 | size = size > -1 ? size + 1: 100; 107 | CHAR_STRING_INPUT_PORT_BUF(port) = calloc(size, sizeof(char)); 108 | char *buf = CHAR_STRING_INPUT_PORT_BUF(port); 109 | const char *sc = str; 110 | while (*sc) { 111 | *buf++ = *sc++; 112 | if (sc - str >= size) { 113 | size += 10; 114 | CHAR_STRING_INPUT_PORT_BUF(port) = realloc(CHAR_STRING_INPUT_PORT_BUF(port), size); 115 | assert(CHAR_STRING_INPUT_PORT_BUF(port)); 116 | memset(buf, 0, 10); 117 | } 118 | } 119 | 120 | ((scm_char_string_input_port *)port)->size = size; 121 | ((scm_char_string_input_port *)port)->cnt = 0; 122 | 123 | INPUT_PORT_GETC_FUNC(port) = char_string_getc; 124 | INPUT_PORT_UNGETC_FUNC(port) = char_string_ungetc; 125 | return port; 126 | } 127 | 128 | static int file_getc(scm_input_port *port) 129 | { 130 | return fgetc(FILE_INPUT_PORT_FILE(port)); 131 | } 132 | 133 | static int file_ungetc(scm_input_port *port, int c) 134 | { 135 | return ungetc(c, FILE_INPUT_PORT_FILE(port)); 136 | } 137 | 138 | static int file_putc(scm_output_port *port, int c) 139 | { 140 | return fputc(c, FILE_OUTPUT_PORT_FILE(port)); 141 | } 142 | 143 | static int file_write_cstr(scm_output_port *port, const char *s) 144 | { 145 | return fprintf(FILE_OUTPUT_PORT_FILE(port), "%s", s); 146 | } 147 | 148 | static int char_string_getc(scm_input_port *port) 149 | { 150 | int c = CHAR_STRING_INPUT_PORT_BUF(port)[((scm_char_string_input_port *)port)->cnt]; 151 | if (c) { 152 | ((scm_char_string_input_port *)port)->cnt++; 153 | return c; 154 | } else 155 | return EOF; 156 | } 157 | 158 | static int char_string_ungetc(scm_input_port *port, int c) 159 | { 160 | if (c == EOF) 161 | return EOF; 162 | ((scm_char_string_input_port *)port)->cnt--; 163 | CHAR_STRING_INPUT_PORT_BUF(port)[((scm_char_string_input_port *)port)->cnt] = c; 164 | return c; 165 | } 166 | 167 | static int char_string_putc(scm_output_port *port, int c) 168 | { 169 | char *buf = CHAR_STRING_OUTPUT_PORT_BUF(port); 170 | int size = ((scm_char_string_output_port *)port)->size; 171 | int cnt = ((scm_char_string_output_port *)port)->cnt; 172 | 173 | if (cnt >= size) { 174 | size += 10; 175 | CHAR_STRING_OUTPUT_PORT_BUF(port) = realloc(buf, size); 176 | memset(buf + cnt, 0, sizeof(char)); 177 | } 178 | 179 | return buf[cnt++] = c; 180 | } 181 | 182 | static int char_string_write_cstr(scm_output_port *port, const char *s) 183 | { 184 | char *buf = CHAR_STRING_OUTPUT_PORT_BUF(port) + ((scm_char_string_output_port *)port)->cnt; 185 | 186 | while (*s) { 187 | *buf++ = *s++; 188 | } 189 | 190 | return 0; 191 | } 192 | -------------------------------------------------------------------------------- /src/system.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "system.h" 4 | #include "bool.h" 5 | #include "number.h" 6 | #include "str.h" 7 | #include "symbol.h" 8 | #include "port.h" 9 | #include "read.h" 10 | #include "print.h" 11 | #include "env.h" 12 | #include "eval.h" 13 | #include "error.h" 14 | 15 | 16 | static const char *help_info = "\n" 17 | " (?) print help\n" 18 | " (exit [code]) exit REPL\n" 19 | " (set 'prompt ) set prompt\n"; 20 | 21 | static scm_object* load_prim(int, scm_object *[]); 22 | static scm_object* time_prim(int, scm_object *[]); 23 | static scm_object* clock_prim(int, scm_object *[]); 24 | static scm_object* rand_prim(int, scm_object *[]); 25 | static scm_object* help_prim(int, scm_object *[]); 26 | static scm_object* exit_prim(int, scm_object *[]); 27 | static scm_object* set_prim(int, scm_object *[]); 28 | 29 | enum { 30 | ENCODING_UNKNOWN, 31 | ENCODING_UTF_8, 32 | ENCODING_UTF_16BE, 33 | ENCODING_UTF_16LE, 34 | ENCODING_UTF_32BE, 35 | ENCODING_UTF_32LE, 36 | ENCODING_UTF_7, 37 | ENCODING_GB_18030 38 | }; 39 | 40 | static int get_skip_encoding_marks(scm_object *port); 41 | 42 | void scm_init_system(scm_env *env) 43 | { 44 | srand((unsigned)time(NULL)); 45 | 46 | scm_add_prim(env, "load", load_prim, 1, 1); 47 | 48 | scm_add_prim(env, "time", time_prim, 0, 0); 49 | scm_add_prim(env, "clock", clock_prim, 0, 0); 50 | scm_add_prim(env, "rand", rand_prim, 0, 0); 51 | 52 | scm_add_prim(env, "?", help_prim, 0, 0); 53 | scm_add_prim(env, "exit", exit_prim, 0, 1); 54 | scm_add_prim(env, "set", set_prim, 2, -1); 55 | } 56 | 57 | 58 | int scm_load_file(const char* filename) 59 | { 60 | FILE *file = fopen(filename, "r"); 61 | if (file == NULL) { 62 | scm_print_error("open-input-file: cannot open input file\n path: "); 63 | scm_print_error(filename); 64 | scm_print_error("\n"); 65 | return -1; 66 | } 67 | 68 | scm_object *port = scm_make_file_input_port(file); 69 | scm_object *exp, *val; 70 | int ch; 71 | 72 | get_skip_encoding_marks(port); 73 | 74 | while (!scm_eofp(ch = scm_getc(port))) { 75 | scm_ungetc(ch, port); 76 | val = NULL; 77 | exp = scm_read(port); 78 | if (!exp) // 如果遇到错误，中止执行 79 | break; 80 | val = scm_eval(exp); 81 | if (!val) // 同上 82 | break; 83 | } 84 | 85 | if (val && !SCM_VOIDP(val)) { 86 | scm_write(scm_stdout_port, val); // 默认用write 87 | printf("\n"); 88 | } 89 | 90 | scm_close_input_port(port); 91 | 92 | return 0; 93 | } 94 | 95 | static scm_object* load_prim(int argc, scm_object *argv[]) 96 | { 97 | char* filename = SCM_CHAR_STR_VAL(argv[0]); 98 | int retcode = scm_load_file(filename); 99 | if (retcode != 0) { 100 | scm_throw_eval_error(); 101 | } 102 | 103 | return scm_void; 104 | } 105 | 106 | static scm_object* time_prim(int argc, scm_object *argv[]) 107 | { 108 | return scm_make_integer(time(NULL)); 109 | } 110 | 111 | static scm_object* clock_prim(int argc, scm_object *argv[]) 112 | { 113 | return scm_make_integer(clock()); 114 | } 115 | 116 | static scm_object* rand_prim(int argc, scm_object *argv[]) 117 | { 118 | return scm_make_integer(rand()); 119 | } 120 | 121 | static scm_object* help_prim(int argc, scm_object *argv[]) 122 | { 123 | printf("%s\n", help_info); 124 | return scm_void; 125 | } 126 | 127 | static scm_object* exit_prim(int argc, scm_object *argv[]) 128 | { 129 | int code = 0; 130 | if (argc > 0) { 131 | if (!SCM_INTEGERP(argv[0])) 132 | return scm_wrong_contract("exit", "integer?", 0, argc, argv); 133 | code = SCM_INT_VAL(argv[0]); 134 | } 135 | exit(code); 136 | return scm_void; 137 | } 138 | 139 | static scm_object* set_prim(int argc, scm_object *argv[]) 140 | { 141 | if (!SCM_SYMBOLP(argv[0])) 142 | return scm_wrong_contract("set", "symbol?", 0, argc, argv); 143 | 144 | const char *name = SCM_SYMBOL_STR_VAL(argv[0]); 145 | 146 | int ok = 0; 147 | char *fail_cause = NULL; 148 | 149 | if (strcmp(name, "prompt") == 0) { 150 | if (SCM_STRINGP(argv[1])) { 151 | scm_g_repl_prompt = SCM_CHAR_STR_VAL(argv[1]); 152 | ok = 1; 153 | } else 154 | fail_cause = "argument is not string."; 155 | } else { 156 | fail_cause = "error option."; 157 | } 158 | 159 | if (!ok) 160 | printf("set failed, %s\n", fail_cause); 161 | 162 | return scm_void; 163 | } 164 | 165 | static int get_skip_encoding_marks(scm_object *port) 166 | { 167 | int bytes[4] = {0x100}; 168 | int read_bytes = 0; 169 | int c; 170 | while (read_bytes < 4 && !scm_eofp(c = scm_getc(port))) 171 | bytes[read_bytes++] = c; 172 | 173 | int encoding = ENCODING_UNKNOWN; 174 | int unread_bytes = read_bytes; 175 | /* 处理可能的常见的BOM */ 176 | if ((bytes[0] == 0x00) && (bytes[1] == 0x00) && (bytes[2] == 0xFE) && (bytes[3] == 0xFF)) { 177 | encoding = ENCODING_UTF_32BE; 178 | unread_bytes = read_bytes - 4; 179 | } else if ((bytes[0] == 0xFF) && (bytes[1] == 0xFE) && (bytes[2] == 0x00) && (bytes[3] == 0x00)) { 180 | encoding = ENCODING_UTF_32LE; 181 | unread_bytes = read_bytes - 4; 182 | } else if ((bytes[0] == 0x2B) && (bytes[1] == 0x2F) && (bytes[2] == 0x76) 183 | && (bytes[3] == 0x38 || bytes[3] == 0x39 || bytes[3] == 0x2B || bytes[3] == 0x2F)) { 184 | encoding = ENCODING_UTF_7; 185 | unread_bytes = read_bytes - 4; 186 | } else if ((bytes[0] == 0x84) && (bytes[1] == 0x31) && (bytes[2] == 0x95) && (bytes[3] == 0x33)) { 187 | encoding = ENCODING_GB_18030; 188 | unread_bytes = read_bytes - 4; 189 | } else if ((bytes[0] == 0xEF) && (bytes[1] == 0xBB) && (bytes[2] == 0xBF)) { 190 | encoding = ENCODING_UTF_8; 191 | unread_bytes = read_bytes - 3; 192 | } else if ((bytes[0] == 0xFE) && (bytes[1] == 0xFF)) { 193 | encoding = ENCODING_UTF_16BE; 194 | unread_bytes = read_bytes - 2; 195 | } else if ((bytes[0] == 0xFF) && (bytes[1] == 0xFE)) { 196 | encoding = ENCODING_UTF_16LE; 197 | unread_bytes = read_bytes - 2; 198 | } // TODO: more 199 | 200 | // un-read, stack pop 201 | int i; 202 | for (int i = 0; i < unread_bytes; i++) 203 | scm_ungetc(bytes[read_bytes - 1 - i], port); 204 | 205 | return encoding; 206 | } 207 | -------------------------------------------------------------------------------- /src/char.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "char.h" 3 | #include "bool.h" 4 | #include "number.h" 5 | #include "env.h" 6 | #include "error.h" 7 | 8 | static scm_object* char_p_prim(int, scm_object *[]); 9 | static scm_object* eq_p_prim(int, scm_object *[]); 10 | static scm_object* lt_p_prim(int, scm_object *[]); 11 | static scm_object* gt_p_prim(int, scm_object *[]); 12 | static scm_object* lteq_p_prim(int, scm_object *[]); 13 | static scm_object* gteq_p_prim(int, scm_object *[]); 14 | static scm_object* ci_eq_p_prim(int, scm_object *[]); 15 | static scm_object* ci_lt_p_prim(int, scm_object *[]); 16 | static scm_object* ci_gt_p_prim(int, scm_object *[]); 17 | static scm_object* ci_lteq_p_prim(int, scm_object *[]); 18 | static scm_object* ci_gteq_p_prim(int, scm_object *[]); 19 | static scm_object* alphabetic_p_prim(int, scm_object *[]); 20 | static scm_object* numeric_p_prim(int, scm_object *[]); 21 | static scm_object* whitespace_p_prim(int, scm_object *[]); 22 | static scm_object* upper_case_p_prim(int, scm_object *[]); 23 | static scm_object* lower_case_p_prim(int, scm_object *[]); 24 | static scm_object* char_to_integer_prim(int, scm_object *[]); 25 | static scm_object* integer_to_char_prim(int, scm_object *[]); 26 | static scm_object* upcase_prim(int, scm_object *[]); 27 | static scm_object* downcase_prim(int, scm_object *[]); 28 | 29 | void scm_init_char(scm_env *env) 30 | { 31 | scm_add_prim(env, "char?", char_p_prim, 1, 1); 32 | 33 | scm_add_prim(env, "char=?", eq_p_prim, 2, -1); 34 | scm_add_prim(env, "char?", gt_p_prim, 2, -1); 36 | scm_add_prim(env, "char<=?", lteq_p_prim, 2, -1); 37 | scm_add_prim(env, "char>=?", gteq_p_prim, 2, -1); 38 | scm_add_prim(env, "char-ci=?", ci_eq_p_prim, 2, -1); 39 | scm_add_prim(env, "char-ci?", ci_gt_p_prim, 2, -1); 41 | scm_add_prim(env, "char-ci<=?", ci_lteq_p_prim, 2, -1); 42 | scm_add_prim(env, "char-ci>=?", ci_gteq_p_prim, 2, -1); 43 | 44 | scm_add_prim(env, "char-alphabetic?", alphabetic_p_prim, 1, 1); 45 | scm_add_prim(env, "char-numeric?", numeric_p_prim, 1, 1); 46 | scm_add_prim(env, "char-whitespace?", whitespace_p_prim, 1, 1); 47 | scm_add_prim(env, "char-upper-case?", upper_case_p_prim, 1, 1); 48 | scm_add_prim(env, "char-lower-case?", lower_case_p_prim, 1, 1); 49 | 50 | scm_add_prim(env, "char->integer", char_to_integer_prim, 1, 1); 51 | scm_add_prim(env, "integer->char", integer_to_char_prim, 1, 1); 52 | 53 | scm_add_prim(env, "char-upcase", upcase_prim, 1, 1); 54 | scm_add_prim(env, "char-downcase", downcase_prim, 1, 1); 55 | } 56 | 57 | scm_object* scm_make_char(char val) 58 | { 59 | scm_object *o = scm_malloc_object(sizeof(scm_char)); 60 | o->type = scm_char_type; 61 | SCM_CHAR_VAL(o) = val; 62 | return o; 63 | } 64 | 65 | static scm_object* char_p_prim(int argc, scm_object *argv[]) 66 | { 67 | return SCM_BOOL(SCM_CHARP(argv[0])); 68 | } 69 | 70 | static scm_object* char_to_integer_prim(int argc, scm_object *argv[]) 71 | { 72 | if (!SCM_CHARP(argv[0])) 73 | return scm_wrong_contract("char->integer", "char?", 0, argc, argv); 74 | 75 | return scm_make_integer(SCM_CHAR_VAL(argv[0])); 76 | } 77 | 78 | static scm_object* integer_to_char_prim(int argc, scm_object *argv[]) 79 | { 80 | if (!SCM_INTEGERP(argv[0])) 81 | return scm_wrong_contract("integer->char", "integer?", 0, argc, argv); 82 | 83 | return scm_make_char(SCM_INT_VAL(argv[0])); 84 | } 85 | 86 | static scm_object* upcase_prim(int argc, scm_object *argv[]) 87 | { 88 | if (!SCM_CHARP(argv[0])) 89 | return scm_make_char(toupper(SCM_CHAR_VAL(argv[0]))); 90 | 91 | return scm_wrong_contract("char-upcase", "char?", 0, argc, argv); 92 | } 93 | 94 | static scm_object* downcase_prim(int argc, scm_object *argv[]) 95 | { 96 | if (!SCM_CHARP(argv[0])) 97 | return scm_wrong_contract("char-downcase", "char?", 0, argc, argv); 98 | 99 | return scm_make_char(tolower(SCM_CHAR_VAL(argv[0]))); 100 | } 101 | 102 | 103 | #define GEN_CHAR_COMP_PRIM(fname, scomp, ccomp) \ 104 | static scm_object* fname##_p_prim(int argc, scm_object *argv[]) \ 105 | { \ 106 | int i; \ 107 | for (i = 0; i < argc - 1; i++) { \ 108 | if (SCM_CHARP(argv[i])) { \ 109 | if (SCM_CHARP(argv[i + 1])) { \ 110 | if (!(SCM_CHAR_VAL(argv[i]) ccomp SCM_CHAR_VAL(argv[i + 1]))) \ 111 | return scm_false; \ 112 | } else \ 113 | return scm_wrong_contract("char"#scomp"?", "char?", i + 1, argc, argv); \ 114 | } else \ 115 | return scm_wrong_contract("char"#scomp"?", "char?", i, argc, argv); \ 116 | } \ 117 | return scm_true; \ 118 | } 119 | 120 | #define GEN_CHAR_CI_COMP_PRIM(fname, scomp, ccomp) \ 121 | static scm_object* ci_##fname##_p_prim(int argc, scm_object *argv[]) \ 122 | { \ 123 | int i; \ 124 | for (i = 0; i < argc - 1; i++) { \ 125 | if (SCM_CHARP(argv[i])) { \ 126 | if (SCM_CHARP(argv[i + 1])) { \ 127 | if (!(toupper(SCM_CHAR_VAL(argv[i])) ccomp toupper(SCM_CHAR_VAL(argv[i + 1])))) \ 128 | return scm_false; \ 129 | } else \ 130 | return scm_wrong_contract("char-ci"#scomp"?", "char?", i + 1, argc, argv); \ 131 | } else \ 132 | return scm_wrong_contract("char-ci"#scomp"?", "char?", i, argc, argv); \ 133 | } \ 134 | return scm_true; \ 135 | } 136 | 137 | GEN_CHAR_COMP_PRIM(eq, =, ==); 138 | GEN_CHAR_COMP_PRIM(lt, <, <); 139 | GEN_CHAR_COMP_PRIM(gt, >, >); 140 | GEN_CHAR_COMP_PRIM(lteq, <=, <=); 141 | GEN_CHAR_COMP_PRIM(gteq, >=, >=); 142 | GEN_CHAR_CI_COMP_PRIM(eq, =, ==); 143 | GEN_CHAR_CI_COMP_PRIM(lt, <, <); 144 | GEN_CHAR_CI_COMP_PRIM(gt, >, >); 145 | GEN_CHAR_CI_COMP_PRIM(lteq, <=, <=); 146 | GEN_CHAR_CI_COMP_PRIM(gteq, >=, >=); 147 | 148 | 149 | #define GEN_CHAR_TYPE_P_PRIM(tname, cfname) \ 150 | static scm_object* tname##_p_prim(int argc, scm_object *argv[]) \ 151 | { \ 152 | if (!SCM_CHARP(argv[0])) \ 153 | return scm_wrong_contract("char-"#tname"?", "char?", 0, argc, argv); \ 154 | return SCM_BOOL(cfname(SCM_CHAR_VAL(argv[0]))); \ 155 | } 156 | 157 | GEN_CHAR_TYPE_P_PRIM(alphabetic, isalpha); 158 | GEN_CHAR_TYPE_P_PRIM(numeric, isdigit); 159 | GEN_CHAR_TYPE_P_PRIM(whitespace, isspace); 160 | GEN_CHAR_TYPE_P_PRIM(upper_case, isupper); 161 | GEN_CHAR_TYPE_P_PRIM(lower_case, islower); 162 | -------------------------------------------------------------------------------- /src/lib/libpcc32.c: -------------------------------------------------------------------------------- 1 | #include "libpcc32.h" 2 | #include "../cc/cc.h" 3 | #include "../bool.h" 4 | #include "../number.h" 5 | #include "../symbol.h" 6 | #include "../env.h" 7 | 8 | 9 | #define S_CHAR_PTR_VAL SCM_CHAR_STR_VAL 10 | #define S_INT_VAL SCM_INT_VAL 11 | #define S_UINT32_VAL SCM_INT_VAL 12 | #define S_UINT16_VAL SCM_INT_VAL 13 | #define S_UINT8_VAL SCM_INT_VAL 14 | 15 | #define RETURN_VOID() return scm_void; 16 | #define RETURN_INT(v) return scm_make_integer(v); 17 | #define RETURN_UINT16(v) return scm_make_integer(v); 18 | #define RETURN_UINT8(v) return scm_make_integer(v); 19 | #define RETURN_BOOL(v) return SCM_BOOL(v); 20 | 21 | #define DEFINE_PRIM(name) \ 22 | static scm_object* name##_prim(int argc, scm_object *argv[]) 23 | 24 | #define ADD_PRIM(name, mina, maxa) \ 25 | scm_add_prim(env, "pcc-"#name, name##_prim, mina, maxa); 26 | #define ADD_NULLARY_PRIM(name) ADD_PRIM(name, 0, 0) 27 | #define ADD_UNARY_PRIM(name) ADD_PRIM(name, 1, 1) 28 | #define ADD_BINARY_PRIM(name) ADD_PRIM(name, 2, 2) 29 | #define ADD_TERNARY_PRIM(name) ADD_PRIM(name, 3, 3) 30 | #define ADD_INT_CONSTANT(name) \ 31 | scm_env_add_binding(env, scm_get_intern_symbol("pcc-"#name), scm_make_integer(name)) 32 | 33 | 34 | /* 函数定义 */ 35 | DEFINE_PRIM(delayMS) 36 | { 37 | delayMS(S_UINT32_VAL(argv[0])); 38 | RETURN_VOID(); 39 | } 40 | 41 | DEFINE_PRIM(clearText) 42 | { 43 | clearText(); 44 | RETURN_VOID(); 45 | } 46 | 47 | DEFINE_PRIM(simpleRing) 48 | { 49 | RETURN_INT(simpleRing(S_UINT16_VAL(argv[0]), S_UINT16_VAL(argv[1]))); 50 | } 51 | 52 | DEFINE_PRIM(setTextColor) 53 | { 54 | RETURN_INT(setTextColor(S_UINT8_VAL(argv[0]))); 55 | } 56 | 57 | DEFINE_PRIM(getTextColor) 58 | { 59 | RETURN_INT(getTextColor()); 60 | } 61 | 62 | DEFINE_PRIM(setBackColor) 63 | { 64 | RETURN_INT(setBackColor(S_UINT8_VAL(argv[0]))); 65 | } 66 | 67 | DEFINE_PRIM(getBackColor) 68 | { 69 | RETURN_INT(getBackColor()); 70 | } 71 | 72 | DEFINE_PRIM(setColors) 73 | { 74 | RETURN_INT(setColors(S_UINT8_VAL(argv[0]), S_UINT8_VAL(argv[1]))); 75 | } 76 | 77 | DEFINE_PRIM(setSwapColors) 78 | { 79 | RETURN_INT(setSwapColors(S_INT_VAL(argv[0]))); 80 | } 81 | 82 | DEFINE_PRIM(setUnderLine) 83 | { 84 | RETURN_INT(setUnderLine(S_INT_VAL(argv[0]))); 85 | } 86 | 87 | DEFINE_PRIM(getLineWidth) 88 | { 89 | RETURN_UINT8(getLineWidth()); 90 | } 91 | 92 | DEFINE_PRIM(getLineNum) 93 | { 94 | RETURN_UINT8(getLineNum()); 95 | } 96 | 97 | DEFINE_PRIM(getCursorX) 98 | { 99 | RETURN_UINT8(getCursorX()); 100 | } 101 | 102 | DEFINE_PRIM(getCursorY) 103 | { 104 | RETURN_UINT8(getCursorY()); 105 | } 106 | 107 | DEFINE_PRIM(gotoTextPos) 108 | { 109 | RETURN_INT(gotoTextPos(S_UINT8_VAL(argv[0]), S_UINT8_VAL(argv[1]))); 110 | } 111 | 112 | DEFINE_PRIM(setCursorVisible) 113 | { 114 | RETURN_INT(setCursorVisible(S_INT_VAL(argv[0]))); 115 | } 116 | 117 | DEFINE_PRIM(setCursorSize) 118 | { 119 | RETURN_INT(setCursorSize(S_UINT8_VAL(argv[0]))); 120 | } 121 | 122 | DEFINE_PRIM(getConsoleTitle) 123 | { 124 | RETURN_INT(getConsoleTitle(S_CHAR_PTR_VAL(argv[0]), S_UINT8_VAL(argv[1]))); 125 | } 126 | 127 | DEFINE_PRIM(setConsoleTitle) 128 | { 129 | RETURN_INT(setConsoleTitle(S_CHAR_PTR_VAL(argv[0]))); 130 | } 131 | 132 | DEFINE_PRIM(fixConsoleSize) 133 | { 134 | RETURN_INT(fixConsoleSize(S_UINT16_VAL(argv[0]), S_UINT16_VAL(argv[1]))); 135 | } 136 | 137 | DEFINE_PRIM(showConsoleInfo) 138 | { 139 | RETURN_INT(showConsoleInfo()); 140 | } 141 | 142 | DEFINE_PRIM(jkGetKey) 143 | { 144 | RETURN_UINT16(jkGetKey()); 145 | } 146 | DEFINE_PRIM(jkHasKey) 147 | { 148 | RETURN_BOOL(jkHasKey()); 149 | } 150 | 151 | void scm_init_libpcc32(scm_env *env) 152 | { 153 | /* 按键定义 */ 154 | ADD_INT_CONSTANT(JK_FUNC_KEY); 155 | ADD_INT_CONSTANT(JK_CTRL_KEY); 156 | 157 | ADD_INT_CONSTANT(JK_ESC); 158 | ADD_INT_CONSTANT(JK_ENTER); 159 | ADD_INT_CONSTANT(JK_SPACE); 160 | ADD_INT_CONSTANT(JK_BKSPACE); 161 | ADD_INT_CONSTANT(JK_TAB); 162 | 163 | ADD_INT_CONSTANT(JK_CTRL_Z); 164 | ADD_INT_CONSTANT(JK_CTRL_X); 165 | ADD_INT_CONSTANT(JK_CTRL_C); 166 | ADD_INT_CONSTANT(JK_CTRL_A); 167 | ADD_INT_CONSTANT(JK_CTRL_S); 168 | ADD_INT_CONSTANT(JK_CTRL_D); 169 | 170 | ADD_INT_CONSTANT(JK_LEFT); 171 | ADD_INT_CONSTANT(JK_RIGHT); 172 | ADD_INT_CONSTANT(JK_UP); 173 | ADD_INT_CONSTANT(JK_DOWN); 174 | ADD_INT_CONSTANT(JK_INSERT); 175 | ADD_INT_CONSTANT(JK_HOME); 176 | ADD_INT_CONSTANT(JK_PGUP); 177 | ADD_INT_CONSTANT(JK_DELETE); 178 | ADD_INT_CONSTANT(JK_END); 179 | ADD_INT_CONSTANT(JK_PGDW); 180 | 181 | ADD_INT_CONSTANT(JK_F1); 182 | ADD_INT_CONSTANT(JK_F2); 183 | ADD_INT_CONSTANT(JK_F3); 184 | ADD_INT_CONSTANT(JK_F4); 185 | ADD_INT_CONSTANT(JK_F5); 186 | ADD_INT_CONSTANT(JK_F6); 187 | ADD_INT_CONSTANT(JK_F7); 188 | ADD_INT_CONSTANT(JK_F8); 189 | ADD_INT_CONSTANT(JK_F9); 190 | ADD_INT_CONSTANT(JK_F10); 191 | ADD_INT_CONSTANT(JK_F11); 192 | ADD_INT_CONSTANT(JK_F12); 193 | 194 | /* 控制台尺寸定义 */ 195 | ADD_INT_CONSTANT(MIN_CONSOLE_WIDTH); 196 | ADD_INT_CONSTANT(MIN_CONSOLE_HEIGHT); 197 | 198 | /* 颜色定义 */ 199 | ADD_INT_CONSTANT(BLACK); 200 | ADD_INT_CONSTANT(BLUE); 201 | ADD_INT_CONSTANT(GREEN); 202 | ADD_INT_CONSTANT(CYAN); 203 | ADD_INT_CONSTANT(RED); 204 | ADD_INT_CONSTANT(MAGENTA); 205 | ADD_INT_CONSTANT(BROWN); 206 | ADD_INT_CONSTANT(LIGHT_GRAY); 207 | ADD_INT_CONSTANT(DARK_GRAY); 208 | ADD_INT_CONSTANT(LIGHT_BLUE); 209 | ADD_INT_CONSTANT(LIGHT_GREEN); 210 | ADD_INT_CONSTANT(LIGHT_CYAN); 211 | ADD_INT_CONSTANT(LIGHT_RED); 212 | ADD_INT_CONSTANT(LIGHT_MAGENTA); 213 | ADD_INT_CONSTANT(YELLOW); 214 | ADD_INT_CONSTANT(WHITE); 215 | 216 | /* 过程定义 */ 217 | ADD_UNARY_PRIM(delayMS); 218 | ADD_NULLARY_PRIM(clearText); 219 | ADD_BINARY_PRIM(simpleRing); 220 | ADD_UNARY_PRIM(setTextColor); 221 | ADD_NULLARY_PRIM(getTextColor); 222 | ADD_UNARY_PRIM(setBackColor); 223 | ADD_NULLARY_PRIM(getBackColor); 224 | ADD_BINARY_PRIM(setColors); 225 | ADD_UNARY_PRIM(setSwapColors); 226 | ADD_UNARY_PRIM(setUnderLine); 227 | ADD_NULLARY_PRIM(getLineWidth); 228 | ADD_NULLARY_PRIM(getLineNum); 229 | ADD_NULLARY_PRIM(getCursorX); 230 | ADD_NULLARY_PRIM(getCursorY); 231 | ADD_BINARY_PRIM(gotoTextPos); 232 | ADD_UNARY_PRIM(setCursorVisible); 233 | ADD_UNARY_PRIM(setCursorSize); 234 | ADD_BINARY_PRIM(getConsoleTitle); 235 | ADD_UNARY_PRIM(setConsoleTitle); 236 | ADD_BINARY_PRIM(fixConsoleSize); 237 | ADD_NULLARY_PRIM(showConsoleInfo); 238 | ADD_NULLARY_PRIM(jkGetKey); 239 | ADD_NULLARY_PRIM(jkHasKey); 240 | } 241 | -------------------------------------------------------------------------------- /src/print.c: -------------------------------------------------------------------------------- 1 | #include "print.h" 2 | #include "list.h" 3 | #include "bool.h" 4 | #include "env.h" 5 | #include "scm.h" 6 | #include "cc/cc.h" 7 | 8 | #define WRITE_TEXT_COLOR LIGHT_BLUE 9 | #define DISPLAY_TEXT_COLOR LIGHT_MAGENTA 10 | 11 | enum { 12 | DISPLAY = 0, 13 | WRITE = 1 14 | }; 15 | 16 | static scm_object* write_prim(int, scm_object *[]); 17 | static scm_object* display_prim(int, scm_object *[]); 18 | static scm_object* newline_prim(int, scm_object *[]); 19 | 20 | static void write_object(scm_object *port, scm_object *, int); 21 | static void write_list(scm_object *port, scm_object *, int); 22 | static void write_vector(scm_object *port, scm_object *, int); 23 | 24 | void scm_init_print(scm_env *env) 25 | { 26 | scm_add_prim(env, "write", write_prim, 1, 2); 27 | scm_add_prim(env, "display", display_prim, 1, 2); 28 | } 29 | 30 | void scm_write(scm_object *port, scm_object *obj) 31 | { 32 | int oc = getTextColor(); 33 | setTextColor(WRITE_TEXT_COLOR); // 仅交互调用时设置颜色 34 | 35 | write_object(port, obj, WRITE); 36 | 37 | setTextColor(oc); 38 | } 39 | 40 | void scm_display(scm_object *port, scm_object *obj) 41 | { 42 | int oc = getTextColor(); 43 | setTextColor(DISPLAY_TEXT_COLOR); 44 | 45 | write_object(port, obj, DISPLAY); 46 | 47 | setTextColor(oc); 48 | } 49 | 50 | static scm_object* write_prim(int argc, scm_object *argv[]) 51 | { 52 | write_object(scm_stdout_port, argv[0], WRITE); 53 | return scm_void; 54 | } 55 | 56 | static scm_object* display_prim(int argc, scm_object *argv[]) 57 | { 58 | write_object(scm_stdout_port, argv[0], DISPLAY); 59 | return scm_void; 60 | } 61 | 62 | static void write_object(scm_object *port, scm_object *obj, int notdisplay) 63 | { 64 | switch (SCM_TYPE(obj)) { 65 | case scm_true_type: 66 | scm_write_cstr(port, "#t"); 67 | break; 68 | case scm_false_type: 69 | scm_write_cstr(port, "#f"); 70 | break; 71 | case scm_integer_type: { 72 | char s[11] = {0}; 73 | sprintf(s, "%ld", SCM_INT_VAL(obj)); 74 | scm_write_cstr(port, s); 75 | break; 76 | } 77 | case scm_float_type: { 78 | char s[17] = {0}; 79 | sprintf(s, "%lf", SCM_FLOAT_VAL(obj)); 80 | scm_write_cstr(port, s); 81 | break; 82 | } 83 | case scm_char_type: 84 | if (notdisplay) { 85 | switch (SCM_CHAR_VAL(obj)) { 86 | case '\n': 87 | scm_write_cstr(port, "#\\newline"); 88 | break; 89 | case ' ': 90 | scm_write_cstr(port, "#\\space"); 91 | break; 92 | default: 93 | scm_write_cstr(port, "#\\"); 94 | scm_putc(port, SCM_CHAR_VAL(obj)); 95 | } 96 | } else { 97 | scm_putc(port, SCM_CHAR_VAL(obj)); 98 | } 99 | break; 100 | case scm_string_type: 101 | if (notdisplay) { 102 | scm_write_cstr(port, "\""); 103 | char *str = SCM_CHAR_STR_VAL(obj); 104 | char *sc; 105 | char *ps; 106 | for (sc = str; *sc; sc++) { 107 | ps = NULL; 108 | switch (*sc) { 109 | case '\a': ps = "\\a"; break; 110 | case '\b': ps = "\\b"; break; 111 | case '\f': ps = "\\f"; break; 112 | case '\n': ps = "\\n"; break; 113 | case '\r': ps = "\\r"; break; 114 | case '\t': ps = "\\t"; break; 115 | case '\v': ps = "\\v"; break; 116 | } 117 | if (ps == NULL) 118 | scm_putc(port, *sc); 119 | else 120 | scm_write_cstr(port, ps); 121 | } 122 | scm_write_cstr(port, "\""); 123 | } 124 | else 125 | scm_write_cstr(port, SCM_CHAR_STR_VAL(obj)); 126 | break; 127 | case scm_symbol_type: 128 | scm_write_cstr(port, SCM_SYMBOL_STR_VAL(obj)); 129 | break; 130 | case scm_pair_type: 131 | write_list(port, obj, notdisplay); 132 | break; 133 | case scm_vector_type: 134 | write_vector(port, obj, notdisplay); 135 | break; 136 | case scm_null_type: 137 | scm_write_cstr(port, "()"); 138 | break; 139 | case scm_primitive_type: 140 | scm_write_cstr(port, "#name); 142 | scm_write_cstr(port, ">"); 143 | break; 144 | case scm_compound_type: 145 | scm_write_cstr(port, "#name ? ((scm_compound_proc *)obj)->name : ""); 147 | scm_write_cstr(port, ">"); 148 | break; 149 | case scm_namespace_type: 150 | scm_write_cstr(port, "#"); 151 | break; 152 | case scm_void_type: 153 | scm_write_cstr(port, "#"); 154 | break; 155 | default: ; 156 | } 157 | } 158 | 159 | static void write_list(scm_object *port, scm_object *list, int notdisplay) 160 | { 161 | 162 | scm_putc(port, '('); 163 | while (!SCM_NULLP(list)) { 164 | if (SCM_PAIRP(list)) { 165 | write_object(port, SCM_CAR(list), notdisplay); 166 | if (!SCM_NULLP(SCM_CDR(list))) { 167 | scm_putc(port, ' '); 168 | list = SCM_CDR(list); 169 | } else { 170 | list = scm_null; 171 | } 172 | } else { 173 | scm_putc(port, '.'); 174 | scm_putc(port, ' '); 175 | write_object(port, list, notdisplay); 176 | list = scm_null; 177 | } 178 | } 179 | scm_putc(port, ')'); 180 | } 181 | 182 | static void write_vector(scm_object *port, scm_object *vector, int notdisplay) 183 | { 184 | scm_putc(port, '#'); 185 | scm_putc(port, '('); 186 | int len = SCM_VECTOR_LEN(vector); 187 | scm_object **elems = SCM_VECTOR_ELEMS(vector); 188 | int i; 189 | for (i = 0; i < len; i++) { 190 | write_object(port, elems[i], notdisplay); 191 | if (i + 1 < len) 192 | scm_putc(port, ' '); 193 | } 194 | scm_putc(port, ')'); 195 | } 196 | -------------------------------------------------------------------------------- /src/cc/pcc32.c: -------------------------------------------------------------------------------- 1 | /******************************************************** 2 | * Author: RedOC * 3 | * Email: RedOC@foxmail.com * 4 | * Notes: Some functions about Win32 Console Control. * 5 | * License: Copyleft. Enjoy it Just for fun. * 6 | * Date: 2008-12-17 00:28:39 * 7 | ********************************************************/ 8 | #ifdef _WIN32 9 | #include "cc.h" 10 | 11 | void delayMS(uint32 d) 12 | { 13 | Sleep(d); 14 | return ; 15 | } 16 | 17 | void clearText(void) 18 | { 19 | system("cls"); 20 | return ; 21 | } 22 | 23 | int setTextColor(uint8 fColor) 24 | { 25 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 26 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 27 | GetConsoleScreenBufferInfo(hd, &csbInfo); 28 | return SetConsoleTextAttribute(hd, fColor | (csbInfo.wAttributes&~0x0F)); 29 | } 30 | 31 | PCCOLOR getTextColor(void) 32 | { 33 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 34 | GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbInfo); 35 | return (PCCOLOR)(csbInfo.wAttributes&0x0F); 36 | } 37 | 38 | int setBackColor(uint8 bColor) 39 | { 40 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 41 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 42 | GetConsoleScreenBufferInfo(hd, &csbInfo); 43 | return SetConsoleTextAttribute(hd, (bColor << 4) | (csbInfo.wAttributes&~0xF0)); 44 | } 45 | 46 | PCCOLOR getBackColor(void) 47 | { 48 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 49 | GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbInfo); 50 | return (PCCOLOR)((csbInfo.wAttributes&0xF0) >> 4); 51 | } 52 | 53 | int setColors(uint8 fColor, uint8 bColor) 54 | { 55 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 56 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 57 | GetConsoleScreenBufferInfo(hd, &csbInfo); 58 | return SetConsoleTextAttribute(hd, fColor | (bColor << 4) | (csbInfo.wAttributes&~0xFF)); 59 | } 60 | 61 | int setSwapColors(int b) 62 | { 63 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 64 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 65 | GetConsoleScreenBufferInfo(hd, &csbInfo); 66 | if (!!b) 67 | return SetConsoleTextAttribute(hd, csbInfo.wAttributes | 0x4000); 68 | else 69 | return SetConsoleTextAttribute(hd, csbInfo.wAttributes & ~0x4000); 70 | } 71 | 72 | int setUnderLine(int b) 73 | { 74 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 75 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 76 | GetConsoleScreenBufferInfo(hd, &csbInfo); 77 | if (!!b) 78 | return SetConsoleTextAttribute(hd, csbInfo.wAttributes | 0x8000); 79 | else 80 | return SetConsoleTextAttribute(hd, csbInfo.wAttributes & ~0x8000); 81 | } 82 | 83 | uint8 getLineWidth(void) 84 | { 85 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 86 | GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbInfo); 87 | return csbInfo.dwSize.X; 88 | } 89 | 90 | uint8 getLineNum(void) 91 | { 92 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 93 | GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbInfo); 94 | return csbInfo.dwSize.Y; 95 | } 96 | 97 | uint8 getCursorX(void) 98 | { 99 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 100 | GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbInfo); 101 | return csbInfo.dwCursorPosition.X; 102 | } 103 | 104 | uint8 getCursorY(void) 105 | { 106 | CONSOLE_SCREEN_BUFFER_INFO csbInfo; 107 | GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbInfo); 108 | return csbInfo.dwCursorPosition.Y; 109 | } 110 | 111 | int gotoTextPos(uint8 x, uint8 y) 112 | { 113 | COORD cd; 114 | cd.X = x; 115 | cd.Y = y; 116 | return SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), cd); 117 | } 118 | 119 | int setCursorVisible(int b) 120 | { 121 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 122 | CONSOLE_CURSOR_INFO ccInfo; 123 | GetConsoleCursorInfo(hd, &ccInfo); 124 | ccInfo.bVisible = !!b; 125 | return SetConsoleCursorInfo(hd, &ccInfo); 126 | } 127 | 128 | int setCursorSize(uint8 s) 129 | { 130 | HANDLE hd = GetStdHandle(STD_OUTPUT_HANDLE); 131 | CONSOLE_CURSOR_INFO ccInfo; 132 | GetConsoleCursorInfo(hd, &ccInfo); 133 | ccInfo.dwSize = s; 134 | return SetConsoleCursorInfo(hd, &ccInfo); 135 | } 136 | 137 | int getConsoleTitle(char *title, uint8 len) 138 | { 139 | return GetConsoleTitle(title, len); 140 | } 141 | 142 | int setConsoleTitle(char *title) 143 | { 144 | return SetConsoleTitle(title); 145 | } 146 | 147 | int fixConsoleSize(uint16 width, uint16 height) 148 | { 149 | int ret = 0; 150 | int fixX = 0, fixY = 0; 151 | COORD cd; 152 | SMALL_RECT srctWindow; 153 | CONSOLE_SCREEN_BUFFER_INFO csbiInfo; 154 | HANDLE hWin = GetStdHandle(STD_OUTPUT_HANDLE); 155 | 156 | if (!hWin) 157 | return 0; 158 | 159 | // 调整最小范围 160 | fixX = (width < MIN_CONSOLE_WIDTH) ? MIN_CONSOLE_WIDTH : width; 161 | fixY = (height < MIN_CONSOLE_HEIGHT) ? MIN_CONSOLE_HEIGHT : height; 162 | 163 | // 先将BUF尺寸扩大到最大 164 | cd.X = 512; 165 | cd.Y = 512; 166 | ret = SetConsoleScreenBufferSize(hWin, cd); 167 | if (!ret) 168 | return ret; 169 | //puts("Set Max Buf Error."); 170 | 171 | // 测试屏幕允许的最大尺寸 172 | GetConsoleScreenBufferInfo(hWin, &csbiInfo); 173 | cd = csbiInfo.dwMaximumWindowSize; 174 | //printf("Max Win Size[%d, %d].\n", cd.X, cd.Y); 175 | fixX = (fixX > cd.X) ? cd.X : fixX; 176 | fixY = (fixY > cd.Y) ? cd.Y : fixY; 177 | //printf("Fix Win Size[%d, %d].\n", fixX, fixY); 178 | 179 | // 确定适当的窗口尺寸 180 | srctWindow.Left = 0; 181 | srctWindow.Right = fixX - 1; 182 | srctWindow.Top = 0; 183 | srctWindow.Bottom = fixY - 1; 184 | ret = SetConsoleWindowInfo(hWin, 1, &srctWindow); 185 | if (!ret) 186 | return ret; 187 | //puts("Set Size Error."); 188 | 189 | // 确定适当的BUF尺寸 190 | cd.X = fixX; 191 | cd.Y = fixY; 192 | ret = SetConsoleScreenBufferSize(hWin, cd); 193 | if (!ret) 194 | return ret; 195 | 196 | //printf("Fix Win Size[%d, %d]: %d.\n", fixX, fixY, ret); 197 | Sleep(100); 198 | return ret; 199 | } 200 | 201 | int showConsoleInfo() 202 | { 203 | int ret; 204 | HANDLE hWin = GetStdHandle(STD_OUTPUT_HANDLE); 205 | CONSOLE_SCREEN_BUFFER_INFO csbiInfo; 206 | 207 | ret = GetConsoleScreenBufferInfo(hWin, &csbiInfo); 208 | if (ret) 209 | { 210 | printf("Buffer Size: [X]%d - [Y]%d\n", csbiInfo.dwSize.X, csbiInfo.dwSize.Y); 211 | printf("Cursor Pos : [X]%d - [Y]%d\n", csbiInfo.dwCursorPosition.X, csbiInfo.dwCursorPosition.Y); 212 | printf("Attributes : %d\n", csbiInfo.wAttributes); 213 | printf("Current Win: [L]%d - [R]%d - [T]%d - [B]%d\n", \ 214 | csbiInfo.srWindow.Left, csbiInfo.srWindow.Right, csbiInfo.srWindow.Top, csbiInfo.srWindow.Bottom); 215 | printf("Maximum Win: [X]%d - [Y]%d\n", csbiInfo.dwMaximumWindowSize.X, csbiInfo.dwMaximumWindowSize.Y); 216 | puts("Over."); 217 | } 218 | return ret; 219 | } 220 | 221 | int simpleRing(uint16 freq, uint16 len) 222 | { 223 | return Beep(freq, len); 224 | } 225 | 226 | uint16 jkGetKey(void) 227 | { 228 | uint16 rk = 0; 229 | uint8 k = getch(); 230 | if (k == JK_FUNC_KEY) 231 | { 232 | k = getch(); 233 | rk = 0xFF00 | k; 234 | return rk; 235 | } 236 | if (k == JK_CTRL_KEY) 237 | { 238 | k = getch(); 239 | rk = 0xE000 | k; 240 | return rk; 241 | } 242 | rk = 0x0000 | k; 243 | return rk; 244 | } 245 | 246 | int jkHasKey(void) 247 | { 248 | return (kbhit()); 249 | } 250 | 251 | #endif 252 | //End of pcc32.c 253 | -------------------------------------------------------------------------------- /src/list.c: -------------------------------------------------------------------------------- 1 | #include "list.h" 2 | #include "number.h" 3 | #include "bool.h" 4 | #include "env.h" 5 | #include "error.h" 6 | 7 | scm_object scm_null[1]; 8 | 9 | static scm_object* pair_p_prim(int, scm_object *[]); 10 | static scm_object* null_p_prim(int, scm_object *[]); 11 | static scm_object* list_p_prim(int, scm_object *[]); 12 | static scm_object* cons_prim(int, scm_object *[]); 13 | static scm_object* car_prim(int, scm_object *[]); 14 | static scm_object* cdr_prim(int, scm_object *[]); 15 | static scm_object* setcar_prim(int, scm_object *[]); 16 | static scm_object* setcdr_prim(int, scm_object *[]); 17 | static scm_object* list_prim(int, scm_object *[]); 18 | static scm_object* list_tail_prim(int, scm_object *[]); 19 | static scm_object* list_ref_prim(int, scm_object *[]); 20 | static scm_object* length_prim(int, scm_object *[]); 21 | static scm_object* append_prim(int, scm_object *[]); 22 | static scm_object* reverse_prim(int, scm_object *[]); 23 | static scm_object* memq_prim(int, scm_object *[]); 24 | static scm_object* memv_prim(int, scm_object *[]); 25 | static scm_object* member_prim(int, scm_object *[]); 26 | 27 | void scm_init_list(scm_env *env) 28 | { 29 | scm_null->type = scm_null_type; 30 | 31 | scm_add_prim(env, "pair?", pair_p_prim, 1, 1); 32 | scm_add_prim(env, "null?", null_p_prim, 1, 1); 33 | scm_add_prim(env, "list?", list_p_prim, 1, 1); 34 | 35 | scm_add_prim(env, "cons", cons_prim, 2, 2); 36 | scm_add_prim(env, "car", car_prim, 1, 1); 37 | scm_add_prim(env, "cdr", cdr_prim, 1, 1); 38 | scm_add_prim(env, "set-car!", setcar_prim, 2, 2); 39 | scm_add_prim(env, "set-cdr!", setcdr_prim, 2, 2); 40 | 41 | scm_add_prim(env, "list", list_prim, 0, -1); 42 | 43 | scm_add_prim(env, "list-tail", list_tail_prim, 2, 2); 44 | scm_add_prim(env, "list-ref", list_ref_prim, 2, 2); 45 | scm_add_prim(env, "length", length_prim, 1, 1); 46 | scm_add_prim(env, "append", append_prim, 0, -1); 47 | scm_add_prim(env, "reverse", reverse_prim, 1, 1); 48 | 49 | scm_add_prim(env, "memq", memq_prim, 2, 2); 50 | scm_add_prim(env, "memv", memv_prim, 2, 2); 51 | scm_add_prim(env, "member", member_prim, 2, 2); 52 | } 53 | 54 | scm_object* scm_make_pair(scm_object *car, scm_object *cdr) 55 | { 56 | scm_object *pair = scm_malloc_object(sizeof(scm_pair)); 57 | pair->type = scm_pair_type; 58 | SCM_PAIR_FLAGS(pair) = SCM_PAIR_FLAGS_INIT; 59 | SCM_CAR(pair) = car; 60 | SCM_CDR(pair) = cdr; 61 | return pair; 62 | } 63 | 64 | /* 65 | * 返回具有一个“是表”标记的序对（但不在结尾增加空表） 66 | */ 67 | scm_object* scm_make_list_pair(scm_object *car, scm_object *cdr) 68 | { 69 | scm_object *r = scm_make_pair(car, cdr); 70 | SCM_PAIR_FLAGS(r) |= SCM_PAIR_IS_LIST; 71 | return r; 72 | } 73 | 74 | scm_object* scm_build_list(int size, scm_object **argv) 75 | { 76 | scm_object *pair = scm_null; 77 | int i; 78 | 79 | for (i = size; i--; ) { 80 | pair = SCM_LCONS(argv[i], pair); /* using SCM_LCONS ! */ 81 | } 82 | 83 | return pair; 84 | } 85 | /* 86 | * @list1 严格表 87 | * @list2 表 88 | */ 89 | scm_object* scm_append_list2(scm_object *list1, scm_object *list2) 90 | { 91 | // TODO: iteration 92 | return SCM_PAIRP(list1) ? 93 | SCM_CONS(SCM_CAR(list1), scm_append_list2(SCM_CDR(list1), list2)) : list2; 94 | } 95 | 96 | /* 97 | * 假设list是一个序对（可以是非严格表），返回其元素个数 98 | */ 99 | int scm_list_length(scm_object *list) 100 | { 101 | int len = 0; 102 | /* 遍历list，直到空表 */ 103 | while (!SCM_NULLP(list)) { 104 | len++; 105 | if (SCM_PAIRP(list)) 106 | list = SCM_CDR(list); 107 | else 108 | list = scm_null; /* 设空表以结束 */ 109 | } 110 | return len; 111 | } 112 | 113 | /** 114 | * 是否一个严格表 115 | */ 116 | int scm_is_list(scm_object *obj) 117 | { 118 | if (SCM_PAIRP(obj)) { 119 | if (SCM_PAIR_FLAGS(obj) & SCM_PAIR_IS_LIST) 120 | return 1; 121 | else { 122 | while (SCM_PAIRP(obj)) 123 | obj = SCM_CDR(obj); 124 | if (SCM_NULLP(obj)) 125 | return 1; 126 | } 127 | } else if (SCM_NULLP(obj)) 128 | return 1; 129 | return 0; 130 | } 131 | 132 | static scm_object* pair_p_prim(int argc, scm_object *argv[]) 133 | { 134 | return SCM_BOOL(SCM_PAIRP(argv[0])); 135 | } 136 | 137 | static scm_object* null_p_prim(int argc, scm_object *argv[]) 138 | { 139 | return SCM_BOOL(SCM_NULLP(argv[0])); 140 | } 141 | 142 | static scm_object* list_p_prim(int argc, scm_object *argv[]) 143 | { 144 | return SCM_BOOL(scm_is_list(argv[0])); 145 | } 146 | 147 | static scm_object* cons_prim(int argc, scm_object *argv[]) 148 | { 149 | return SCM_CONS(argv[0], argv[1]); 150 | } 151 | 152 | static scm_object* car_prim(int argc, scm_object *argv[]) 153 | { 154 | if (!SCM_PAIRP(argv[0])) 155 | return scm_wrong_contract("car", "pair?", 0, argc, argv); 156 | 157 | return SCM_CAR(argv[0]); 158 | } 159 | 160 | static scm_object* cdr_prim(int argc, scm_object *argv[]) 161 | { 162 | if (!SCM_PAIRP(argv[0])) 163 | return scm_wrong_contract("cdr", "pair?", 0, argc, argv); 164 | 165 | return SCM_CDR(argv[0]); 166 | } 167 | 168 | static scm_object* setcar_prim(int argc, scm_object *argv[]) 169 | { 170 | if (!SCM_PAIRP(argv[0])) 171 | return scm_wrong_contract("set-car!", "pair?", 0, argc, argv); 172 | 173 | SCM_CAR(argv[0]) = argv[1]; 174 | return scm_void; 175 | } 176 | 177 | static scm_object* setcdr_prim(int argc, scm_object *argv[]) 178 | { 179 | if (!SCM_PAIRP(argv[0])) 180 | return scm_wrong_contract("set-cdr!", "pair?", 0, argc, argv); 181 | 182 | SCM_CDR(argv[0]) = argv[1]; 183 | SCM_PAIR_FLAGS(argv[0]) = 184 | SCM_PAIRP(argv[1]) ? SCM_PAIR_FLAGS(argv[1]) : SCM_PAIR_IS_NON_LIST; 185 | return scm_void; 186 | } 187 | 188 | static scm_object* list_prim(int argc, scm_object *argv[]) 189 | { 190 | return scm_build_list(argc, argv); 191 | } 192 | 193 | static scm_object* do_checked_list_ref(const char *name, int takecar, int argc, scm_object *argv[]) { 194 | if(!SCM_PAIRP(argv[0])) 195 | return scm_wrong_contract(name, "pair?", 0, argc, argv); 196 | if(!is_exact_nonnegative_integer(argv[1])) 197 | return scm_wrong_contract(name, "exact-nonnegative-integer?", 1, argc, argv); 198 | 199 | scm_object *list = argv[0]; 200 | int index = SCM_INT_VAL(argv[1]); 201 | while (index > 0) { 202 | index--; 203 | if (!SCM_PAIRP(list)) 204 | return scm_wrong_contract("cdr", "pair?", 0, argc, argv); 205 | list = SCM_CDR(list); 206 | } 207 | 208 | if (takecar) { 209 | if (!SCM_PAIRP(list)) 210 | return scm_wrong_contract("car", "pair?", 0, argc, argv); 211 | 212 | return SCM_CAR(list); 213 | } else 214 | return list; 215 | } 216 | 217 | static scm_object* list_tail_prim(int argc, scm_object *argv[]) 218 | { 219 | return do_checked_list_ref("list-tail", 0, argc, argv); 220 | } 221 | 222 | static scm_object* list_ref_prim(int argc, scm_object *argv[]) 223 | { 224 | return do_checked_list_ref("list-ref", 1, argc, argv); 225 | } 226 | 227 | static scm_object* length_prim(int argc, scm_object *argv[]) 228 | { 229 | if (!scm_is_list(argv[0])) 230 | return scm_wrong_contract("length", "list?", 0, argc, argv); 231 | 232 | return scm_make_integer(scm_list_length(argv[0])); 233 | } 234 | 235 | static scm_object* append_prim(int argc, scm_object *argv[]) 236 | { 237 | scm_object *ret = scm_null; 238 | if (argc > 0) { 239 | int i; 240 | for (i = 0; i < argc - 1; i++) { 241 | if (!scm_is_list(argv[0])) 242 | return scm_wrong_contract("append", "list?", i, argc, argv); 243 | ret = scm_append_list2(ret, argv[i]); 244 | } 245 | ret = scm_append_list2(ret, argv[i]); 246 | } 247 | 248 | return ret; 249 | } 250 | 251 | static scm_object* reverse_prim(int argc, scm_object *argv[]) 252 | { 253 | if (!scm_is_list(argv[0])) 254 | return scm_wrong_contract("reverse", "list?", 0, argc, argv); 255 | 256 | scm_object *ret = scm_null; 257 | scm_object *list = argv[0]; 258 | scm_list_for_each(list) { 259 | ret = SCM_LCONS(SCM_CAR(list), ret); 260 | } 261 | 262 | return ret; 263 | } 264 | 265 | #define GEN_MEMBER_PRIM(name, scm_name, eq) \ 266 | static scm_object* name(int argc, scm_object *argv[]) \ 267 | { \ 268 | if (!scm_is_list(argv[1])) \ 269 | return scm_wrong_contract(scm_name, "list?", 1, argc, argv); \ 270 | \ 271 | scm_object *obj = argv[0]; \ 272 | scm_object *list = argv[1]; \ 273 | scm_list_for_each(list) { \ 274 | if (scm_eq(SCM_CAR(list), obj)) \ 275 | return list; \ 276 | } \ 277 | return scm_false; \ 278 | } 279 | 280 | GEN_MEMBER_PRIM(memq_prim, "memq", eq?); 281 | GEN_MEMBER_PRIM(memv_prim, "memv", eqv?); 282 | GEN_MEMBER_PRIM(member_prim, "member", equal?); -------------------------------------------------------------------------------- /src/str.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "str.h" 3 | #include "bool.h" 4 | #include "number.h" 5 | #include "char.h" 6 | #include "list.h" 7 | #include "env.h" 8 | #include "error.h" 9 | 10 | scm_object scm_empty_string[1]; 11 | 12 | static scm_object* string_p_prim(int, scm_object *[]); 13 | static scm_object* make_string_prim(int, scm_object *[]); 14 | static scm_object* string_prim(int, scm_object *[]); 15 | static scm_object* string_length_prim(int, scm_object *[]); 16 | static scm_object* string_ref_prim(int, scm_object *[]); 17 | static scm_object* string_set_prim(int, scm_object *[]); 18 | static scm_object* substring_prim(int, scm_object *[]); 19 | static scm_object* string_append_prim(int, scm_object *[]); 20 | static scm_object* string_copy_prim(int, scm_object *[]); 21 | static scm_object* string_fill_prim(int, scm_object *[]); 22 | static scm_object* string_to_list_prim(int, scm_object *[]); 23 | static scm_object* list_to_string_prim(int, scm_object *[]); 24 | 25 | void scm_init_string(scm_env *env) 26 | { 27 | scm_empty_string->type = scm_string_type; 28 | SCM_CHAR_STR_VAL(scm_empty_string) = ""; 29 | 30 | scm_add_prim(env, "string?", string_p_prim, 1, 1); 31 | scm_add_prim(env, "make-string", make_string_prim, 1, 2); 32 | scm_add_prim(env, "string", string_prim, 0, -1); 33 | scm_add_prim(env, "string-length", string_length_prim, 1, 1); 34 | scm_add_prim(env, "string-ref", string_ref_prim, 2, 2); 35 | scm_add_prim(env, "string-set!", string_set_prim, 3, 3); 36 | scm_add_prim(env, "substring", substring_prim, 3, 3); 37 | scm_add_prim(env, "string-append", string_append_prim, 0, -1); 38 | scm_add_prim(env, "string->list", string_to_list_prim, 1, 1); 39 | scm_add_prim(env, "list->string", list_to_string_prim, 1, 1); 40 | scm_add_prim(env, "string-copy", string_copy_prim, 1, 1); 41 | scm_add_prim(env, "string-fill!", string_fill_prim, 2, 2); 42 | } 43 | 44 | scm_object* scm_make_string(const char *str, int len) 45 | { 46 | scm_object *o = scm_malloc_object(sizeof(scm_string)); 47 | o->type = scm_string_type; 48 | SCM_CHAR_STR_VAL(o) = (char *)str; 49 | SCM_STR_LEN(o) = len; 50 | return o; 51 | } 52 | 53 | static scm_object* string_p_prim(int argc, scm_object *argv[]) 54 | { 55 | return SCM_BOOL(SCM_STRINGP(argv[0])); 56 | } 57 | 58 | static scm_object* make_string_prim(int argc, scm_object *argv[]) 59 | { 60 | if (!is_exact_nonnegative_integer(argv[0])) 61 | return scm_wrong_contract("make-string", "exact-nonnegative-integer?", 0, argc, argv); 62 | 63 | char c = '\0'; 64 | if (argc > 1) { 65 | if (!SCM_CHARP(argv[1])) 66 | return scm_wrong_contract("make-string", "char?", 1, argc, argv); 67 | 68 | c = SCM_CHAR_VAL(argv[1]); 69 | } 70 | 71 | int len = SCM_INT_VAL(argv[0]); 72 | char *cs = malloc(sizeof(char) * len + 1); 73 | int i; 74 | for (i = 0; i < len; i++) 75 | cs[i] = c; 76 | cs[i] = '\0'; 77 | 78 | return scm_make_string(cs, len); 79 | } 80 | 81 | static scm_object* string_prim(int argc, scm_object *argv[]) 82 | { 83 | int i; 84 | char *cs = malloc(sizeof(char) * argc + 1); 85 | for (i = 0; i < argc; i++) { 86 | if (!SCM_CHARP(argv[i])) 87 | return scm_wrong_contract("string", "char?", i, argc, argv); 88 | 89 | cs[i] = SCM_CHAR_VAL(argv[i]); 90 | } 91 | cs[i] = '\0'; 92 | 93 | return scm_make_string(cs, argc); 94 | } 95 | 96 | static scm_object* string_length_prim(int argc, scm_object *argv[]) 97 | { 98 | if (!SCM_STRINGP(argv[0])) 99 | return scm_wrong_contract("string-length", "string?", 0, argc, argv); 100 | 101 | return scm_make_integer(SCM_STR_LEN(argv[0])); 102 | } 103 | 104 | static scm_object* string_ref_prim(int argc, scm_object *argv[]) 105 | { 106 | if (!SCM_STRINGP(argv[0])) 107 | return scm_wrong_contract("string-ref", "string?", 0, argc, argv); 108 | if (!is_exact_nonnegative_integer(argv[1])) 109 | return scm_wrong_contract("string-ref", "exact-nonnegative-integer?", 1, argc, argv); 110 | 111 | int len = SCM_STR_LEN(argv[0]); 112 | int k = SCM_INT_VAL(argv[1]); 113 | if (!(0 <= k && k < len)) 114 | return scm_out_of_range("string-ref", argv[0], k, k, 0); 115 | 116 | return scm_make_char(SCM_CHAR_STR_VAL(argv[0])[k]); 117 | } 118 | 119 | static scm_object* string_set_prim(int argc, scm_object *argv[]) 120 | { 121 | if (!SCM_STRINGP(argv[0])) 122 | return scm_wrong_contract("string-set!", "string?", 0, argc, argv); 123 | if (!is_exact_nonnegative_integer(argv[1])) 124 | return scm_wrong_contract("string-set!", "exact-nonnegative-integer?", 1, argc, argv); 125 | if (!SCM_CHARP(argv[2])) 126 | return scm_wrong_contract("string-set!", "char?", 2, argc, argv); 127 | 128 | int k = SCM_INT_VAL(argv[1]); 129 | if (!(0 <= k && k < SCM_STR_LEN(argv[0]))) 130 | return scm_out_of_range("string-set!", argv[0], k, k, 0); 131 | 132 | SCM_CHAR_STR_VAL(argv[0])[k] = SCM_CHAR_VAL(argv[2]); 133 | 134 | return scm_void; 135 | } 136 | 137 | static scm_object* substring_prim(int argc, scm_object *argv[]) 138 | { 139 | if (!SCM_STRINGP(argv[0])) 140 | return scm_wrong_contract("substring", "string?", 0, argc, argv); 141 | if (!is_exact_nonnegative_integer(argv[1])) 142 | return scm_wrong_contract("substring", "exact-nonnegative-integer?", 1, argc, argv); 143 | if (!is_exact_nonnegative_integer(argv[2])) 144 | return scm_wrong_contract("substring", "exact-nonnegative-integer?", 2, argc, argv); 145 | 146 | int len = SCM_STR_LEN(argv[0]); 147 | int start = SCM_INT_VAL(argv[1]); 148 | int end = SCM_INT_VAL(argv[2]); 149 | if ((0 <= start && start <= len) && (start <= end && end <= len)) { 150 | len = end - start; 151 | char *cs = malloc(sizeof(char) * len + 1); 152 | strncpy(cs, SCM_CHAR_STR_VAL(argv[0]) + start, len); 153 | cs[len] = '\0'; 154 | return scm_make_string(cs, len); 155 | } else { 156 | return scm_out_of_range("substring", argv[0], start, end, 0); 157 | } 158 | } 159 | 160 | static scm_object* string_append_prim(int argc, scm_object *argv[]) 161 | { 162 | if (argc == 0) 163 | return scm_empty_string; 164 | 165 | int len = 0; 166 | int i; 167 | for (i = 0; i < argc; i++) { 168 | if (!SCM_STRINGP(argv[i])) 169 | return scm_wrong_contract("string-append", "string?", i, argc, argv); 170 | len += SCM_STR_LEN(argv[i]); 171 | } 172 | 173 | char *cs = malloc(sizeof(char) * len + 1); 174 | int end = 0; 175 | for (i = 0; i < argc; i++) { 176 | strcpy(cs + end, SCM_CHAR_STR_VAL(argv[i])); 177 | end += SCM_STR_LEN(argv[i]); 178 | } 179 | 180 | return scm_make_string(cs, len); 181 | } 182 | 183 | static scm_object* string_to_list_prim(int argc, scm_object *argv[]) 184 | { 185 | if (!SCM_STRINGP(argv[0])) 186 | return scm_wrong_contract("string->list", "string?", 0, argc, argv); 187 | 188 | scm_object *ret = scm_null; 189 | char *cs = SCM_CHAR_STR_VAL(argv[0]); 190 | int i; 191 | for(i = SCM_STR_LEN(argv[0]) - 1; i >= 0; i--) 192 | ret = SCM_CONS(scm_make_char(cs[i]), ret); 193 | return ret; 194 | } 195 | 196 | static scm_object* list_to_string_prim(int argc, scm_object *argv[]) 197 | { 198 | if (!SCM_LISTP(argv[0])) 199 | return scm_wrong_contract("list->string", "(listof char?)", 0, argc, argv); 200 | 201 | int len = 0; 202 | scm_object *list = argv[0]; 203 | while (!SCM_NULLP(list)) { 204 | if (SCM_PAIRP(list)) { 205 | len++; 206 | if (!SCM_CHARP(SCM_CAR(list))) 207 | return scm_wrong_contract("list->string", "(listof char?)", 0, argc, argv); 208 | list = SCM_CDR(list); 209 | } else { 210 | if (!SCM_NULLP(list)) 211 | return scm_wrong_contract("list->string", "(listof char?)", 0, argc, argv); 212 | } 213 | } 214 | char *cs = malloc(sizeof(char) * len + 1); 215 | list = argv[0]; 216 | int i; 217 | for (i = 0; i < len; i++) { 218 | cs[i] = SCM_CHAR_VAL(SCM_CAR(list)); 219 | list = SCM_CDR(list); 220 | } 221 | cs[i] = '\0'; 222 | return scm_make_string(cs, len); 223 | } 224 | 225 | static scm_object* string_copy_prim(int argc, scm_object *argv[]) 226 | { 227 | if (!SCM_STRINGP(argv[0])) 228 | return scm_wrong_contract("string-copy", "string?", 0, argc, argv); 229 | 230 | char *cs = malloc(sizeof(char) * SCM_STR_LEN(argv[0]) + 1); 231 | strcpy(cs, SCM_CHAR_STR_VAL(argv[0])); 232 | return scm_make_string(cs, SCM_STR_LEN(argv[0])); 233 | } 234 | 235 | static scm_object* string_fill_prim(int argc, scm_object *argv[]) 236 | { 237 | if (!SCM_STRINGP(argv[0])) 238 | return scm_wrong_contract("string-fill!", "string?", 0, argc, argv); 239 | if (!SCM_CHARP(argv[1])) 240 | return scm_wrong_contract("string-fill!", "char?", 1, argc, argv); 241 | 242 | char *cs = SCM_CHAR_STR_VAL(argv[0]); 243 | char c = SCM_CHAR_VAL(argv[1]); 244 | char *sc = cs; 245 | while (*sc) *sc++ = c; 246 | 247 | return scm_void; 248 | } 249 | -------------------------------------------------------------------------------- /src/number.c: -------------------------------------------------------------------------------- 1 | #include "number.h" 2 | #include "bool.h" 3 | #include "env.h" 4 | #include "error.h" 5 | 6 | static scm_object* number_p_prim(int, scm_object *[]); 7 | static scm_object* integer_p_prim(int, scm_object *[]); 8 | static scm_object* real_p_prim(int, scm_object *[]); 9 | static scm_object* zero_p_prim(int, scm_object *[]); 10 | static scm_object* positive_p_prim(int, scm_object *[]); 11 | static scm_object* negative_p_prim(int, scm_object *[]); 12 | static scm_object* odd_p_prim(int, scm_object *[]); 13 | static scm_object* even_p_prim(int, scm_object *[]); 14 | static scm_object* plus_prim(int, scm_object *[]); 15 | static scm_object* minus_prim(int, scm_object *[]); 16 | static scm_object* mul_prim(int, scm_object *[]); 17 | static scm_object* div_prim(int, scm_object *[]); 18 | static scm_object* remainder_prim(int, scm_object *[]); 19 | static scm_object* modulo_prim(int, scm_object *[]); 20 | static scm_object* abs_prim(int, scm_object *[]); 21 | static scm_object* eq_prim(int, scm_object *[]); 22 | static scm_object* lt_prim(int, scm_object *[]); 23 | static scm_object* gt_prim(int, scm_object *[]); 24 | static scm_object* lteq_prim(int, scm_object *[]); 25 | static scm_object* gteq_prim(int, scm_object *[]); 26 | 27 | void scm_init_number(scm_env *env) 28 | { 29 | scm_add_prim(env, "number?", number_p_prim, 1, 1); 30 | scm_add_prim(env, "integer?", integer_p_prim, 1, 1); 31 | scm_add_prim(env, "real?", real_p_prim, 1, 1); 32 | 33 | scm_add_prim(env, "zero?", zero_p_prim, 1, 1); 34 | scm_add_prim(env, "positive?", positive_p_prim, 1, 1); 35 | scm_add_prim(env, "negative?", negative_p_prim, 1, 1); 36 | scm_add_prim(env, "odd?", odd_p_prim, 1, 1); 37 | scm_add_prim(env, "even?", even_p_prim, 1, 1); 38 | 39 | scm_add_prim(env, "+", plus_prim, 0, -1); 40 | scm_add_prim(env, "-", minus_prim, 1, -1); 41 | scm_add_prim(env, "*", mul_prim, 0, -1); 42 | scm_add_prim(env, "/", div_prim, 1, -1); 43 | 44 | scm_add_prim(env, "remainder", remainder_prim, 2, 2); 45 | scm_add_prim(env, "modulo", modulo_prim, 2, 2); 46 | scm_add_prim(env, "abs", abs_prim, 1, 1); 47 | 48 | scm_add_prim(env, "=", eq_prim, 2, -1); 49 | scm_add_prim(env, "<", lt_prim, 2, -1); 50 | scm_add_prim(env, ">", gt_prim, 2, -1); 51 | scm_add_prim(env, "<=", lteq_prim, 2, -1); 52 | scm_add_prim(env, ">=", gteq_prim, 2, -1); 53 | } 54 | 55 | scm_object* scm_make_integer(long val) 56 | { 57 | scm_object *o = scm_malloc_object(sizeof(scm_integer)); 58 | o->type = scm_integer_type; 59 | SCM_INT_VAL(o) = val; 60 | return o; 61 | } 62 | 63 | scm_object* scm_make_float(double val) 64 | { 65 | scm_object *o = scm_malloc_object(sizeof(scm_float)); 66 | o->type = scm_float_type; 67 | SCM_FLOAT_VAL(o) = val; 68 | return o; 69 | } 70 | 71 | static scm_object* number_p_prim(int argc, scm_object *argv[]) 72 | { 73 | return SCM_BOOL(SCM_NUMBERP(argv[0])); 74 | } 75 | 76 | static scm_object* integer_p_prim(int argc, scm_object *argv[]) 77 | { 78 | return SCM_BOOL(SCM_INTEGERP(argv[0])); 79 | } 80 | 81 | static scm_object* real_p_prim(int argc, scm_object *argv[]) 82 | { 83 | return SCM_BOOL(SCM_INTEGERP(argv[0]) || SCM_FLOATP(argv[0])); 84 | } 85 | 86 | static scm_object* zero_p_prim(int argc, scm_object *argv[]) 87 | { 88 | if (SCM_INTEGERP(argv[0])) 89 | return SCM_BOOL(SCM_INT_VAL(argv[0]) == 0); 90 | if (SCM_FLOATP(argv[0])) 91 | return SCM_BOOL(SCM_FLOAT_VAL(argv[0]) == 0.0f); 92 | return scm_wrong_contract("zero?", "number?", 0, argc, argv); 93 | } 94 | 95 | #define GEN_POSI_NEGATIVE_PRIM(name, sname, op) \ 96 | static scm_object* name(int argc, scm_object *argv[]) \ 97 | { \ 98 | if (SCM_INTEGERP(argv[0])) \ 99 | return SCM_BOOL(SCM_INT_VAL(argv[0]) op 0); \ 100 | if (SCM_FLOATP(argv[0])) \ 101 | return SCM_BOOL(SCM_FLOAT_VAL(argv[0]) op 0.0f); \ 102 | return scm_wrong_contract(sname, "real?", 0, argc, argv); \ 103 | } 104 | 105 | GEN_POSI_NEGATIVE_PRIM(positive_p_prim, "positive?", >); 106 | GEN_POSI_NEGATIVE_PRIM(negative_p_prim, "negative?", <); 107 | 108 | #define GEN_ODD_EVEN_PRIM(name, sname, equal) \ 109 | static scm_object* name(int argc, scm_object *argv[]) \ 110 | { \ 111 | if (!SCM_INTEGERP(argv[0])) \ 112 | return scm_wrong_contract(sname, "integer?", 0, argc, argv); \ 113 | return SCM_BOOL((SCM_INT_VAL(argv[0]) % 2) equal 0); \ 114 | } 115 | GEN_ODD_EVEN_PRIM(odd_p_prim, "odd?", !=); 116 | GEN_ODD_EVEN_PRIM(even_p_prim, "even?", ==); 117 | 118 | #define CHECK_AND_GET_MAX_TYPE(op) \ 119 | int max_type = scm_integer_type; \ 120 | int argi; \ 121 | for (argi = 0; argi < argc; argi++) { \ 122 | switch (argv[argi]->type) { \ 123 | case scm_integer_type: \ 124 | if (scm_integer_type > max_type) \ 125 | max_type = scm_integer_type;\ 126 | break; \ 127 | case scm_float_type: \ 128 | if (scm_float_type > max_type) \ 129 | max_type = scm_float_type; \ 130 | break; \ 131 | default: \ 132 | return scm_wrong_contract(#op, "number?", argi, argc, argv);\ 133 | } \ 134 | } 135 | 136 | #define GEN_PLUS_OR_MUL_PRIM_ACCUMULATE(op) \ 137 | switch (argv[0]->type) { \ 138 | case scm_integer_type:\ 139 | ret = SCM_INT_VAL(argv[0]); \ 140 | break; \ 141 | case scm_float_type: \ 142 | ret = SCM_FLOAT_VAL(argv[0]); \ 143 | break; \ 144 | } \ 145 | for (argi = 1; argi < argc; argi++) { \ 146 | switch (argv[argi]->type) { \ 147 | case scm_integer_type: \ 148 | ret op##= SCM_INT_VAL(argv[argi]);\ 149 | break; \ 150 | case scm_float_type: \ 151 | ret op##= SCM_FLOAT_VAL(argv[argi]);\ 152 | break; \ 153 | } \ 154 | } 155 | #define GEN_PLUS_OR_MUL_PRIM(fname, op, init) static scm_object* fname##_prim(int argc, scm_object *argv[]) { \ 156 | if (argc == 0) \ 157 | return scm_make_integer(init); \ 158 | CHECK_AND_GET_MAX_TYPE(op) \ 159 | switch (max_type) { \ 160 | case scm_integer_type: { \ 161 | long ret; \ 162 | GEN_PLUS_OR_MUL_PRIM_ACCUMULATE(op) \ 163 | return scm_make_integer(ret); \ 164 | } \ 165 | case scm_float_type: { \ 166 | double ret; \ 167 | GEN_PLUS_OR_MUL_PRIM_ACCUMULATE(op) \ 168 | return scm_make_float(ret); \ 169 | } \ 170 | } \ 171 | } 172 | 173 | #define GEN_MINUS_OR_DIV_PRIM_ACCUMULATE(op, init) \ 174 | switch (argv[0]->type) { \ 175 | case scm_integer_type:\ 176 | ret = SCM_INT_VAL(argv[0]); \ 177 | break; \ 178 | case scm_float_type: \ 179 | ret = SCM_FLOAT_VAL(argv[0]); \ 180 | break; \ 181 | } \ 182 | if (argc == 1) \ 183 | ret = init op ret; \ 184 | else \ 185 | for (argi = 1; argi < argc; argi++) { \ 186 | switch (argv[argi]->type) { \ 187 | case scm_integer_type: \ 188 | ret op##= SCM_INT_VAL(argv[argi]);\ 189 | break; \ 190 | case scm_float_type: \ 191 | ret op##= SCM_FLOAT_VAL(argv[argi]);\ 192 | break; \ 193 | } \ 194 | } 195 | #define GEN_MINUS_OR_DIV_PRIM(fname, op, init) static scm_object* fname##_prim(int argc, scm_object *argv[]) { \ 196 | CHECK_AND_GET_MAX_TYPE(op) \ 197 | switch (max_type) { \ 198 | case scm_integer_type: { \ 199 | long ret; \ 200 | GEN_MINUS_OR_DIV_PRIM_ACCUMULATE(op, init) \ 201 | return scm_make_integer(ret); \ 202 | } \ 203 | case scm_float_type: { \ 204 | double ret; \ 205 | GEN_MINUS_OR_DIV_PRIM_ACCUMULATE(op, init) \ 206 | return scm_make_float(ret); \ 207 | } \ 208 | } \ 209 | } 210 | 211 | 212 | #define EQ_PRIM_FOREACH(first_val) \ 213 | for (argi = 1; argi < argc; argi++) { \ 214 | switch (argv[argi]->type) { \ 215 | case scm_integer_type: \ 216 | if (first_val != SCM_INT_VAL(argv[argi]))\ 217 | return scm_false; \ 218 | break; \ 219 | case scm_float_type: \ 220 | if (first_val != SCM_FLOAT_VAL(argv[argi]))\ 221 | return scm_false; \ 222 | break; \ 223 | default: \ 224 | return scm_wrong_contract("=", "number?", argi, argc, argv);\ 225 | }\ 226 | } 227 | 228 | static scm_object* eq_prim(int argc, scm_object *argv[]) 229 | { 230 | scm_object *first = argv[0]; 231 | int argi; 232 | 233 | switch (first->type) { 234 | case scm_integer_type: 235 | EQ_PRIM_FOREACH(SCM_INT_VAL(first)) 236 | break; 237 | case scm_float_type: 238 | EQ_PRIM_FOREACH(SCM_FLOAT_VAL(first)) 239 | break; 240 | default: 241 | return scm_wrong_contract("=", "number?", 0, argc, argv); 242 | } 243 | 244 | return scm_true; 245 | } 246 | 247 | #define COMP_PRIM_CMP_WITH_NEXT_ARG(op, prev_arg_val) \ 248 | switch (argv[argi + 1]->type) { \ 249 | case scm_integer_type: \ 250 | if (!(prev_arg_val op SCM_INT_VAL(argv[argi + 1]))) \ 251 | return scm_false; \ 252 | break; \ 253 | case scm_float_type: \ 254 | if (!(prev_arg_val op SCM_FLOAT_VAL(argv[argi + 1]))) \ 255 | return scm_false; \ 256 | break; \ 257 | default: \ 258 | return scm_wrong_contract(#op, "real?", argi + 1, argc, argv);\ 259 | } 260 | #define GEN_COMP_PRIM(fname, op) static scm_object* fname##_prim(int argc, scm_object *argv[]) { \ 261 | int argi; \ 262 | for (argi = 0; argi < argc - 1; argi++) { \ 263 | switch (argv[argi]->type) { \ 264 | case scm_integer_type: \ 265 | COMP_PRIM_CMP_WITH_NEXT_ARG(op, SCM_INT_VAL(argv[argi])) \ 266 | break; \ 267 | case scm_float_type: \ 268 | COMP_PRIM_CMP_WITH_NEXT_ARG(op, SCM_FLOAT_VAL(argv[argi])) \ 269 | break; \ 270 | default: \ 271 | return scm_wrong_contract(#op, "real?", argi, argc, argv); \ 272 | } \ 273 | } \ 274 | return scm_true; \ 275 | } 276 | 277 | GEN_PLUS_OR_MUL_PRIM(plus, +, 0); 278 | GEN_PLUS_OR_MUL_PRIM(mul, *, 1); 279 | GEN_MINUS_OR_DIV_PRIM(minus, -, 0); 280 | GEN_MINUS_OR_DIV_PRIM(div, /, 1); 281 | GEN_COMP_PRIM(lt, <); 282 | GEN_COMP_PRIM(gt, >); 283 | GEN_COMP_PRIM(lteq, <=); 284 | GEN_COMP_PRIM(gteq, >=); 285 | 286 | 287 | static scm_object* remainder_prim(int argc, scm_object *argv[]) 288 | { 289 | if (!SCM_INTEGERP(argv[0])) 290 | return scm_wrong_contract("remainder", "integer?", 0, argc, argv); 291 | if (!SCM_INTEGERP(argv[1])) 292 | return scm_wrong_contract("remainder", "integer?", 1, argc, argv); 293 | 294 | return scm_make_integer(SCM_INT_VAL(argv[0]) % SCM_INT_VAL(argv[1])); 295 | } 296 | 297 | static scm_object* modulo_prim(int argc, scm_object *argv[]) 298 | { 299 | if (!SCM_INTEGERP(argv[0])) 300 | return scm_wrong_contract("modulo", "integer?", 0, argc, argv); 301 | if (!SCM_INTEGERP(argv[1])) 302 | return scm_wrong_contract("modulo", "integer?", 1, argc, argv); 303 | 304 | return scm_make_integer(SCM_INT_VAL(argv[0]) % SCM_INT_VAL(argv[1])); 305 | } 306 | 307 | static scm_object* abs_prim(int argc, scm_object *argv[]) 308 | { 309 | if (SCM_INTEGERP(argv[0])) { 310 | int n = SCM_INT_VAL(argv[0]); 311 | return scm_make_integer(n < 0 ? - n : n); 312 | } 313 | if (SCM_FLOATP(argv[0])) { 314 | double n = SCM_FLOAT_VAL(argv[0]); 315 | return scm_make_float(n < 0 ? - n : n); 316 | } 317 | 318 | return scm_wrong_contract("abs", "number?", 0, argc, argv); 319 | } -------------------------------------------------------------------------------- /src/read.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "read.h" 5 | #include "bool.h" 6 | #include "number.h" 7 | #include "char.h" 8 | #include "str.h" 9 | #include "symbol.h" 10 | #include "list.h" 11 | #include "vector.h" 12 | #include "env.h" 13 | #include "error.h" 14 | 15 | static scm_object* read(scm_object *); 16 | static scm_object* read_char(scm_object *); 17 | static scm_object* read_string(scm_object *); 18 | static scm_object* read_number(scm_object *, char, int); 19 | static scm_object* read_symbol(scm_object *, int); 20 | static scm_object* read_quote(scm_object *); 21 | static scm_object* read_list(scm_object *); 22 | static scm_object* read_vector(scm_object *); 23 | static void skip_whitespace_comments(scm_object *); 24 | static scm_object* read_error(const char *s); 25 | 26 | static scm_object* read_prim(int, scm_object *[]); 27 | 28 | /* c :: int */ 29 | #define isodigit(c) ('0' <= (c) && (c) <= '7') 30 | #define is_dbcs_lead_byte(c) (((c) < 0 && c != EOF) || (c) > 127) 31 | 32 | jmp_buf read_error_jmp_buf; 33 | 34 | int isdelimiter(int c) 35 | { 36 | if (isspace(c)) 37 | return 1; 38 | switch (c) { 39 | case '(': case ')': 40 | case '[': case ']': 41 | case '{': case '}': 42 | case '"': case ';': 43 | return 1; 44 | } 45 | return 0; 46 | } 47 | 48 | int is_special_inital(int c) 49 | { 50 | switch (c) { 51 | case '!': case '$': case '%': 52 | case '&': case '*': case '/': 53 | case ':': case '<': case '=': 54 | case '>': case '?': case '^': 55 | case '_': case '~': 56 | return 1; 57 | } 58 | if (is_dbcs_lead_byte(c)) 59 | return 1; 60 | return 0; 61 | } 62 | 63 | int is_peculiar_identifier(int c) 64 | { 65 | switch (c) { 66 | case '+': case '-': 67 | // and case '...' 68 | return 1; 69 | } 70 | return 0; 71 | } 72 | 73 | int is_sepcial_subsequent(int c) 74 | { 75 | switch (c) { 76 | case '+': case '-': 77 | case '.': case '@': 78 | return 1; 79 | } 80 | return 0; 81 | } 82 | 83 | void scm_init_read(scm_env *env) 84 | { 85 | scm_add_prim(env, "read", read_prim, 0, 1); 86 | } 87 | 88 | scm_object* scm_read(scm_object *port) 89 | { 90 | if (setjmp(read_error_jmp_buf) == 1) { 91 | return NULL; 92 | } 93 | return read(port); // TODO: Unicode 94 | } 95 | 96 | static scm_object* read_prim(int argc, scm_object *argv[]) 97 | { 98 | return read(scm_stdin_port); 99 | } 100 | 101 | scm_object* read(scm_object *port) 102 | { 103 | scm_object *obj = NULL; 104 | int c; // 可以接收EOF（-1） 105 | 106 | skip_whitespace_comments(port); 107 | 108 | c = scm_getc(port); 109 | 110 | switch (c) { 111 | case '#': 112 | c = scm_getc(port); 113 | switch (c) { 114 | case 't': 115 | case 'T': 116 | obj = scm_true; 117 | break; 118 | case 'f': 119 | case 'F': 120 | obj = scm_false; 121 | break; 122 | case '\\': 123 | obj = read_char(port); 124 | break; 125 | case '(': 126 | case '[': 127 | case '{': 128 | obj = read_vector(port); 129 | break; 130 | default: 131 | obj = read_number(port, c, 1); 132 | } 133 | break; 134 | case '-': 135 | case '+': {//TODO: +1a also a identifler 136 | int c1 = scm_getc(port); 137 | if (isdigit(c1)) { 138 | scm_ungetc(c1, port); 139 | obj = read_number(port, 10, c == '-' ? -1 : 1); 140 | } else { 141 | scm_ungetc(c1, port); 142 | obj = read_symbol(port, c); 143 | } 144 | break; 145 | } 146 | case '.': //TODO: .5 == 0.5 147 | obj = read_symbol(port, c); 148 | break; 149 | case '(': 150 | case '[': 151 | case '{': 152 | obj = read_list(port); 153 | break; 154 | case '"': 155 | obj = read_string(port); 156 | break; 157 | case '\'': 158 | obj = read_quote(port); 159 | break; 160 | default: 161 | if (scm_eofp(c)) { 162 | break; 163 | } else if (isdigit(c)) { 164 | scm_ungetc(c, port); 165 | obj = read_number(port, 10, 1); 166 | } else if (isalpha(c) || is_special_inital(c)) { 167 | obj = read_symbol(port, c); 168 | } 169 | } 170 | 171 | return obj; 172 | } 173 | 174 | static scm_object* read_quote(scm_object *port) 175 | { 176 | return cons((scm_object *)scm_quote_symbol, cons(read(port), scm_null)); 177 | } 178 | 179 | static scm_object* read_list(scm_object *port) 180 | { 181 | scm_object *head = scm_null, *prev = NULL, *curr; 182 | scm_object *obj; 183 | int found_dot = 0; 184 | int c; 185 | 186 | while (1) { 187 | c = scm_getc(port); 188 | if (c == ')' || c == ']' || c == '}' || scm_eofp(c)) { 189 | if (found_dot && found_dot != 2) // 如果读序对的'.，但没有读到cdr 190 | return read_error("unexpected `)'"); 191 | break; 192 | } 193 | 194 | scm_ungetc(c, port); 195 | obj = read(port); 196 | skip_whitespace_comments(port); 197 | 198 | if (prev) { 199 | if (SAME_OBJ(obj, (scm_object *)scm_dot_symbol)) { 200 | if (found_dot) // 如果不是: 预期已读到至少一个car (prev != NULL)，并且没有读到过'. 201 | return read_error("illegal use of `.'"); 202 | found_dot = 1; // 找到'.，预期读一个cdr 203 | } else { 204 | if (found_dot) { 205 | SCM_CDR(prev) = obj; 206 | prev = obj; 207 | found_dot = 2; // '.已读一个cdr 208 | } else { 209 | curr = cons(obj, scm_null); 210 | SCM_CDR(prev) = curr; 211 | prev = curr; 212 | } 213 | } 214 | } else { 215 | if (SAME_OBJ(obj, (scm_object *)scm_dot_symbol)) 216 | return read_error("illegal use of `.'"); 217 | head = prev = cons(obj, scm_null); 218 | } 219 | } 220 | 221 | if (!SCM_NULLP(head) && (!found_dot || SCM_NULLP(prev))) { 222 | SCM_PAIR_FLAGS(head) |= SCM_PAIR_IS_LIST; 223 | } 224 | 225 | return head; 226 | } 227 | 228 | static scm_object* read_vector(scm_object *port) 229 | { 230 | int len = 0; 231 | scm_pair head; 232 | scm_object *prev = (scm_object *)&head; 233 | scm_object *obj; 234 | int c; 235 | 236 | while (1) { 237 | c = scm_getc(port); 238 | if (c == ')' || c == ']' || c == '}' || scm_eofp(c)) { 239 | break; 240 | } 241 | 242 | scm_ungetc(c, port); 243 | obj = read(port); 244 | skip_whitespace_comments(port); 245 | 246 | SCM_CDR(prev) = SCM_LIST1(obj); 247 | prev = SCM_CDR(prev); 248 | len++; 249 | } 250 | 251 | if (prev != (scm_object *)&head) 252 | return scm_list_to_vector(SCM_CDR(&head), len); 253 | else 254 | return scm_make_vector(NULL, 0); 255 | } 256 | 257 | static scm_object* read_symbol(scm_object *port, int initch) 258 | { 259 | #define SYMBOL_BUF_SIZE_INIT 10 260 | int buf_size = SYMBOL_BUF_SIZE_INIT; 261 | int buf_idx = 0; 262 | char *buf = (char*)malloc(sizeof(char) * SYMBOL_BUF_SIZE_INIT + 1); 263 | int c; 264 | 265 | buf[buf_idx++] = initch; 266 | while (1) { 267 | c = scm_getc(port); 268 | if (is_dbcs_lead_byte(c)) { 269 | // nothing 270 | } else if (isdelimiter(c)) { 271 | scm_ungetc(c, port); 272 | break; 273 | } else if (scm_eofp(c)) { 274 | break; 275 | } 276 | if (buf_idx >= buf_size) { 277 | buf_size += 10; // grow 10bytes 278 | buf = realloc(buf, buf_size); 279 | } 280 | buf[buf_idx++] = c; 281 | } 282 | buf[buf_idx] = '\0'; 283 | 284 | return (scm_object *)scm_get_intern_symbol((const char *)buf); 285 | } 286 | 287 | static scm_object* read_number(scm_object *port, char radixc, int sign) 288 | { 289 | #define NUMBER_BUF_SIZE_INIT 5 290 | #define APPEND_CH(c) if(buf_idx >= buf_size) \ 291 | { buf_size += 3; buf = realloc(buf, buf_size); } \ 292 | buf[buf_idx++] = c; 293 | 294 | int buf_size = NUMBER_BUF_SIZE_INIT; 295 | int buf_idx = 0; 296 | char *buf = (char*)malloc(sizeof(char) * NUMBER_BUF_SIZE_INIT + 1); 297 | int dot = 0; 298 | int c; 299 | 300 | switch (radixc) { 301 | case 'b': 302 | case 'B': 303 | // radix 2 304 | case 'o': 305 | case 'O': 306 | // radix 8 307 | case 'd': 308 | case 'D': 309 | case 10: 310 | while (1) { 311 | c = scm_getc(port); 312 | if (isdigit(c)) { 313 | APPEND_CH(c); 314 | } else if (c == '.') { 315 | if(dot) { // 类似1..a，是一个合法标识符，但我们不支持 316 | read_error("bad syntax"); 317 | return NULL; 318 | } 319 | dot = 1; 320 | APPEND_CH(c); 321 | } else if (scm_eofp(c)) { 322 | break; 323 | } else { 324 | scm_ungetc(c, port); 325 | break; 326 | } 327 | } 328 | buf[buf_idx] = '\0'; 329 | 330 | if (dot) { 331 | double num = atof(buf); 332 | if (sign < 0) num *= sign; 333 | return scm_make_float(num); 334 | } else { 335 | int num = atol(buf); 336 | if (sign < 0) num *= sign; 337 | return scm_make_integer(num); 338 | } 339 | break; 340 | case 'x': 341 | case 'X': 342 | // radix 16 343 | default: 344 | read_error("bad syntax"); 345 | return NULL; 346 | } 347 | } 348 | 349 | static scm_object* read_char(scm_object *port) 350 | { 351 | #define CHARS_BUF_SIZE_INIT 1 352 | 353 | int buf_size = CHARS_BUF_SIZE_INIT; 354 | int buf_idx = 0; 355 | char *buf = (char*)malloc(sizeof(char) * CHARS_BUF_SIZE_INIT + 1); 356 | int c; 357 | 358 | while (1) { 359 | c = scm_getc(port); 360 | if (isdelimiter(c)) { 361 | scm_ungetc(c, port); 362 | break; 363 | } else if (scm_eofp(c)) { 364 | break; 365 | } 366 | if (buf_idx >= buf_size) { 367 | buf_size += 2; 368 | buf = realloc(buf, buf_size); 369 | } 370 | buf[buf_idx++] = c; 371 | } 372 | if (buf_idx == 1) { 373 | c = *buf; 374 | } else { 375 | buf[buf_idx] = '\0'; 376 | if (strcmp(buf, "space") == 0) 377 | c = ' '; 378 | else if (strcmp(buf, "newline") == 0) 379 | c = '\n'; 380 | } 381 | return scm_make_char(c); 382 | } 383 | 384 | static scm_object* read_string(scm_object *port) 385 | { 386 | #define STR_BUF_SIZE_INIT 50 387 | 388 | int buf_size = STR_BUF_SIZE_INIT; 389 | int buf_idx = 0; 390 | char *buf = (char*)malloc(sizeof(char) * STR_BUF_SIZE_INIT + 1); 391 | int c; 392 | 393 | while (1) { 394 | c = scm_getc(port); 395 | // escape sequence handling 396 | if (c == '\\') { 397 | c = scm_getc(port); 398 | switch (c) { 399 | case '\\': case '\"': case '\'': break; 400 | case 'a': c = '\a'; break; 401 | case 'b': c = '\b'; break; 402 | case 'e': c = '\33'; break; /* escape */ 403 | case 'f': c = '\f'; break; 404 | case 'n': c = '\n'; break; 405 | case 'r': c = '\r'; break; 406 | case 't': c = '\t'; break; 407 | case 'v': c = '\v'; break; 408 | case 'x': 409 | // TODO: 410 | case 'u': 411 | case 'U': 412 | // TODO: 413 | default: 414 | //if(isodigit(c)) 415 | ; 416 | } 417 | } else if (c == '"') { 418 | break; 419 | } else if (scm_eofp(c)) { 420 | break; 421 | } 422 | if (buf_idx >= buf_size) { 423 | buf_size += 20; 424 | buf = realloc(buf, buf_size); 425 | } 426 | buf[buf_idx++] = c; 427 | } 428 | buf[buf_idx] = '\0'; 429 | 430 | return scm_make_string((const char*)buf, buf_idx); 431 | } 432 | 433 | static void skip_whitespace_comments(scm_object *port) 434 | { 435 | int c, c1; 436 | while (1) { 437 | c = scm_getc(port); 438 | if (isspace(c)) 439 | continue; 440 | else if (c == ';') { 441 | while(1) { 442 | c = scm_getc(port); 443 | if (c == '\n' || c == '\r') 444 | break; 445 | else if (scm_eofp(c)) 446 | return; 447 | } 448 | } else if (c == '#') { // mutil-line comment start 449 | c1 = scm_getc(port); 450 | if (c1 == '|') { 451 | while (1) { 452 | c = scm_getc(port); 453 | if (c == '|') { 454 | c = scm_getc(port); 455 | if (c == '#') 456 | break; 457 | } else if (scm_eofp(c)) 458 | return; 459 | } 460 | } else { 461 | scm_ungetc(c1, port); 462 | break; 463 | } 464 | } else 465 | break; 466 | } 467 | scm_ungetc(c, port); 468 | } 469 | 470 | static scm_object* read_error(const char *s) 471 | { 472 | scm_print_error("read: "); 473 | scm_print_error(s == NULL ? "error" : s); 474 | scm_print_error("\n"); 475 | 476 | longjmp(read_error_jmp_buf, 1); 477 | 478 | return NULL; 479 | } 480 | -------------------------------------------------------------------------------- /src/eval.c: -------------------------------------------------------------------------------- 1 | #include "eval.h" 2 | #include "env.h" 3 | #include "bool.h" 4 | #include "symbol.h" 5 | #include "number.h" 6 | #include "list.h" 7 | #include "error.h" 8 | #include "port.h" 9 | #include "read.h" 10 | #include "print.h" 11 | 12 | #define EVAL(expr) { exp = expr; goto EVAL; } 13 | 14 | #define apply_primitive_procedure(proc, argc, argv) (((scm_primitive_proc *)proc)->prim(argc, argv)) 15 | #define when_to_if(exp) \ 16 | scm_make_if1(scm_when_test(exp), scm_make_begin(scm_when_body(exp))) 17 | #define unless_to_if(exp) \ 18 | scm_make_if1( \ 19 | scm_make_app(scm_not_symbol, SCM_LIST1(scm_unless_test(exp))), \ 20 | scm_make_begin(scm_unless_body(exp))) 21 | 22 | static scm_object* eval_prim(int, scm_object *[]); 23 | static scm_object* eval(scm_object *, scm_env *); 24 | static scm_object* eval_definition(scm_object *, scm_env *); 25 | static scm_object* eval_assignment(scm_object *, scm_env *); 26 | static scm_object* eval_lambda(scm_object *, scm_env *); 27 | static scm_env* make_apply_env(scm_compound_proc *, int, scm_object *[]); 28 | static int match_arity(scm_object *, int, scm_object *[]); 29 | 30 | static scm_object* let_to_combination(scm_object *); 31 | static scm_object* and_to_if(scm_object *); 32 | static scm_object* or_to_if(scm_object *); 33 | static scm_object* cond_to_if(scm_object *); 34 | static scm_object* case_to_cond(scm_object *); 35 | static scm_object* scm_inc_assign_to_more_prim(scm_object *); 36 | static scm_object* scm_dec_assign_to_more_prim(scm_object *); 37 | static scm_object* do_to_more_prim(scm_object *); 38 | static scm_object* while_to_more_prim(scm_object *); 39 | static scm_object* for_to_more_prim(scm_object *); 40 | 41 | static scm_env *global_env = NULL; 42 | 43 | jmp_buf eval_error_jmp_buf; 44 | 45 | void scm_init() 46 | { 47 | global_env = scm_basic_env(); 48 | } 49 | 50 | void scm_init_eval(scm_env *env) 51 | { 52 | scm_add_prim(env, "eval", eval_prim, 1, 2); 53 | } 54 | 55 | scm_object* scm_eval_src_string(char *src) 56 | { 57 | scm_object *port = scm_make_char_string_input_port(src, -1); 58 | scm_object *exp, *val; 59 | int ch; 60 | 61 | while (!scm_eofp(ch = scm_getc(port))) { 62 | scm_ungetc(ch, port); 63 | val = NULL; 64 | exp = scm_read(port); 65 | if (!exp) // 如果遇到错误，中止执行 66 | break; 67 | val = scm_eval(exp); 68 | if (!val) // 同上 69 | break; 70 | } 71 | 72 | return val; 73 | } 74 | 75 | scm_object* scm_eval(scm_object *exp) 76 | { 77 | if (setjmp(eval_error_jmp_buf) == 1) { 78 | return NULL; 79 | } 80 | return eval(exp, global_env); 81 | } 82 | 83 | scm_object* scm_apply(scm_object *proc, int argc, scm_object *argv[]) 84 | { 85 | if (SCM_PRIMPROCP(proc)) { 86 | if (match_arity(proc, argc, argv)) 87 | return apply_primitive_procedure(proc, argc, argv); 88 | } else if (SCM_COMPROCP(proc)) { 89 | if (match_arity(proc, argc, argv)) 90 | return eval(scm_make_begin(((scm_compound_proc *)proc)->body), 91 | make_apply_env((scm_compound_proc *)proc, argc, argv)); 92 | } 93 | return NULL; 94 | } 95 | 96 | static scm_object* eval_prim(int argc, scm_object *argv[]) 97 | { 98 | if (argc == 1) { 99 | return eval(argv[0], global_env); 100 | } else { 101 | if (!SCM_NAMESPACEP(argv[1])) 102 | return scm_wrong_contract("eval", "namespace?", 1, argc, argv); 103 | return eval(argv[0], (scm_env *)argv[1]); 104 | } 105 | } 106 | 107 | static scm_object* eval(scm_object *exp, scm_env *env) 108 | { 109 | EVAL: 110 | // 根据表达式类型dispatch动作 111 | switch (SCM_TYPE(exp)) { 112 | case scm_true_type: 113 | case scm_false_type: 114 | case scm_integer_type: 115 | case scm_float_type: 116 | case scm_char_type: 117 | case scm_string_type: 118 | case scm_vector_type: 119 | case scm_void_type: 120 | // self evaluating 121 | return exp; 122 | 123 | case scm_symbol_type: { 124 | // 是符号，查询在环境中关联的值 125 | scm_object *val = scm_env_lookup(env, (scm_symbol *) exp); 126 | if (val != NULL) { 127 | return val; 128 | } else { 129 | return scm_undefined_identifier((scm_symbol *)exp); 130 | } 131 | } 132 | 133 | case scm_pair_type: { 134 | if (!SCM_LISTP(exp)) { 135 | scm_print_error("application: bad syntax\n"); 136 | scm_print_error(" in: "); 137 | scm_write(scm_stdout_port, exp); 138 | scm_print_error("\n"); 139 | scm_throw_eval_error(); 140 | return NULL; 141 | } 142 | scm_symbol *operator = (scm_symbol *) scm_operator(exp); 143 | // 如果运算符为符号，可能是语法关键字 144 | if (SCM_SYMBOLP(operator)) { 145 | if (SAME_OBJ(operator, scm_quote_symbol)) 146 | // eval quotation 147 | return scm_quoted_object(exp); 148 | if (SAME_OBJ(operator, scm_define_symbol)) 149 | return eval_definition(exp, env); 150 | if (SAME_OBJ(operator, scm_lambda_symbol)) 151 | return eval_lambda(exp, env); 152 | if (SAME_OBJ(operator, scm_begin_symbol)) { 153 | /* 求值顺序表达式/序列 */ 154 | scm_object *exps = scm_begin_actions(exp); 155 | if (! SCM_NULLP(exps)) { 156 | // 顺序求值尾部前面的表达式 157 | for(; ! SCM_NULLP( SCM_CDR(exps) ); exps = SCM_CDR(exps) ) 158 | eval(SCM_CAR(exps), env); 159 | // 迭代求值尾上下文中的表达式 160 | EVAL(SCM_CAR(exps)); 161 | } else { 162 | return scm_void; 163 | } 164 | } 165 | if (SAME_OBJ(operator, scm_if_symbol)) { 166 | /* 求值if表达式 */ 167 | scm_object *optionalAlt; 168 | // 首先求值谓词表达式 169 | // 然后继续判断谓词的值：如果为真，返回迭代求值后件，否则迭代求值前件 170 | EVAL(SCM_TRUEP( eval(scm_if_predicate(exp), env) ) ? 171 | scm_if_consequent(exp) : (optionalAlt = scm_if_alternative(exp), 172 | SCM_NULLP(optionalAlt) ? scm_void : optionalAlt)); 173 | } 174 | if (SAME_OBJ(operator, scm_let_symbol)) { 175 | /* let在语法上变换到lambda */ 176 | EVAL(let_to_combination(exp)); 177 | } 178 | if (SAME_OBJ(operator, scm_and_symbol)) { 179 | EVAL(and_to_if(exp)); 180 | } 181 | if (SAME_OBJ(operator, scm_or_symbol)) { 182 | EVAL(or_to_if(exp)); 183 | } 184 | if (SAME_OBJ(operator, scm_when_symbol)) { 185 | EVAL(when_to_if(exp)); 186 | } 187 | if (SAME_OBJ(operator, scm_unless_symbol)) { 188 | EVAL(unless_to_if(exp)); 189 | } 190 | if (SAME_OBJ(operator, scm_cond_symbol)) { 191 | EVAL(cond_to_if(exp)); 192 | } 193 | if (SAME_OBJ(operator, scm_case_symbol)) { 194 | EVAL(case_to_cond(exp)); 195 | } 196 | if (SAME_OBJ(operator, scm_inc_assign_symbol)) { 197 | EVAL(scm_inc_assign_to_more_prim(exp)); 198 | } 199 | if (SAME_OBJ(operator, scm_dec_assign_symbol)) { 200 | EVAL(scm_dec_assign_to_more_prim(exp)); 201 | } 202 | if (SAME_OBJ(operator, scm_do_symbol)) { 203 | EVAL(do_to_more_prim(exp)); 204 | } 205 | if (SAME_OBJ(operator, scm_while_symbol)) { 206 | EVAL(while_to_more_prim(exp)); 207 | } 208 | if (SAME_OBJ(operator, scm_for_symbol)) { 209 | EVAL(for_to_more_prim(exp)); 210 | } 211 | if (SAME_OBJ(operator, scm_assignment_symbol)) 212 | return eval_assignment(exp, env); 213 | } 214 | 215 | /* 另外，是符号但不是语法关键字，或者不是符号，就是过程调用表达式：*/ 216 | // 首先求值运算符，得到过程对象 217 | scm_object *proc = eval((scm_object *) operator, env); 218 | scm_object *operands = scm_operands(exp); 219 | 220 | // 然后求值运算数，得到实际参数 221 | //array of values 222 | //TODO: O(n) 223 | scm_object **argv = malloc(sizeof(scm_object *) * scm_list_length(operands)); 224 | int argc = 0; 225 | scm_list_for_each(operands) { 226 | argv[argc++] = eval(SCM_CAR(operands), env); 227 | } 228 | 229 | if (SCM_PRIMPROCP(proc)) { 230 | // 检查实参个数是否匹配形参个数 231 | if (match_arity(proc, argc, argv)) 232 | return apply_primitive_procedure(proc, argc, argv); 233 | } else if (SCM_COMPROCP(proc)) { 234 | if (match_arity(proc, argc, argv)) { 235 | // 将过程体转换为begin类型表达式 236 | exp = scm_make_begin(((scm_compound_proc *)proc)->body); 237 | // 构造一个用于执行过程调用的新环境 238 | env = make_apply_env((scm_compound_proc *)proc, argc, argv); 239 | // 在新环境上下文中迭代求值过程体。注意这里没有去递归调用eval，上同 240 | goto EVAL; 241 | } 242 | } else { 243 | scm_print_error("application: not a procedure;\n"\ 244 | " expected a procedure that can be applied to arguments\n"); 245 | scm_throw_eval_error(); 246 | } 247 | break; 248 | } 249 | case scm_null_type: 250 | scm_print_error("application: illegal empty application;\n"); 251 | scm_throw_eval_error(); 252 | break; 253 | default: ; 254 | } 255 | return NULL; 256 | } 257 | 258 | static scm_object* eval_lambda(scm_object *exp, scm_env *env) 259 | { 260 | // make compound procedure 261 | scm_compound_proc *proc = (scm_compound_proc *)scm_malloc_object(sizeof(scm_compound_proc)); 262 | ((scm_object *)proc)->type = scm_compound_type; 263 | proc->name = NULL; 264 | proc->body = scm_lambda_body(exp); 265 | proc->env = env; 266 | 267 | scm_object *formals = scm_lambda_paramters(exp); 268 | 269 | if (SCM_PAIRP(formals)) { 270 | int len = scm_list_length(formals); 271 | int param_i = 0; 272 | proc->params = malloc(len * sizeof(scm_object *)); 273 | proc->min_arity = len; 274 | 275 | while (SCM_PAIRP(formals)) { 276 | proc->params[param_i++] = SCM_CAR(formals); 277 | formals = SCM_CDR(formals); 278 | } 279 | if (SCM_NULLP(formals)) { 280 | proc->max_arity = len; 281 | } else { 282 | proc->params[param_i++] = formals; 283 | proc->max_arity = -1; 284 | } 285 | proc->params_len = param_i; 286 | } else if (SCM_NULLP(formals)) { 287 | proc->min_arity = 0; 288 | proc->max_arity = 0; 289 | proc->params_len = 0; 290 | } else if (SCM_SYMBOLP(formals)) { 291 | proc->params = malloc(sizeof(scm_object *)); 292 | proc->params[0] = formals; 293 | proc->params_len = 1; 294 | proc->min_arity = 0; 295 | proc->max_arity = -1; 296 | } else { 297 | scm_print_error("lambda: argument sequence\n"); 298 | scm_print_error(" in: "); 299 | scm_write(scm_stdout_port, exp); 300 | scm_print_error("\n"); 301 | scm_throw_eval_error(); 302 | } 303 | 304 | return (scm_object *)proc; 305 | } 306 | 307 | static scm_object* eval_definition(scm_object *exp, scm_env *env) 308 | { 309 | scm_symbol *id = scm_definition_var(exp); 310 | scm_object *val = eval(scm_definition_val(exp), env); 311 | if (SCM_COMPROCP(val) && !((scm_compound_proc *)val)->name) 312 | ((scm_compound_proc *)val)->name = SCM_SYMBOL_STR_VAL(id); 313 | 314 | scm_env_add_binding(env, id, val); 315 | 316 | return scm_void; 317 | } 318 | 319 | static scm_object* eval_assignment(scm_object *exp, scm_env *env) 320 | { 321 | scm_object *id = scm_assignment_var(exp); 322 | if (!SCM_SYMBOLP(id)) { 323 | scm_print_error("set!: bad syntax \n"); 324 | scm_throw_eval_error(); 325 | } 326 | if (scm_env_update_binding(env, (scm_symbol*)id, eval(scm_assignment_val(exp), env)) != 0) { 327 | scm_undefined_identifier((scm_symbol*)id); 328 | } 329 | return scm_void; 330 | } 331 | 332 | static scm_env* make_apply_env(scm_compound_proc *proc, int argc, scm_object *argv[]) 333 | { 334 | if (proc->params_len > 0) { 335 | // 将创建该过程时的环境作为外围环境 336 | scm_env *apply_env = scm_env_new_frame(proc->params_len, proc->env); 337 | 338 | int index; 339 | if (proc->min_arity == proc->max_arity) { 340 | for (index = 0; index < proc->params_len; index++) 341 | scm_env_add_binding(apply_env, (scm_symbol *)proc->params[index], argv[index]); 342 | } else { 343 | if (proc->min_arity > 0) { 344 | for (index = 0; index < proc->params_len - 1; index++) 345 | scm_env_add_binding(apply_env, (scm_symbol *) proc->params[index], argv[index]); 346 | scm_env_add_binding(apply_env, (scm_symbol *)proc->params[index], 347 | scm_build_list(argc - index, argv + index)); 348 | } else { 349 | scm_env_add_binding(apply_env, (scm_symbol *)proc->params[0], scm_build_list(argc, argv)); 350 | } 351 | } 352 | 353 | return apply_env; 354 | } else { 355 | return proc->env; 356 | } 357 | } 358 | 359 | static int match_arity(scm_object *proc, int argc, scm_object *argv[]) 360 | { 361 | int min , max; 362 | 363 | if (SCM_COMPROCP(proc)) { 364 | min = ((scm_compound_proc *)proc)->min_arity; 365 | max = ((scm_compound_proc *)proc)->max_arity; 366 | } else { 367 | min = ((scm_primitive_proc *)proc)->min_arity; 368 | max = ((scm_primitive_proc *)proc)->max_arity; 369 | } 370 | 371 | if (min == max) { 372 | if (argc != min) 373 | scm_mismatch_arity(proc, 0, min, -1, argc, argv); 374 | } else { 375 | if (max > 0) { 376 | if (argc < min || argc > max) 377 | scm_mismatch_arity(proc, 0, min, max, argc, argv); 378 | } else { 379 | if (argc < min) 380 | scm_mismatch_arity(proc, 1, min, -1, argc, argv); 381 | } 382 | } 383 | 384 | return 1; 385 | } 386 | 387 | 388 | /* built-in syntax transformers */ 389 | 390 | static scm_object* let_to_combination(scm_object *exp) 391 | { 392 | // pluck bindings vars, inits 393 | scm_object *bindings = scm_let_bindings(exp); 394 | scm_pair binding_vars_head; 395 | scm_object *var_prev = (scm_object *)&binding_vars_head; 396 | scm_pair binding_inits_head; 397 | scm_object *init_prev = (scm_object *)&binding_inits_head; 398 | scm_list_for_each(bindings) { 399 | var_prev = SCM_CDR(var_prev) = SCM_LCONS(SCM_CAAR(bindings), scm_null); 400 | init_prev = SCM_CDR(init_prev) = SCM_LCONS(SCM_CADAR(bindings), scm_null); 401 | } 402 | 403 | scm_object *binding_vars = var_prev != (scm_object *)&binding_vars_head ? 404 | SCM_CDR(&binding_vars_head) : scm_null; 405 | scm_object *binding_inits = init_prev != (scm_object *)&binding_inits_head ? 406 | SCM_CDR(&binding_inits_head) : scm_null; 407 | 408 | scm_object *body = scm_let_body(exp); 409 | 410 | if(scm_is_named_let(exp)) { 411 | return scm_make_app0( 412 | scm_make_lambda( 413 | scm_null, 414 | SCM_LIST2( 415 | scm_make_def(scm_let_var(exp), scm_make_lambda(binding_vars, body)), 416 | scm_make_app(scm_let_var(exp), binding_inits)))); 417 | } else { 418 | return scm_make_app( 419 | scm_make_lambda(binding_vars, body), 420 | binding_inits); 421 | } 422 | } 423 | 424 | #define GEN_AND_OR_OR_TRANS(name, val_ifnull, pred_exp) \ 425 | static scm_object* name(scm_object *exp) \ 426 | { \ 427 | if(SCM_NULLP(SCM_CDR(exp))) \ 428 | return val_ifnull; \ 429 | \ 430 | scm_object *temp_var = scm_gen_symbol(); \ 431 | scm_object *head = NULL, *prev; \ 432 | scm_object *let_exp, *if_exp; \ 433 | \ 434 | exp = SCM_CDR(exp); \ 435 | scm_list_for_each(exp) { \ 436 | if (!SCM_NULLP(SCM_CDR(exp))) { \ 437 | if_exp = scm_make_if(pred_exp, temp_var, NULL); \ 438 | let_exp = scm_make_let(SCM_LIST1(SCM_LIST2(temp_var, SCM_CAR(exp))), if_exp); \ 439 | if (head != NULL) \ 440 | SCM_CDR(prev) = SCM_LIST1(let_exp); \ 441 | else \ 442 | head = let_exp; \ 443 | prev = SCM_CDDR(if_exp); \ 444 | } else { \ 445 | if (head != NULL) \ 446 | SCM_CDR(prev) = SCM_LIST1(SCM_CAR(exp)); \ 447 | else { \ 448 | head = SCM_CAR(exp); \ 449 | } \ 450 | } \ 451 | \ 452 | } \ 453 | \ 454 | return head; \ 455 | } 456 | 457 | GEN_AND_OR_OR_TRANS(and_to_if, scm_true, scm_make_app(scm_not_symbol, SCM_LIST1(temp_var))); 458 | GEN_AND_OR_OR_TRANS(or_to_if, scm_false, temp_var); 459 | 460 | static scm_object* cond_to_if(scm_object *exp) 461 | { 462 | #define it_clause_actions(exp) scm_sequence_exp(scm_clause_actions(SCM_CAR(exp))) 463 | 464 | if(SCM_NULLP(scm_cond_clauses(exp))) 465 | return scm_void; 466 | 467 | scm_object *head = NULL, *prev; 468 | scm_object *if_exp; 469 | 470 | // for each clauses 471 | exp = scm_cond_clauses(exp); 472 | scm_list_for_each(exp) { 473 | if (!scm_is_else_clause(SCM_CAR(exp))) { 474 | if_exp = scm_make_if(scm_clause_test(SCM_CAR(exp)), it_clause_actions(exp), scm_void); 475 | if (head != NULL) 476 | SCM_CDR(prev) = SCM_LIST1(if_exp); 477 | else 478 | head = if_exp; 479 | prev = SCM_CDDR(if_exp); 480 | } else { 481 | if (!SCM_NULLP(SCM_CDR(exp))) { 482 | scm_print_error("cond: bad syntax (`else' clause must be last) "); 483 | scm_print_error(" in: "); 484 | scm_write(scm_stdout_port, SCM_CAR(exp)); 485 | scm_print_error("\n"); 486 | scm_throw_eval_error(); 487 | } 488 | if (head != NULL) 489 | SCM_CDR(prev) = SCM_LIST1(it_clause_actions(exp)); 490 | else { 491 | head = it_clause_actions(exp); 492 | } 493 | } 494 | } 495 | 496 | return head; 497 | } 498 | 499 | static scm_object* case_to_cond(scm_object *exp) 500 | { 501 | if (SCM_NULLP(SCM_CDR(exp))) { 502 | scm_print_error("case: bad syntax \n"); 503 | scm_throw_eval_error(); 504 | } 505 | if (SCM_NULLP(SCM_CDDR(exp))) 506 | return scm_void; 507 | 508 | scm_pair cond_clauses; 509 | scm_object *prev = (scm_object *)&cond_clauses; 510 | scm_object *temp_var = scm_gen_symbol(); 511 | int haselse = 0; 512 | // map clauses 513 | scm_object *clauses = scm_case_clauses(exp); 514 | scm_list_for_each(clauses) { 515 | if (!scm_is_else_clause(SCM_CAR(clauses))) { 516 | prev = SCM_CDR(prev) = 517 | SCM_LIST1( 518 | SCM_LCONS( 519 | scm_make_app( 520 | scm_memv_symbol, 521 | SCM_LIST2( 522 | temp_var, 523 | scm_make_quotation(scm_clause_test(SCM_CAR(clauses))))), 524 | scm_clause_actions(SCM_CAR(clauses)))); 525 | } else { 526 | if (!SCM_NULLP(SCM_CDR(clauses))) { 527 | scm_print_error("case: bad syntax \n"); 528 | scm_throw_eval_error(); 529 | } 530 | SCM_CDR(prev) = SCM_CAR(clauses); 531 | haselse = 1; 532 | } 533 | } 534 | 535 | scm_object *body = scm_null; 536 | if (prev != (scm_object *)&cond_clauses) { // 有非else clauses 537 | body = scm_make_cond(SCM_CDR(&cond_clauses)); 538 | } else if (haselse) { // only else clause 539 | body = scm_sequence_exp(scm_clause_actions(SCM_CDR(&cond_clauses))); 540 | scm_write(scm_stdout_port, body); 541 | } 542 | 543 | return scm_make_let( 544 | SCM_LIST1(SCM_LIST2(temp_var, scm_case_key(exp))), 545 | body); 546 | } 547 | 548 | #define GEN_INCDEC_TRANS(name, fname, op) \ 549 | static scm_object* name(scm_object *exp) \ 550 | { \ 551 | scm_object *var = SCM_CADR(exp); \ 552 | if (!SCM_SYMBOLP(var)) { \ 553 | scm_print_error(fname": bad syntax \n"); \ 554 | scm_throw_eval_error(); \ 555 | } \ 556 | return scm_make_begin( \ 557 | SCM_LIST2( \ 558 | scm_make_app(scm_assignment_symbol, \ 559 | SCM_LIST2(var, \ 560 | scm_make_app(op, SCM_LIST2(var, scm_make_integer(1))))), \ 561 | var)); \ 562 | } 563 | GEN_INCDEC_TRANS(scm_inc_assign_to_more_prim, "inc!", scm_plus_symbol); 564 | GEN_INCDEC_TRANS(scm_dec_assign_to_more_prim, "dec!", scm_minus_symbol); 565 | 566 | static scm_object* do_to_more_prim(scm_object *exp) 567 | { 568 | scm_object *bindings = scm_do_bindings(exp); 569 | scm_pair let_bindings_head; 570 | scm_object *bind_prev = (scm_object *)&let_bindings_head; 571 | scm_pair steps_head; 572 | scm_object *step_prev = (scm_object *)&steps_head; 573 | // pluck bindings (var, init), steps 574 | scm_list_for_each(bindings) { 575 | bind_prev = SCM_CDR(bind_prev) = SCM_LIST1(SCM_LIST2(SCM_CAAR(bindings), SCM_CADAR(bindings))); 576 | step_prev = SCM_CDR(step_prev) = SCM_LIST1(SCM_CADDAR(bindings)); 577 | } 578 | scm_object *let_bindings = bind_prev != (scm_object *)&let_bindings_head ? 579 | SCM_CDR(&let_bindings_head) : scm_null; 580 | scm_object *steps = step_prev != (scm_object *)&steps_head ? 581 | SCM_CDR(&steps_head) : scm_null; 582 | 583 | scm_object *var = scm_gen_symbol(); 584 | 585 | return scm_make_named_let( 586 | var, 587 | let_bindings, 588 | scm_make_if( 589 | scm_do_test(exp), 590 | scm_sequence_exp(scm_do_actions(exp)), 591 | scm_sequence_exp( 592 | scm_append_list2(scm_do_commands(exp), SCM_LIST1(scm_make_app(var, steps)))))); 593 | } 594 | 595 | static scm_object* while_to_more_prim(scm_object *exp) 596 | { 597 | scm_object *var = scm_gen_symbol(); 598 | 599 | return scm_make_named_let( 600 | var, 601 | scm_null, 602 | scm_make_when( 603 | scm_while_test(exp), 604 | scm_append_list2( 605 | scm_while_body(exp), 606 | SCM_LIST1(scm_make_app0(var))))); 607 | } 608 | 609 | static scm_object* for_to_more_prim(scm_object *exp) 610 | { 611 | scm_object *var = scm_for_var(exp); 612 | scm_object *list = scm_for_list(exp); 613 | scm_object *loop_var = scm_gen_symbol(); 614 | 615 | return scm_make_named_let( 616 | loop_var, 617 | SCM_LIST1(SCM_LIST2(var, scm_for_list_start(list))), 618 | scm_make_when( 619 | scm_make_app(scm_lt_symbol, SCM_LIST2(var, scm_for_list_end(list))), 620 | scm_append_list2( 621 | scm_for_body(exp), 622 | SCM_LIST1( 623 | scm_make_app( 624 | loop_var, 625 | SCM_LIST1( 626 | scm_make_app( 627 | scm_plus_symbol, 628 | SCM_LIST2(var, scm_make_integer(1))))))))); 629 | } 630 | --------------------------------------------------------------------------------