conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'upstream/master' into native-record 

Conflicts:
	include/picrin/value.h
	piclib/prelude.scm
	src/codegen.c
	src/gc.c
	src/init.c
	src/macro.c
	src/vm.c
	src/write.c
This commit is contained in:
Yuito Murase 2014-08-03 15:48:24 +09:00
parent c76dfcb861 c2982a4252
commit fa0de0c3fa
49 changed files with 1344 additions and 1168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CMakeLists.txt
View File

@ -16,7 +16,7 @@ execute_process(
set(CMAKE_RUNTIME_OUTPUT_DIRECTORY bin)
set(CMAKE_LIBRARY_OUTPUT_DIRECTORY lib)
set(CMAKE_C_FLAGS "-Wall -Wextra")
set(CMAKE_C_FLAGS "-O2 -Wall -Wextra")
set(CMAKE_C_FLAGS_DEBUG "-g -DDEBUG=1")
option(USE_C11_FEATURE "Enable c11 feature" OFF)

2
contrib/10.regexp/src/regexp.c
View File

@ -182,7 +182,7 @@ pic_regexp_regexp_replace(pic_state *pic)
void
pic_init_regexp(pic_state *pic)
{
pic_deflibrary ("(picrin regexp)") {
pic_deflibrary (pic, "(picrin regexp)") {
pic_defun(pic, "regexp", pic_regexp_regexp);
pic_defun(pic, "regexp?", pic_regexp_regexp_p);
pic_defun(pic, "regexp-match", pic_regexp_regexp_match);

21
docs/lang.rst
View File

@ -19,6 +19,7 @@ At the REPL start-up time, some usuful built-in libraries listed below will be a
- ``(scheme time)``
- ``(scheme case-lambda)``
- ``(scheme read)``
- ``(scheme eval)``
Compliance with R7RS
---------------------
@ -45,22 +46,22 @@ section status comments
4.2.2 Binding constructs yes
4.2.3 Sequencing yes
4.2.4 Iteration yes
4.2.5 Delayed evaluation N/A
4.2.5 Delayed evaluation yes
4.2.6 Dynamic bindings yes
4.2.7 Exception handling no ``guard`` syntax.
4.2.7 Exception handling yes ``guard`` syntax.
4.2.8 Quasiquotation yes can be safely nested. TODO: multiple argument for unquote
4.2.9 Case-lambda N/A
4.3.1 Bindings constructs for syntactic keywords incomplete [#]_
4.2.9 Case-lambda yes
4.3.1 Bindings constructs for syntactic keywords yes [#]_
4.3.2 Pattern language yes ``syntax-rules``
4.3.3 Signaling errors in macro transformers yes
5.1 Programs yes
5.2 Import declarations incomplete only simple import declarations, no support for import with renaming.
5.2 Import declarations yes
5.3.1 Top level definitions yes
5.3.2 Internal definitions yes TODO: interreferential definitions
5.3.3 Multiple-value definitions yes
5.4 Syntax definitions yes
5.5 Recored-type definitions yes
5.6.1 Library Syntax incomplete In picrin, libraries can be reopend and can be nested.
5.6.1 Library Syntax yes In picrin, libraries can be reopend and can be nested.
5.6.2 Library example N/A
5.7 The REPL yes
6.1 Equivalence predicates yes
@ -70,7 +71,7 @@ section status comments
6.2.4 Implementation extensions yes
6.2.5 Syntax of numerical constants yes
6.2.6 Numerical operations yes ``denominator``, ``numerator``, and ``rationalize`` are not supported for now. Also, picrin does not provide complex library procedures.
6.2.7 Numerical input and output incomplete only partial support supplied.
6.2.7 Numerical input and output yes
6.3 Booleans yes
6.4 Pairs and lists yes ``list?`` is safe for using against circular list.
6.5 Symbols yes
@ -79,12 +80,12 @@ section status comments
6.8 Vectors yes
6.9 Bytevectors yes
6.10 Control features yes
6.11 Exceptions yes ``raise-continuable`` is not supported
6.12 Environments and evaluation N/A
6.11 Exceptions yes
6.12 Environments and evaluation yes
6.13.1 Ports yes
6.13.2 Input yes
6.13.3 Output yes
6.14 System interface yes
================================================ ========== ==========================================================================================================================
.. [#] Picrin provides hygienic macros in addition to so-called legacy macro (``define-macro``), such as syntactic closure, explicit renaming macro, and implicit renaming macro. As of now let-syntax and letrec-syntax are not provided.
.. [#] Picrin provides hygienic macros in addition to so-called legacy macro (``define-macro``), such as syntactic closure, explicit renaming macro, and implicit renaming macro.

2
docs/libs.rst
View File

@ -49,6 +49,7 @@ Utility functions and syntaces for macro definition.
- define-macro
- gensym
- ungensym
- macroexpand
- macroexpand-1
@ -68,6 +69,7 @@ Syntactic closures.
- er-macro-transformer
- ir-macro-transformer
- strip-syntax
Explicit renaming macro family.

2
extlib/xfile

@ -1 +1 @@
Subproject commit 45cad164afcd0ad3f83286f39ae947c0e595c077
Subproject commit e9d634ff99d1a954af3fa80dc2f2ccb1227b4a2b

2
extlib/xhash

@ -1 +1 @@
Subproject commit ddc2ea288b37b3f5de37024ff2648d11aa18811a
Subproject commit 0b5f935aa7a236f1ef1787f81dce7f5ba679e95b

36
include/picrin.h
View File

@ -57,18 +57,11 @@ typedef struct {
struct pic_env *up;
} pic_callinfo;
typedef struct pic_block {
struct pic_block *prev;
int depth;
struct pic_proc *in, *out;
unsigned refcnt;
} pic_block;
typedef struct {
int argc;
char **argv, **envp;
pic_block *blk;
struct pic_block *blk;
pic_value *sp;
pic_value *stbase, *stend;
@ -78,6 +71,8 @@ typedef struct {
pic_code *ip;
struct pic_lib *lib;
pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
pic_sym sDEFINE_SYNTAX;
@ -95,20 +90,17 @@ typedef struct {
int sym_cnt;
int uniq_sym_cnt;
xhash global_tbl;
pic_value *globals;
size_t glen, gcapa;
xhash globals;
xhash macros;
pic_value libs;
pic_value lib_tbl;
struct pic_lib *lib;
bool rfcase;
xhash rlabels;
jmp_buf *jmp;
struct pic_error *err;
struct pic_jmpbuf *try_jmps;
size_t try_jmp_size, try_jmp_idx;
struct pic_heap *heap;
struct pic_object **arena;
@ -151,7 +143,6 @@ pic_value pic_funcall(pic_state *pic, const char *name, pic_list args);
struct pic_proc *pic_get_proc(pic_state *);
int pic_get_args(pic_state *, const char *, ...);
void pic_defun(pic_state *, const char *, pic_func_t);
void pic_defmacro(pic_state *, const char *, struct pic_proc *);
bool pic_equal_p(pic_state *, pic_value, pic_value);
@ -159,6 +150,7 @@ pic_sym pic_intern(pic_state *, const char *, size_t);
pic_sym pic_intern_cstr(pic_state *, const char *);
const char *pic_symbol_name(pic_state *, pic_sym);
pic_sym pic_gensym(pic_state *, pic_sym);
pic_sym pic_ungensym(pic_state *, pic_sym);
bool pic_interned_p(pic_state *, pic_sym);
char *pic_strdup(pic_state *, const char *);
@ -180,17 +172,17 @@ pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_v
pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value);
pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value);
pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value);
pic_value pic_eval(pic_state *, pic_value);
struct pic_proc *pic_compile(pic_state *, pic_value);
pic_value pic_macroexpand(pic_state *, pic_value);
pic_value pic_eval(pic_state *, pic_value, struct pic_lib *);
struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *);
pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *);
void pic_in_library(pic_state *, pic_value);
struct pic_lib *pic_make_library(pic_state *, pic_value);
struct pic_lib *pic_find_library(pic_state *, pic_value);
#define pic_deflibrary(spec) \
pic_deflibrary_helper__(GENSYM(i), GENSYM(prev_lib), spec)
#define pic_deflibrary_helper__(i, prev_lib, spec) \
#define pic_deflibrary(pic, spec) \
pic_deflibrary_helper__(pic, GENSYM(i), GENSYM(prev_lib), spec)
#define pic_deflibrary_helper__(pic, i, prev_lib, spec) \
for (int i = 0; ! i; ) \
for (struct pic_lib *prev_lib; ! i; ) \
for ((prev_lib = pic->lib), pic_make_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib)

6
include/picrin/config.h
View File

@ -26,8 +26,6 @@
/* #define PIC_RESCUE_SIZE 30 */
/* #define PIC_GLOBALS_SIZE 1024 */
/* #define PIC_SYM_POOL_SIZE 128 */
/* #define PIC_IREP_SIZE 8 */
@ -93,10 +91,6 @@
# define PIC_RESCUE_SIZE 30
#endif
#ifndef PIC_GLOBALS_SIZE
# define PIC_GLOBALS_SIZE 1024
#endif
#ifndef PIC_SYM_POOL_SIZE
# define PIC_SYM_POOL_SIZE 128
#endif

40
include/picrin/cont.h
View File

@ -9,11 +9,18 @@
extern "C" {
#endif
struct pic_block {
PIC_OBJECT_HEADER
struct pic_block *prev;
int depth;
struct pic_proc *in, *out;
};
struct pic_cont {
PIC_OBJECT_HEADER
jmp_buf jmp;
pic_block *blk;
struct pic_block *blk;
char *stk_pos, *stk_ptr;
ptrdiff_t stk_len;
@ -30,37 +37,12 @@ struct pic_cont {
size_t arena_size;
int arena_idx;
struct pic_jmpbuf *try_jmps;
size_t try_jmp_idx, try_jmp_size;
pic_value results;
};
#define PIC_BLK_INCREF(pic,blk) do { \
(blk)->refcnt++; \
} while (0)
#define PIC_BLK_DECREF(pic,blk) do { \
pic_block *_a = (blk), *_b; \
while (_a) { \
if (! --_a->refcnt) { \
_b = _a->prev; \
pic_free((pic), _a); \
_a = _b; \
} else { \
break; \
} \
} \
} while (0)
#define PIC_BLK_EXIT(pic) do { \
pic_block *_a; \
while (pic->blk) { \
if (pic->blk->out) \
pic_apply0(pic, pic->blk->out); \
_a = pic->blk->prev; \
PIC_BLK_DECREF(pic, pic->blk); \
pic->blk = _a; \
} \
} while (0)
pic_value pic_values0(pic_state *);
pic_value pic_values1(pic_state *, pic_value);
pic_value pic_values2(pic_state *, pic_value, pic_value);

12
include/picrin/error.h
View File

@ -11,17 +11,19 @@ extern "C" {
struct pic_jmpbuf {
jmp_buf here;
pic_callinfo *ci;
pic_value *sp;
struct pic_proc *handler;
ptrdiff_t ci_offset;
ptrdiff_t sp_offset;
pic_code *ip;
jmp_buf *prev_jmp;
struct pic_jmpbuf *prev;
};
/* do not return from try block! */
#define pic_try \
pic_push_try(pic); \
pic_try_with_handler(NULL)
#define pic_try_with_handler(handler) \
pic_push_try(pic, handler); \
if (setjmp(*pic->jmp) == 0) \
do
#define pic_catch \
@ -29,7 +31,7 @@ struct pic_jmpbuf {
else \
if (pic_pop_try(pic), 1)
void pic_push_try(pic_state *);
void pic_push_try(pic_state *, struct pic_proc *);
void pic_pop_try(pic_state *);
noreturn void pic_throw(pic_state *, short, const char *, pic_value);

7
include/picrin/value.h
View File

@ -13,7 +13,7 @@ extern "C" {
* pic_sym is just an alias to unsigned int.
*/
typedef unsigned pic_sym;
typedef int pic_sym;
/**
* `undef` values never seen from user-end: that is,
@ -116,7 +116,8 @@ enum pic_tt {
PIC_TT_IREP,
PIC_TT_DATA,
PIC_TT_DICT,
PIC_TT_RECORD
PIC_TT_RECORD,
PIC_TT_BLK,
};
#define PIC_OBJECT_HEADER \
@ -271,6 +272,8 @@ pic_type_repr(enum pic_tt tt)
return "dict";
case PIC_TT_RECORD:
return "record";
case PIC_TT_BLK:
return "block";
}
UNREACHABLE();
}

6
piclib/CMakeLists.txt
View File

@ -8,6 +8,9 @@ list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/eval.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm
@ -15,4 +18,7 @@ list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/95.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/111.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/user.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/repl.scm
)

13
piclib/picrin/macro.scm
View File

@ -20,7 +20,7 @@
expr)))))
(define (memoize f)
"memoize on a symbol"
"memoize on symbols"
(define cache (make-dictionary))
(lambda (sym)
(if (dictionary-has? cache sym)
@ -30,6 +30,10 @@
(dictionary-set! cache sym val)
val))))
(define (identifier=? env1 sym1 env2 sym2)
(eq? (make-identifier sym1 env1)
(make-identifier sym2 env2)))
(define (make-syntactic-closure env free form)
(define resolve
@ -106,6 +110,9 @@
(rename sym)))
(f (walk inject expr) inject compare))))
(define (strip-syntax form)
(walk ungensym form))
(define-syntax define-macro
(er-macro-transformer
(lambda (expr r c)
@ -120,11 +127,13 @@
(cons (cdr formal)
body)))))))
(export make-syntactic-closure
(export identifier=?
make-syntactic-closure
close-syntax
capture-syntactic-environment
sc-macro-transformer
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer
strip-syntax
define-macro))

86
piclib/picrin/repl.scm Normal file
View File

@ -0,0 +1,86 @@
(define-library (picrin repl)
(import (scheme base)
(scheme read)
(scheme file)
(scheme write)
(scheme eval)
(scheme process-context))
(define (join sep strs)
(let loop ((result (car strs)) (rest (cdr strs)))
(if (null? rest)
result
(loop (string-append result sep (car rest)) (cdr rest)))))
(define (file->string file)
(with-input-from-file file
(lambda ()
(let loop ((line (read-line)) (acc '()))
(if (eof-object? line)
(join "\n" (reverse acc))
(loop (read-line) (cons line acc)))))))
(define (print obj . port)
(let ((port (if (null? port) (current-output-port) (car port))))
(write obj port)
(newline port)
obj))
(define (print-help)
(display "picrin scheme\n")
(display "\n")
(display "Usage: picrin [options] [file]\n")
(display "\n")
(display "Options:\n")
(display " -e [program] run one liner script\n")
(display " -h or --help show this help\n"))
(define (getopt)
(let ((args (cdr (command-line))))
(if (null? args)
#f
(case (string->symbol (car args))
((-h --help)
(print-help)
(exit 1))
((-e)
(cadr args))
(else
(file->string (car args)))))))
(define (main-loop in out on-err)
(display "> " out)
(let ((expr (read in)))
(if (eof-object? expr)
(newline out) ; exit
(begin
(call/cc
(lambda (leave)
(with-exception-handler
(lambda (condition)
(display (error-object-message condition) (current-error-port))
(newline)
(if on-err
(on-err)
(leave)))
(lambda ()
(print (eval expr '(picrin user)) out)))))
(main-loop in out on-err)))))
(define (run-repl program)
(let ((in (if program
(open-input-string program)
(current-input-port)))
(out (if program
(open-output-string) ; ignore output
(current-output-port)))
(on-err (if program
(lambda () (exit 1))
#f)))
(main-loop in out on-err)))
(define (repl)
(let ((program (getopt)))
(run-repl program)))
(export repl))

19
piclib/picrin/test.scm
View File

@ -24,7 +24,7 @@
(for-each
(lambda (fail)
(display fail))
fails))
(reverse fails)))
(define (test-begin . o)
(set! test-counter (+ test-counter 1)))
@ -83,19 +83,4 @@
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
(define-syntax test-numeric-syntax
(syntax-rules ()
((test-numeric-syntax str expect strs ...)
(let* ((z (read (open-input-string str)))
(out (open-output-string))
(z-str (begin (write z out) (get-output-string out))))
(test expect (values z))
(test #t (and (member z-str '(str strs ...)) #t))))))
;; (define (test-read-error str)
;; (test-assert
;; (guard (exn (else #t))
;; (read (open-input-string str))
;; #f)))
(export test test-begin test-end test-values test-exit test-syntax-error test-numeric-syntax)
)
(export test test-begin test-end test-values test-exit test-syntax-error))

14
piclib/picrin/user.scm Normal file
View File

@ -0,0 +1,14 @@
; the default repl environment
(define-library (picrin user)
(import (scheme base)
(scheme load)
(scheme process-context)
(scheme read)
(scheme write)
(scheme file)
(scheme inexact)
(scheme cxr)
(scheme lazy)
(scheme time)
(picrin macro)))

125
piclib/prelude.scm
View File

@ -145,19 +145,6 @@
(let ((x (cadr form)))
(qq 1 x)))))
#;
(define-syntax let*
(ir-macro-transformer
(lambda (form inject compare)
(let ((bindings (cadr form))
(body (cddr form)))
(if (null? bindings)
`(let () ,@body)
`(let ((,(caar bindings)
,@(cdar bindings)))
(let* (,@(cdr bindings))
,@body)))))))
(define-syntax let*
(er-macro-transformer
(lambda (form r compare)
@ -375,18 +362,6 @@
(import (scheme base)
(picrin macro))
(define-syntax with
(ir-macro-transformer
(lambda (form inject compare)
(let ((before (car (cdr form)))
(after (car (cdr (cdr form))))
(body (cdr (cdr (cdr form)))))
`(begin
(,before)
(let ((result (begin ,@body)))
(,after)
result))))))
(define-syntax parameterize
(ir-macro-transformer
(lambda (form inject compare)
@ -394,12 +369,11 @@
(body (cdr (cdr form))))
(let ((vars (map car formal))
(vals (map cadr formal)))
`(with
(lambda ()
,@(map (lambda (var val) `(parameter-push! ,var ,val)) vars vals))
(lambda ()
,@(map (lambda (var) `(parameter-pop! ,var)) vars))
,@body))))))
`(begin
,@(map (lambda (var val) `(parameter-push! ,var ,val)) vars vals)
(let ((result (begin ,@body)))
,@(map (lambda (var) `(parameter-pop! ,var)) vars)
result)))))))
(export parameterize))
@ -486,11 +460,6 @@
(export define-record-type)
(define (fold f s xs)
(if (null? xs)
s
(fold f (f (car xs) s) (cdr xs))))
;;; 6.6 Characters
(define-macro (define-char-transitive-predicate name op)
@ -551,24 +520,24 @@
;;; 6.9 bytevector
(define (bytevector . objs)
(let ((len (length objs)))
(define (bytevector->list v start end)
(do ((i start (+ i 1))
(res '()))
((= i end)
(reverse res))
(set! res (cons (bytevector-u8-ref v i) res))))
(define (list->bytevector list)
(let ((len (length list)))
(let ((v (make-bytevector len)))
(do ((i 0 (+ i 1))
(l objs (cdr l)))
(l list (cdr l)))
((= i len)
v)
(bytevector-u8-set! v i (car l))))))
(define (bytevector->list v start end)
(do ((i start (+ i 1))
(res '()))
((= i end)
(reverse res))
(set! res (cons (bytevector-u8-ref v i) res))))
(define (list->bytevector v)
(apply bytevector v))
(define (bytevector . objs)
(list->bytevector objs))
(define (utf8->string v . opts)
(let ((start (if (pair? opts) (car opts) 0))
@ -942,3 +911,63 @@
(import (picrin syntax-rules))
(export syntax-rules)
(define-syntax guard-aux
(syntax-rules (else =>)
((guard-aux reraise (else result1 result2 ...))
(begin result1 result2 ...))
((guard-aux reraise (test => result))
(let ((temp test))
(if temp
(result temp)
reraise)))
((guard-aux reraise (test => result)
clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test))
(or test reraise))
((guard-aux reraise (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(guard-aux reraise clause1 clause2 ...))))
((guard-aux reraise (test result1 result2 ...))
(if test
(begin result1 result2 ...)
reraise))
((guard-aux reraise
(test result1 result2 ...)
clause1 clause2 ...)
(if test
(begin result1 result2 ...)
(guard-aux reraise clause1 clause2 ...)))))
(define-syntax guard
(syntax-rules ()
((guard (var clause ...) e1 e2 ...)
((call/cc
(lambda (guard-k)
(with-exception-handler
(lambda (condition)
((call/cc
(lambda (handler-k)
(guard-k
(lambda ()
(let ((var condition))
(guard-aux
(handler-k
(lambda ()
(raise-continuable condition)))
clause ...))))))))
(lambda ()
(call-with-values
(lambda () e1 e2 ...)
(lambda args
(guard-k
(lambda ()
(apply values args)))))))))))))
(export guard)

29
piclib/scheme/eval.scm Normal file
View File

@ -0,0 +1,29 @@
(define-library (scheme eval)
(import (scheme base))
(define (null-environment n)
(if (not (= n 5))
(error "unsupported environment version" n)
'(scheme null)))
(define (scheme-report-environment n)
(if (not (= n 5))
(error "unsupported environment version" n)
'(scheme r5rs)))
(define environment
(let ((counter 0))
(lambda specs
(let ((library-name `(picrin @@my-environment ,counter)))
(set! counter (+ counter 1))
(eval
`(define-library ,library-name
,@(map (lambda (spec)
`(import ,spec))
specs))
'(scheme base))
library-name))))
(export null-environment
scheme-report-environment
environment))

16
piclib/scheme/file.scm
View File

@ -7,5 +7,19 @@
(define (call-with-output-file filename callback)
(call-with-port (open-output-file filename) callback))
(define (with-input-from-file filename thunk)
(call-with-input-file filename
(lambda (port)
(parameterize ((current-input-port port))
(thunk)))))
(define (with-output-to-file filename thunk)
(call-with-output-file filename
(lambda (port)
(parameterize ((current-output-port port))
(thunk)))))
(export call-with-input-file
call-with-output-file))
call-with-output-file
with-input-from-file
with-output-to-file))

12
piclib/scheme/null.scm Normal file
View File

@ -0,0 +1,12 @@
(define-library (scheme null)
(import (scheme base))
(export define
lambda
if
quote
quasiquote
unquote
unquote-splicing
begin
set!
define-syntax))

118
piclib/scheme/r5rs.scm Normal file
View File

@ -0,0 +1,118 @@
(define-library (scheme r5rs)
(import (scheme base)
(scheme inexact)
(scheme write)
(scheme read)
(scheme file)
(scheme cxr)
(scheme lazy)
(scheme eval)
(scheme load))
(export * + - / < <= = > >=
abs acos and
;; angle
append apply asin assoc assq assv atan
begin boolean?
caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
call-with-current-continuation
call-with-input-file
call-with-output-file
call-with-values
car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr
ceiling
;; char->integer char-alphabetic? char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char<? char=? char>=? char>? char?
close-input-port close-output-port complex? cond cons cos current-input-port current-output-port
define define-syntax delay
;; denominator
display do dynamic-wind
eof-object? eq? equal? eqv? eval even?
(rename inexact exact->inexact)
exact? exp expt
floor for-each force
gcd
if
;; imag-part
(rename exact inexact->exact)
inexact? input-port? integer->char integer?
;; interaction-environment
lambda lcm length let
peek-char procedure?
quote
rational? read
;; real-part
remainder round
scheme-report-environment
set! set-cdr! sqrt string->list string->symbol
;; string-ci<=? string-ci=? string-ci>?
string-fill! string-ref string<=? string=? string>? substring symbol?
truncate
vector vector-fill! vector-ref vector? with-output-to-file write-char
output-port?
let-syntax
letrec-syntax
list->string
list-ref
list?
log
;; make-polar
make-string
map
member
memv
modulo
newline
null-environment
number->string
;; numerator
open-input-file
or
pair?
positive?
quasiquote
quotient
;; rationalize
read-char
real?
reverse
let*
letrec
list
list->vector
list-tail
load
;; magnitude
;; make-rectangular
make-vector
max
memq
min
negative?
not
null?
number?
odd?
open-output-file
set-car!
sin
string
string->number
string-append
;; string-ci<?
;; string-ci>=?
string-copy
string-length
string-set!
string<?
string>=?
string?
symbol->string
tan
values
vector->list
vector-length
vector-set!
with-input-from-file
write
zero?
))

4
src/bool.c
View File

@ -42,10 +42,10 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
pic_errorf(pic, "Stack overflow in equal\n");
}
if (pic_pair_p(x) || pic_vec_p(x)) {
if (xh_get(ht, pic_obj_ptr(x)) != NULL) {
if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) {
return true; /* `x' was seen already. */
} else {
xh_put(ht, pic_obj_ptr(x), NULL);
xh_put_ptr(ht, pic_obj_ptr(x), NULL);
}
}
}

23
src/codegen.c
View File

@ -100,7 +100,7 @@ new_analyze_state(pic_state *pic)
/* push initial scope */
push_scope(state, pic_nil_value());
xh_begin(&it, &pic->global_tbl);
xh_begin(&it, &pic->globals);
while (xh_next(&it)) {
pic_sym sym = xh_key(it.e, pic_sym);
xv_push(&state->scope->locals, &sym);
@ -291,20 +291,8 @@ static pic_value
analyze_global_var(analyze_state *state, pic_sym sym)
{
pic_state *pic = state->pic;
xh_entry *e;
size_t i;
if ((e = xh_get_int(&pic->global_tbl, sym))) {
i = xh_val(e, size_t);
}
else {
i = pic->glen++;
if (i >= pic->gcapa) {
pic_error(pic, "global table overflow");
}
xh_put_int(&pic->global_tbl, sym, &i);
}
return pic_list2(pic, pic_symbol_value(state->sGREF), pic_int_value(i));
return pic_list2(pic, pic_symbol_value(state->sGREF), pic_sym_value(sym));
}
static pic_value
@ -832,6 +820,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
case PIC_TT_DATA:
case PIC_TT_DICT:
case PIC_TT_RECORD:
case PIC_TT_BLK:
pic_errorf(pic, "invalid expression given: ~s", obj);
}
UNREACHABLE();
@ -1096,7 +1085,7 @@ codegen(codegen_state *state, pic_value obj)
sym = pic_sym(pic_car(pic, obj));
if (sym == state->sGREF) {
cxt->code[cxt->clen].insn = OP_GREF;
cxt->code[cxt->clen].u.i = pic_int(pic_list_ref(pic, obj, 1));
cxt->code[cxt->clen].u.i = pic_sym(pic_list_ref(pic, obj, 1));
cxt->clen++;
return;
} else if (sym == state->sCREF) {
@ -1442,7 +1431,7 @@ pic_codegen(pic_state *pic, pic_value obj)
}
struct pic_proc *
pic_compile(pic_state *pic, pic_value obj)
pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib)
{
struct pic_irep *irep;
size_t ai = pic_gc_arena_preserve(pic);
@ -1458,7 +1447,7 @@ pic_compile(pic_state *pic, pic_value obj)
#endif
/* macroexpand */
obj = pic_macroexpand(pic, obj);
obj = pic_macroexpand(pic, obj, lib);
#if DEBUG
fprintf(stdout, "## macroexpand completed\n");
pic_debug(pic, obj);

28
src/cont.c
View File

@ -10,6 +10,7 @@
#include "picrin/proc.h"
#include "picrin/cont.h"
#include "picrin/pair.h"
#include "picrin/error.h"
pic_value
pic_values0(pic_state *pic)
@ -118,7 +119,6 @@ save_cont(pic_state *pic, struct pic_cont **c)
cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT);
cont->blk = pic->blk;
PIC_BLK_INCREF(pic, cont->blk);
cont->stk_len = native_stack_length(pic, &pos);
cont->stk_pos = pos;
@ -143,6 +143,11 @@ save_cont(pic_state *pic, struct pic_cont **c)
cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size);
memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
cont->try_jmp_idx = pic->try_jmp_idx;
cont->try_jmp_size = pic->try_jmp_size;
cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
cont->results = pic_undef_value();
}
@ -158,8 +163,12 @@ native_stack_extend(pic_state *pic, struct pic_cont *cont)
noreturn static void
restore_cont(pic_state *pic, struct pic_cont *cont)
{
void pic_vm_tear_off(pic_state *);
char v;
struct pic_cont *tmp = cont;
struct pic_block *blk;
pic_vm_tear_off(pic); /* tear off */
if (&v < pic->native_stack_start) {
if (&v > cont->stk_pos) native_stack_extend(pic, cont);
@ -168,8 +177,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
}
PIC_BLK_DECREF(pic, pic->blk);
PIC_BLK_INCREF(pic, cont->blk);
blk = pic->blk;
pic->blk = cont->blk;
pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
@ -189,13 +197,18 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
pic->arena_size = cont->arena_size;
pic->arena_idx = cont->arena_idx;
pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
pic->try_jmp_size = cont->try_jmp_size;
pic->try_jmp_idx = cont->try_jmp_idx;
memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len);
longjmp(tmp->jmp, 1);
}
static void
walk_to_block(pic_state *pic, pic_block *here, pic_block *there)
walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there)
{
if (here == there)
return;
@ -213,7 +226,7 @@ walk_to_block(pic_state *pic, pic_block *here, pic_block *there)
static pic_value
pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
{
pic_block *here;
struct pic_block *here;
pic_value val;
if (in != NULL) {
@ -221,17 +234,14 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
}
here = pic->blk;
pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block));
pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
pic->blk->prev = here;
pic->blk->depth = here->depth + 1;
pic->blk->in = in;
pic->blk->out = out;
pic->blk->refcnt = 1;
PIC_BLK_INCREF(pic, here);
val = pic_apply0(pic, thunk);
PIC_BLK_DECREF(pic, pic->blk);
pic->blk = here;
if (out != NULL) {

2
src/dict.c
View File

@ -163,7 +163,7 @@ pic_dict_dict_for_each(pic_state *pic)
void
pic_init_dict(pic_state *pic)
{
pic_deflibrary ("(picrin dictionary)") {
pic_deflibrary (pic, "(picrin dictionary)") {
pic_defun(pic, "make-dictionary", pic_dict_dict);
pic_defun(pic, "dictionary?", pic_dict_dict_p);
pic_defun(pic, "dictionary-has?", pic_dict_dict_has_p);

71
src/error.c
View File

@ -34,39 +34,41 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
}
void
pic_push_try(pic_state *pic)
pic_push_try(pic_state *pic, struct pic_proc *handler)
{
struct pic_jmpbuf *try_jmp;
try_jmp = pic_alloc(pic, sizeof(struct pic_jmpbuf));
if (pic->try_jmp_idx >= pic->try_jmp_size) {
pic->try_jmp_size *= 2;
pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
}
try_jmp->ci = pic->ci;
try_jmp->sp = pic->sp;
try_jmp = pic->try_jmps + pic->try_jmp_idx++;
try_jmp->handler = handler;
try_jmp->ci_offset = pic->ci - pic->cibase;
try_jmp->sp_offset = pic->sp - pic->stbase;
try_jmp->ip = pic->ip;
try_jmp->prev_jmp = pic->jmp;
pic->jmp = &try_jmp->here;
try_jmp->prev = pic->try_jmps;
pic->try_jmps = try_jmp;
}
void
pic_pop_try(pic_state *pic)
{
struct pic_jmpbuf *prev;
struct pic_jmpbuf *try_jmp;
assert(pic->jmp == &pic->try_jmps->here);
try_jmp = pic->try_jmps + --pic->try_jmp_idx;
pic->ci = pic->try_jmps->ci;
pic->sp = pic->try_jmps->sp;
pic->ip = pic->try_jmps->ip;
/* assert(pic->jmp == &try_jmp->here); */
pic->jmp = pic->try_jmps->prev_jmp;
pic->ci = try_jmp->ci_offset + pic->cibase;
pic->sp = try_jmp->sp_offset + pic->stbase;
pic->ip = try_jmp->ip;
prev = pic->try_jmps->prev;
pic_free(pic, pic->try_jmps);
pic->try_jmps = prev;
pic->jmp = try_jmp->prev_jmp;
}
static struct pic_error *
@ -89,11 +91,16 @@ error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
noreturn void
pic_throw_error(pic_state *pic, struct pic_error *e)
{
void pic_vm_tear_off(pic_state *);
pic_vm_tear_off(pic); /* tear off */
pic->err = e;
if (! pic->jmp) {
puts(pic_errmsg(pic));
abort();
}
longjmp(*pic->jmp, 1);
}
@ -140,14 +147,20 @@ pic_error_with_exception_handler(pic_state *pic)
pic_get_args(pic, "ll", &handler, &thunk);
pic_try {
pic_try_with_handler(handler) {
v = pic_apply0(pic, thunk);
}
pic_catch {
struct pic_error *e = pic->err;
pic->err = NULL;
v = pic_apply1(pic, handler, pic_obj_value(e));
if (e->type == PIC_ERROR_RAISED) {
v = pic_list_ref(pic, e->irrs, 0);
} else {
v = pic_obj_value(e);
}
v = pic_apply1(pic, handler, v);
pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e));
}
return v;
@ -163,6 +176,27 @@ pic_error_raise(pic_state *pic)
pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v));
}
static pic_value
pic_error_raise_continuable(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic->try_jmp_idx == 0) {
pic_errorf(pic, "no exception handler registered");
}
if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) {
pic_errorf(pic, "uncontinuable exception handler is on top");
}
else {
pic->try_jmp_idx--;
v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v);
++pic->try_jmp_idx;
}
return v;
}
noreturn static pic_value
pic_error_error(pic_state *pic)
{
@ -242,6 +276,7 @@ pic_init_error(pic_state *pic)
{
pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler);
pic_defun(pic, "raise", pic_error_raise);
pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
pic_defun(pic, "error", pic_error_error);
pic_defun(pic, "error-object?", pic_error_error_object_p);
pic_defun(pic, "error-object-message", pic_error_error_object_message);

39
src/eval.c Normal file
View File

@ -0,0 +1,39 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/macro.h"
pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
{
struct pic_proc *proc;
proc = pic_compile(pic, program, lib);
return pic_apply(pic, proc, pic_nil_value());
}
static pic_value
pic_eval_eval(pic_state *pic)
{
pic_value program, spec;
struct pic_lib *lib;
pic_get_args(pic, "oo", &program, &spec);
lib = pic_find_library(pic, spec);
if (lib == NULL) {
pic_errorf(pic, "no library found: ~s", spec);
}
return pic_eval(pic, program, lib);
}
void
pic_init_eval(pic_state *pic)
{
pic_deflibrary (pic, "(scheme eval)") {
pic_defun(pic, "eval", pic_eval_eval);
}
}

13
src/file.c
View File

@ -4,6 +4,13 @@
#include "picrin.h"
#include "picrin/port.h"
#include "picrin/error.h"
static noreturn void
file_error(pic_state *pic, const char *msg)
{
pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value());
}
static pic_value
generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
@ -13,7 +20,7 @@ generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
file = xfopen(fname, mode);
if (! file) {
pic_error(pic, "could not open file");
file_error(pic, "could not open file");
}
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
@ -93,7 +100,7 @@ pic_file_delete(pic_state *pic)
pic_get_args(pic, "z", &fname);
if (remove(fname) != 0) {
pic_error(pic, "file cannot be deleted");
file_error(pic, "file cannot be deleted");
}
return pic_none_value();
}
@ -101,7 +108,7 @@ pic_file_delete(pic_state *pic)
void
pic_init_file(pic_state *pic)
{
pic_deflibrary ("(scheme file)") {
pic_deflibrary (pic, "(scheme file)") {
pic_defun(pic, "open-input-file", pic_file_open_input_file);
pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file);
pic_defun(pic, "open-output-file", pic_file_open_output_file);

62
src/gc.c
View File

@ -323,18 +323,6 @@ gc_free(pic_state *pic, union header *bp)
static void gc_mark(pic_state *, pic_value);
static void gc_mark_object(pic_state *pic, struct pic_object *obj);
static void
gc_mark_block(pic_state *pic, pic_block *blk)
{
while (blk) {
if (blk->in)
gc_mark_object(pic, (struct pic_object *)blk->in);
if (blk->out)
gc_mark_object(pic, (struct pic_object *)blk->out);
blk = blk->prev;
}
}
static bool
gc_is_marked(union header *p)
{
@ -416,10 +404,10 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
struct pic_cont *cont = (struct pic_cont *)obj;
pic_value *stack;
pic_callinfo *ci;
int i;
size_t i;
/* block */
gc_mark_block(pic, cont->blk);
gc_mark_object(pic, (struct pic_object *)cont->blk);
/* stack */
for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) {
@ -434,10 +422,17 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
/* arena */
for (i = 0; i < cont->arena_idx; ++i) {
for (i = 0; i < (size_t)cont->arena_idx; ++i) {
gc_mark_object(pic, cont->arena[i]);
}
/* error handlers */
for (i = 0; i < cont->try_jmp_idx; ++i) {
if (cont->try_jmps[i].handler) {
gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler);
}
}
/* result values */
gc_mark(pic, cont->results);
break;
@ -518,6 +513,20 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
break;
}
case PIC_TT_BLK: {
struct pic_block *blk = (struct pic_block *)obj;
if (blk->prev) {
gc_mark_object(pic, (struct pic_object *)blk->prev);
}
if (blk->in) {
gc_mark_object(pic, (struct pic_object *)blk->in);
}
if (blk->out) {
gc_mark_object(pic, (struct pic_object *)blk->out);
}
break;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
@ -551,7 +560,9 @@ gc_mark_phase(pic_state *pic)
xh_iter it;
/* block */
gc_mark_block(pic, pic->blk);
if (pic->blk) {
gc_mark_object(pic, (struct pic_object *)pic->blk);
}
/* stack */
for (stack = pic->stbase; stack != pic->sp; ++stack) {
@ -576,8 +587,9 @@ gc_mark_phase(pic_state *pic)
}
/* global variables */
for (i = 0; i < pic->glen; ++i) {
gc_mark(pic, pic->globals[i]);
xh_begin(&it, &pic->globals);
while (xh_next(&it)) {
gc_mark(pic, xh_val(it.e, pic_value));
}
/* macro objects */
@ -586,8 +598,15 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, xh_val(it.e, struct pic_object *));
}
/* error handlers */
for (i = 0; i < pic->try_jmp_idx; ++i) {
if (pic->try_jmps[i].handler) {
gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler);
}
}
/* library table */
gc_mark(pic, pic->lib_tbl);
gc_mark(pic, pic->libs);
}
static void
@ -633,7 +652,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
pic_free(pic, cont->st_ptr);
pic_free(pic, cont->ci_ptr);
pic_free(pic, cont->arena);
PIC_BLK_DECREF(pic, cont->blk);
pic_free(pic, cont->try_jmps);
break;
}
case PIC_TT_SENV: {
@ -675,6 +694,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
xh_destroy(&rec->hash);
break;
}
case PIC_TT_BLK: {
break;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:

6
src/init.c
View File

@ -32,6 +32,8 @@ void pic_init_write(pic_state *);
void pic_init_read(pic_state *);
void pic_init_dict(pic_state *);
void pic_init_record(pic_state *);
void pic_init_eval(pic_state *);
void pic_init_lib(pic_state *);
void pic_init_contrib(pic_state *);
void pic_load_piclib(pic_state *);
@ -60,7 +62,7 @@ pic_init_core(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_deflibrary ("(scheme base)") {
pic_deflibrary (pic, "(scheme base)") {
/* load core syntaces */
pic->lib->env = pic_null_syntactic_environment(pic);
@ -94,6 +96,8 @@ pic_init_core(pic_state *pic)
pic_init_read(pic); DONE;
pic_init_dict(pic); DONE;
pic_init_record(pic); DONE;
pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;
pic_load_piclib(pic); DONE;

193
src/lib.c
View File

@ -6,6 +6,9 @@
#include "picrin/lib.h"
#include "picrin/pair.h"
#include "picrin/macro.h"
#include "picrin/error.h"
#include "picrin/dict.h"
#include "picrin/string.h"
struct pic_lib *
pic_make_library(pic_state *pic, pic_value name)
@ -32,7 +35,7 @@ pic_make_library(pic_state *pic, pic_value name)
xh_init_int(&lib->exports, sizeof(pic_sym));
/* register! */
pic->lib_tbl = pic_acons(pic, name, pic_obj_value(lib), pic->lib_tbl);
pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
return lib;
}
@ -54,62 +57,204 @@ pic_find_library(pic_state *pic, pic_value spec)
{
pic_value v;
v = pic_assoc(pic, spec, pic->lib_tbl, NULL);
v = pic_assoc(pic, spec, pic->libs, NULL);
if (pic_false_p(v)) {
return NULL;
}
return pic_lib_ptr(pic_cdr(pic, v));
}
void
pic_import(pic_state *pic, pic_value spec)
static struct pic_dict *
import_table(pic_state *pic, pic_value spec)
{
const pic_sym sONLY = pic_intern_cstr(pic, "only");
const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix");
const pic_sym sEXCEPT = pic_intern_cstr(pic, "except");
struct pic_lib *lib;
struct pic_dict *imports, *dict;
pic_value val, id;
xh_iter it;
imports = pic_dict_new(pic);
if (pic_list_p(spec)) {
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) {
dict = import_table(pic, pic_cadr(pic, spec));
pic_for_each (val, pic_cddr(pic, spec)) {
pic_dict_set(pic, imports, pic_sym(val), pic_dict_ref(pic, dict, pic_sym(val)));
}
return imports;
}
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) {
imports = import_table(pic, pic_cadr(pic, spec));
pic_for_each (val, pic_cddr(pic, spec)) {
id = pic_dict_ref(pic, imports, pic_sym(pic_car(pic, val)));
pic_dict_del(pic, imports, pic_sym(pic_car(pic, val)));
pic_dict_set(pic, imports, pic_sym(pic_cadr(pic, val)), id);
}
return imports;
}
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) {
dict = import_table(pic, pic_cadr(pic, spec));
xh_begin(&it, &dict->hash);
while (xh_next(&it)) {
pic_dict_set(pic, imports, pic_intern_cstr(pic, pic_str_cstr(pic_strcat(pic, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cddr(pic, spec))))), pic_str_new_cstr(pic, pic_symbol_name(pic, xh_key(it.e, pic_sym)))))), xh_val(it.e, pic_value));
}
return imports;
}
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) {
imports = import_table(pic, pic_cadr(pic, spec));
pic_for_each (val, pic_cddr(pic, spec)) {
pic_dict_del(pic, imports, pic_sym(val));
}
return imports;
}
}
lib = pic_find_library(pic, spec);
if (! lib) {
pic_errorf(pic, "library not found: ~a", spec);
}
xh_begin(&it, &lib->exports);
while (xh_next(&it)) {
pic_dict_set(pic, imports, xh_key(it.e, pic_sym), pic_sym_value(xh_val(it.e, pic_sym)));
}
return imports;
}
static void
import(pic_state *pic, pic_value spec)
{
struct pic_dict *imports;
xh_iter it;
imports = import_table(pic, spec);
xh_begin(&it, &imports->hash);
while (xh_next(&it)) {
#if DEBUG
printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym)));
printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, pic_sym(xh_val(it.e, pic_value))));
#endif
pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), pic_sym(xh_val(it.e, pic_value)));
}
}
static void
export(pic_state *pic, pic_value spec)
{
const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
pic_value a, b;
pic_sym rename;
if (pic_sym_p(spec)) { /* (export a) */
a = b = spec;
} else { /* (export (rename a b)) */
if (! pic_list_p(spec))
goto fail;
if (! pic_length(pic, spec) == 3)
goto fail;
if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME)))
goto fail;
if (! pic_sym_p(a = pic_list_ref(pic, spec, 1)))
goto fail;
if (! pic_sym_p(b = pic_list_ref(pic, spec, 2)))
goto fail;
}
if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a)));
}
#if DEBUG
printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename));
#endif
xh_put_int(&pic->lib->exports, pic_sym(b), &rename);
return;
fail:
pic_errorf(pic, "illegal export spec: ~s", spec);
}
void
pic_import(pic_state *pic, pic_value spec)
{
import(pic, spec);
}
void
pic_export(pic_state *pic, pic_sym sym)
{
pic_sym rename;
export(pic, pic_sym_value(sym));
}
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
static pic_value
pic_lib_import(pic_state *pic)
{
size_t argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
import(pic, argv[i]);
}
#if DEBUG
printf("* exporting %s as %s\n", pic_symbol_name(pic, sym), pic_symbol_name(pic, rename));
#endif
return pic_none_value();
}
xh_put_int(&pic->lib->exports, sym, &rename);
static pic_value
pic_lib_export(pic_state *pic)
{
size_t argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
export(pic, argv[i]);
}
return pic_none_value();
}
static pic_value
pic_lib_define_library(pic_state *pic)
{
struct pic_lib *prev = pic->lib;
size_t argc, i;
pic_value spec, *argv;
pic_get_args(pic, "o*", &spec, &argc, &argv);
pic_make_library(pic, spec);
pic_try {
pic_in_library(pic, spec);
for (i = 0; i < argc; ++i) {
pic_void(pic_eval(pic, argv[i], pic->lib));
}
pic_in_library(pic, prev->name);
}
pic_catch {
pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
pic_throw_error(pic, pic->err);
}
return pic_none_value();
}
void
pic_export_as(pic_state *pic, pic_sym sym, pic_sym as)
pic_init_lib(pic_state *pic)
{
pic_sym rename;
void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
}
#if DEBUG
printf("* exporting %s as %s\n", pic_symbol_name(pic, as), pic_symbol_name(pic, rename));
#endif
xh_put_int(&pic->lib->exports, as, &rename);
pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);
pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);
}

6
src/load.c
View File

@ -20,7 +20,7 @@ pic_load_cstr(pic_state *pic, const char *src)
pic_for_each (v, exprs) {
ai = pic_gc_arena_preserve(pic);
proc = pic_compile(pic, v);
proc = pic_compile(pic, v, pic->lib);
if (proc == NULL) {
pic_error(pic, "load: compilation failure");
}
@ -54,7 +54,7 @@ pic_load(pic_state *pic, const char *fn)
pic_for_each (v, exprs) {
ai = pic_gc_arena_preserve(pic);
proc = pic_compile(pic, v);
proc = pic_compile(pic, v, pic->lib);
if (proc == NULL) {
pic_error(pic, "load: compilation failure");
}
@ -81,7 +81,7 @@ pic_load_load(pic_state *pic)
void
pic_init_load(pic_state *pic)
{
pic_deflibrary ("(scheme load)") {
pic_deflibrary (pic, "(scheme load)") {
pic_defun(pic, "load", pic_load_load);
}
}

267
src/macro.c
View File

@ -104,83 +104,6 @@ macroexpand_quote(pic_state *pic, pic_value expr)
return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr));
}
static pic_value
macroexpand_import(pic_state *pic, pic_value expr)
{
pic_value spec;
pic_for_each (spec, pic_cdr(pic, expr)) {
pic_import(pic, spec);
}
return pic_none_value();
}
static pic_value
macroexpand_export(pic_state *pic, pic_value expr)
{
extern pic_value pic_export_as(pic_state *, pic_sym, pic_sym);
pic_value spec;
pic_sym sRENAME, sym, as;
sRENAME = pic_intern_cstr(pic, "rename");
pic_for_each (spec, pic_cdr(pic, expr)) {
if (pic_sym_p(spec)) {
sym = as = pic_sym(spec);
}
else if (pic_list_p(spec) && pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) {
if (pic_length(pic, spec) != 3) {
pic_error(pic, "syntax error");
}
if (! pic_sym_p(pic_list_ref(pic, spec, 1))) {
pic_error(pic, "syntax error");
}
sym = pic_sym(pic_list_ref(pic, spec, 1));
if (! pic_sym_p(pic_list_ref(pic, spec, 2))) {
pic_error(pic, "syntax error");
}
as = pic_sym(pic_list_ref(pic, spec, 2));
}
else {
pic_error(pic, "syntax error");
}
/* TODO: warn if symbol is shadowed by local variable */
pic_export_as(pic, sym, as);
}
return pic_none_value();
}
static pic_value
macroexpand_deflibrary(pic_state *pic, pic_value expr)
{
struct pic_lib *prev = pic->lib;
pic_value v;
if (pic_length(pic, expr) < 2) {
pic_error(pic, "syntax error");
}
pic_make_library(pic, pic_cadr(pic, expr));
pic_try {
pic_in_library(pic, pic_cadr(pic, expr));
pic_for_each (v, pic_cddr(pic, expr)) {
pic_void(pic_eval(pic, v));
}
pic_in_library(pic, prev->name);
}
pic_catch {
pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
pic_throw_error(pic, pic->err);
}
return pic_none_value();
}
static pic_value
macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv)
{
@ -286,12 +209,14 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
} else {
pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym));
}
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
val = pic_eval(pic, val);
val = pic_eval(pic, val, pic->lib);
} pic_catch {
pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
}
@ -318,8 +243,7 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
if (mac->senv == NULL) { /* legacy macro */
args = pic_cdr(pic, expr);
}
else {
} else {
args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
}
@ -335,18 +259,12 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
puts("");
#endif
return macroexpand(pic, v, senv);
return v;
}
static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
switch (pic_type(expr)) {
case PIC_TT_SYMBOL: {
return macroexpand_symbol(pic, pic_sym(expr), senv);
@ -363,16 +281,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (pic_sym_p(car)) {
pic_sym tag = pic_sym(car);
if (tag == pic->rDEFINE_LIBRARY) {
return macroexpand_deflibrary(pic, expr);
}
else if (tag == pic->rIMPORT) {
return macroexpand_import(pic, expr);
}
else if (tag == pic->rEXPORT) {
return macroexpand_export(pic, expr);
}
else if (tag == pic->rDEFINE_SYNTAX) {
if (tag == pic->rDEFINE_SYNTAX) {
return macroexpand_defsyntax(pic, expr, senv);
}
else if (tag == pic->rLAMBDA) {
@ -386,40 +295,15 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
}
if ((mac = find_macro(pic, tag)) != NULL) {
return macroexpand_macro(pic, mac, expr, senv);
return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv);
}
}
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
}
case PIC_TT_EOF:
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
case PIC_TT_INT:
case PIC_TT_CHAR:
case PIC_TT_STRING:
case PIC_TT_VECTOR:
case PIC_TT_BLOB: {
default:
return expr;
}
case PIC_TT_PROC:
case PIC_TT_PORT:
case PIC_TT_ERROR:
case PIC_TT_ENV:
case PIC_TT_CONT:
case PIC_TT_UNDEF:
case PIC_TT_SENV:
case PIC_TT_MACRO:
case PIC_TT_LIB:
case PIC_TT_VAR:
case PIC_TT_IREP:
case PIC_TT_DATA:
case PIC_TT_DICT:
case PIC_TT_RECORD:
pic_errorf(pic, "unexpected value type: ~s", expr);
}
UNREACHABLE();
}
static pic_value
@ -428,6 +312,12 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
size_t ai = pic_gc_arena_preserve(pic);
pic_value v;
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
v = macroexpand_node(pic, expr, senv);
pic_gc_arena_restore(pic, ai);
@ -436,8 +326,9 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
}
pic_value
pic_macroexpand(pic_state *pic, pic_value expr)
pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
{
struct pic_lib *prev;
pic_value v;
#if DEBUG
@ -446,7 +337,13 @@ pic_macroexpand(pic_state *pic, pic_value expr)
puts("");
#endif
v = macroexpand(pic, expr, pic->lib->env);
/* change library for macro-expansion time processing */
prev = pic->lib;
pic->lib = lib;
v = macroexpand(pic, expr, lib->env);
pic->lib = prev;
#if DEBUG
puts("after expand:");
@ -457,47 +354,6 @@ pic_macroexpand(pic_state *pic, pic_value expr)
return v;
}
static pic_value
macroexpand_one(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
struct pic_macro *mac;
pic_value v, args;
if (pic_sym_p(expr)) {
pic_sym sym;
sym = pic_sym(expr);
if (pic_interned_p(pic, sym)) {
return pic_sym_value(make_identifier(pic, pic_sym(expr), senv));
}
}
if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
pic_sym sym;
sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
if ((mac = find_macro(pic, sym)) != NULL) {
if (mac->senv == NULL) { /* legacy macro */
args = pic_cdr(pic, expr);
}
else {
args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
}
pic_try {
v = pic_apply(pic, mac->proc, args);
} pic_catch {
pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
}
return v;
}
}
return pic_undef_value(); /* no expansion occurred */
}
struct pic_senv *
pic_senv_new(pic_state *pic, struct pic_senv *up)
{
@ -535,17 +391,15 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym,
}
void
pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func)
{
pic_sym sym, rename;
pic_put_rename(pic, pic->lib->env, name, id);
/* symbol registration */
sym = pic_intern_cstr(pic, name);
rename = pic_add_rename(pic, pic->lib->env, sym);
define_macro(pic, rename, macro, NULL);
define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL);
/* auto export! */
pic_export(pic, sym);
pic_export(pic, name);
}
bool
@ -554,15 +408,6 @@ pic_identifier_p(pic_state *pic, pic_value obj)
return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj));
}
bool
pic_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_sym x, struct pic_senv *e2, pic_sym y)
{
x = make_identifier(pic, x, e1);
y = make_identifier(pic, y, e2);
return x == y;
}
static pic_value
pic_macro_gensym(pic_state *pic)
{
@ -575,6 +420,16 @@ pic_macro_gensym(pic_state *pic)
return pic_sym_value(uniq);
}
static pic_value
pic_macro_ungensym(pic_state *pic)
{
pic_sym sym;
pic_get_args(pic, "m", &sym);
return pic_sym_value(pic_ungensym(pic, sym));
}
static pic_value
pic_macro_macroexpand(pic_state *pic)
{
@ -582,23 +437,32 @@ pic_macro_macroexpand(pic_state *pic)
pic_get_args(pic, "o", &expr);
return pic_macroexpand(pic, expr);
return pic_macroexpand(pic, expr, pic->lib);
}
static pic_value
pic_macro_macroexpand_1(pic_state *pic)
{
pic_value expr, val;
struct pic_senv *senv = pic->lib->env;
struct pic_macro *mac;
pic_value expr;
pic_sym sym;
pic_get_args(pic, "o", &expr);
val = macroexpand_one(pic, expr, pic->lib->env);
if (pic_undef_p(val)) {
return pic_values2(pic, expr, pic_false_value());
if (pic_sym_p(expr)) {
if (pic_interned_p(pic, pic_sym(expr))) {
return pic_values2(pic, macroexpand_symbol(pic, pic_sym(expr), senv), pic_true_value());
}
}
else {
return pic_values2(pic, val, pic_true_value());
if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
if ((mac = find_macro(pic, sym)) != NULL) {
return pic_values2(pic, macroexpand_macro(pic, mac, expr, senv), pic_true_value());
}
}
return pic_values2(pic, expr, pic_false_value()); /* no expansion occurred */
}
static pic_value
@ -611,27 +475,6 @@ pic_macro_identifier_p(pic_state *pic)
return pic_bool_value(pic_identifier_p(pic, obj));
}
static pic_value
pic_macro_identifier_eq_p(pic_state *pic)
{
pic_sym x, y;
pic_value e, f;
struct pic_senv *e1, *e2;
pic_get_args(pic, "omom", &e, &x, &f, &y);
if (! pic_senv_p(e)) {
pic_error(pic, "unexpected type of argument 1");
}
e1 = pic_senv_ptr(e);
if (! pic_senv_p(f)) {
pic_error(pic, "unexpected type of argument 3");
}
e2 = pic_senv_ptr(f);
return pic_bool_value(pic_identifier_eq_p(pic, e1, x, e2, y));
}
static pic_value
pic_macro_make_identifier(pic_state *pic)
{
@ -648,12 +491,12 @@ pic_macro_make_identifier(pic_state *pic)
void
pic_init_macro(pic_state *pic)
{
pic_deflibrary ("(picrin macro)") {
pic_deflibrary (pic, "(picrin macro)") {
pic_defun(pic, "gensym", pic_macro_gensym);
pic_defun(pic, "ungensym", pic_macro_ungensym);
pic_defun(pic, "macroexpand", pic_macro_macroexpand);
pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1);
pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
}
}

67
src/number.c
View File

@ -28,6 +28,59 @@ lcm(int a, int b)
return fabs((double)a * b) / gcd(a, b);
}
/**
* Returns the length of string representing val.
* radix is between 2 and 36 (inclusive).
* No error checks are performed in this function.
*/
static int
number_string_length(int val, int radix)
{
long long v = val; /* in case val == INT_MIN */
int count = 0;
if (val == 0) {
return 1;
}
if (val < 0) {
v = - v;
count = 1;
}
while (v > 0) {
++count;
v /= radix;
}
return count;
}
/**
* Returns the string representing val.
* radix is between 2 and 36 (inclusive).
* This function overwrites buffer and stores the result.
* No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun.
*/
static void
number_string(int val, int radix, int length, char *buffer) {
const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
long long v = val;
int i;
if (val == 0) {
buffer[0] = '0';
buffer[1] = '\0';
return;
}
if (val < 0) {
buffer[0] = '-';
v = -v;
}
for(i = length - 1; v > 0; --i) {
buffer[i] = digits[v % radix];
v /= radix;
}
buffer[length] = '\0';
return;
}
static pic_value
pic_number_real_p(pic_state *pic)
{
@ -748,10 +801,16 @@ pic_number_number_to_string(pic_state *pic)
pic_get_args(pic, "F|i", &f, &e, &radix);
if (e) {
char buf[snprintf(NULL, 0, "%d", (int)f) + 1];
if (radix < 2 || radix > 36) {
pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix);
}
snprintf(buf, sizeof buf, "%d", (int)f);
if (e) {
int ival = (int) f;
int ilen = number_string_length(ival, radix);
char buf[ilen + 1];
number_string(ival, radix, ilen, buf);
return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
}
@ -866,7 +925,7 @@ pic_init_number(pic_state *pic)
pic_defun(pic, "string->number", pic_number_string_to_number);
pic_gc_arena_restore(pic, ai);
pic_deflibrary ("(scheme inexact)") {
pic_deflibrary (pic, "(scheme inexact)") {
pic_defun(pic, "finite?", pic_number_finite_p);
pic_defun(pic, "infinite?", pic_number_infinite_p);
pic_defun(pic, "nan?", pic_number_nan_p);

25
src/port.c
View File

@ -377,7 +377,7 @@ pic_port_get_output_bytevector(pic_state *pic)
static pic_value
pic_port_read_char(pic_state *pic)
{
char c;
int c;
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
@ -388,14 +388,14 @@ pic_port_read_char(pic_state *pic)
return pic_eof_object();
}
else {
return pic_char_value(c);
return pic_char_value((char)c);
}
}
static pic_value
pic_port_peek_char(pic_state *pic)
{
char c;
int c;
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
@ -407,14 +407,14 @@ pic_port_peek_char(pic_state *pic)
}
else {
xungetc(c, port->file);
return pic_char_value(c);
return pic_char_value((char)c);
}
}
static pic_value
pic_port_read_line(pic_state *pic)
{
char c;
int c;
struct pic_port *port = pic_stdin(pic), *buf;
struct pic_string *str;
@ -453,16 +453,16 @@ pic_port_read_string(pic_state *pic){
struct pic_port *port = pic_stdin(pic), *buf;
pic_str *str;
int k, i;
char c;
int c;
pic_get_args(pic, "i|p", &k, &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg");
c = EOF;
buf = pic_open_output_string(pic);
for(i = 0; i < k; ++i) {
c = xfgetc(port->file);
if( c == EOF){
if((c = xfgetc(port->file)) == EOF){
break;
}
xfputc(c, buf->file);
@ -481,7 +481,7 @@ pic_port_read_string(pic_state *pic){
static pic_value
pic_port_read_byte(pic_state *pic){
struct pic_port *port = pic_stdin(pic);
char c;
int c;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8");
@ -495,14 +495,15 @@ pic_port_read_byte(pic_state *pic){
static pic_value
pic_port_peek_byte(pic_state *pic)
{
char c;
int c;
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8");
if ((c = xfgetc(port->file)) == EOF) {
c = xfgetc(port->file);
if (c == EOF) {
return pic_eof_object();
}
else {
@ -695,7 +696,7 @@ pic_init_port(pic_state *pic)
STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT);
STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT);
pic_deflibrary ("(picrin port)") {
pic_deflibrary (pic, "(picrin port)") {
pic_define(pic, "standard-input-port", pic_obj_value(STDIN));
pic_define(pic, "standard-output-port", pic_obj_value(STDOUT));
pic_define(pic, "standard-error-port", pic_obj_value(STDERR));

2
src/proc.c
View File

@ -177,7 +177,7 @@ pic_init_proc(pic_state *pic)
pic_defun(pic, "map", pic_proc_map);
pic_defun(pic, "for-each", pic_proc_for_each);
pic_deflibrary ("(picrin attribute)") {
pic_deflibrary (pic, "(picrin attribute)") {
pic_defun(pic, "attribute", pic_proc_attribute);
}
}

140
src/read.c
View File

@ -13,10 +13,10 @@
#include "picrin/blob.h"
#include "picrin/port.h"
typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, char);
typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, int);
static pic_value read(pic_state *pic, struct pic_port *port, char c);
static pic_value read_nullable(pic_state *pic, struct pic_port *port, char c);
static pic_value read(pic_state *pic, struct pic_port *port, int c);
static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c);
static noreturn void
read_error(pic_state *pic, const char *msg)
@ -24,8 +24,8 @@ read_error(pic_state *pic, const char *msg)
pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value());
}
static char
skip(struct pic_port *port, char c)
static int
skip(struct pic_port *port, int c)
{
while (isspace(c)) {
c = xfgetc(port->file);
@ -33,16 +33,16 @@ skip(struct pic_port *port, char c)
return c;
}
static char
static int
next(struct pic_port *port)
{
return xfgetc(port->file);
}
static char
static int
peek(struct pic_port *port)
{
char c;
int c;
xungetc((c = xfgetc(port->file)), port->file);
@ -52,9 +52,9 @@ peek(struct pic_port *port)
static bool
expect(struct pic_port *port, const char *str)
{
char c;
int c;
while ((c = *str++) != 0) {
while ((c = (int)*str++) != 0) {
if (c != peek(port))
return false;
next(port);
@ -64,13 +64,25 @@ expect(struct pic_port *port, const char *str)
}
static bool
isdelim(char c)
isdelim(int c)
{
return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
return c == EOF || strchr("();,|\" \t\n\r", (char)c) != NULL; /* ignores "#", "'" */
}
static bool
strcaseeq(const char *s1, const char *s2)
{
char a, b;
while ((a = *s1++) * (b = *s2++)) {
if (tolower(a) != tolower(b))
return false;
}
return a == b;
}
static pic_value
read_comment(pic_state *pic, struct pic_port *port, char c)
read_comment(pic_state *pic, struct pic_port *port, int c)
{
UNUSED(pic);
@ -82,9 +94,9 @@ read_comment(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_block_comment(pic_state *pic, struct pic_port *port, char c)
read_block_comment(pic_state *pic, struct pic_port *port, int c)
{
char x, y;
int x, y;
int i = 1;
UNUSED(pic);
@ -107,7 +119,7 @@ read_block_comment(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_datum_comment(pic_state *pic, struct pic_port *port, char c)
read_datum_comment(pic_state *pic, struct pic_port *port, int c)
{
UNUSED(c);
@ -117,18 +129,18 @@ read_datum_comment(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_directive(pic_state *pic, struct pic_port *port, char c)
read_directive(pic_state *pic, struct pic_port *port, int c)
{
switch (peek(port)) {
switch ((char)peek(port)) {
case 'n':
if (expect(port, "no-fold-case")) {
/* :FIXME: set no-fold-case flag */
pic->rfcase = false;
return pic_undef_value();
}
break;
case 'f':
if (expect(port, "fold-case")) {
/* :FIXME: set fold-case flag */
pic->rfcase = true;
return pic_undef_value();
}
break;
@ -138,7 +150,7 @@ read_directive(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_quote(pic_state *pic, struct pic_port *port, char c)
read_quote(pic_state *pic, struct pic_port *port, int c)
{
UNUSED(c);
@ -146,7 +158,7 @@ read_quote(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_quasiquote(pic_state *pic, struct pic_port *port, char c)
read_quasiquote(pic_state *pic, struct pic_port *port, int c)
{
UNUSED(c);
@ -154,11 +166,11 @@ read_quasiquote(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_comma(pic_state *pic, struct pic_port *port, char c)
read_comma(pic_state *pic, struct pic_port *port, int c)
{
c = next(port);
if (c == '@') {
if ((char)c == '@') {
return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port)));
} else {
return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, c));
@ -166,7 +178,7 @@ read_comma(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_symbol(pic_state *pic, struct pic_port *port, char c)
read_symbol(pic_state *pic, struct pic_port *port, int c)
{
size_t len;
char *buf;
@ -179,20 +191,22 @@ read_symbol(pic_state *pic, struct pic_port *port, char c)
if (len != 0) {
c = next(port);
}
if (pic->rfcase) {
c = tolower(c);
}
len += 1;
buf = pic_realloc(pic, buf, len + 1);
buf[len - 1] = c;
buf[len - 1] = (char)c;
} while (! isdelim(peek(port)));
buf[len] = '\0';
sym = pic_intern_cstr(pic, buf);
sym = pic_intern(pic, buf, len);
pic_free(pic, buf);
return pic_sym_value(sym);
}
static size_t
read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[])
read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[])
{
size_t i = 0;
@ -200,9 +214,9 @@ read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[])
read_error(pic, "expected one or more digits");
}
buf[i++] = c;
buf[i++] = (char)c;
while (isdigit(c = peek(port))) {
buf[i++] = next(port);
buf[i++] = (char)next(port);
}
buf[i] = '\0';
@ -211,7 +225,7 @@ read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[])
}
static pic_value
read_number(pic_state *pic, struct pic_port *port, char c)
read_number(pic_state *pic, struct pic_port *port, int c)
{
char buf[256];
size_t i;
@ -219,10 +233,10 @@ read_number(pic_state *pic, struct pic_port *port, char c)
i = read_uinteger(pic, port, c, buf);
switch (peek(port)) {
switch ((char)peek(port)) {
case '.':
do {
buf[i++] = next(port);
buf[i++] = (char)next(port);
} while (isdigit(peek(port)));
buf[i] = '\0';
return pic_float_value(atof(buf));
@ -253,7 +267,7 @@ negate(pic_value n)
}
static pic_value
read_minus(pic_state *pic, struct pic_port *port, char c)
read_minus(pic_state *pic, struct pic_port *port, int c)
{
pic_value sym;
@ -262,10 +276,10 @@ read_minus(pic_state *pic, struct pic_port *port, char c)
}
else {
sym = read_symbol(pic, port, c);
if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-inf.0")))) {
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) {
return pic_float_value(-INFINITY);
}
if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-nan.0")))) {
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) {
return pic_float_value(-NAN);
}
return sym;
@ -273,7 +287,7 @@ read_minus(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_plus(pic_state *pic, struct pic_port *port, char c)
read_plus(pic_state *pic, struct pic_port *port, int c)
{
pic_value sym;
@ -282,10 +296,10 @@ read_plus(pic_state *pic, struct pic_port *port, char c)
}
else {
sym = read_symbol(pic, port, c);
if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+inf.0")))) {
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) {
return pic_float_value(INFINITY);
}
if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+nan.0")))) {
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) {
return pic_float_value(NAN);
}
return read_symbol(pic, port, c);
@ -293,13 +307,13 @@ read_plus(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_boolean(pic_state *pic, struct pic_port *port, char c)
read_boolean(pic_state *pic, struct pic_port *port, int c)
{
UNUSED(pic);
UNUSED(port);
if (! isdelim(peek(port))) {
if (c == 't') {
if ((char)c == 't') {
if (! expect(port, "rue")) {
goto fail;
}
@ -310,7 +324,7 @@ read_boolean(pic_state *pic, struct pic_port *port, char c)
}
}
if (c == 't') {
if ((char)c == 't') {
return pic_true_value();
} else {
return pic_false_value();
@ -321,12 +335,12 @@ read_boolean(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_char(pic_state *pic, struct pic_port *port, char c)
read_char(pic_state *pic, struct pic_port *port, int c)
{
c = next(port);
if (! isdelim(peek(port))) {
switch (c) {
switch ((char)c) {
default: read_error(pic, "unexpected character after char literal");
case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break;
case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break;
@ -356,7 +370,7 @@ read_char(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_string(pic_state *pic, struct pic_port *port, char c)
read_string(pic_state *pic, struct pic_port *port, int c)
{
char *buf;
size_t size, cnt;
@ -378,7 +392,7 @@ read_string(pic_state *pic, struct pic_port *port, char c)
case 'r': c = '\r'; break;
}
}
buf[cnt++] = c;
buf[cnt++] = (char)c;
if (cnt >= size) {
buf = pic_realloc(pic, buf, size *= 2);
}
@ -405,7 +419,7 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
cnt = 0;
while ((c = next(port)) != '|') {
if (c == '\\') {
switch (c = next(port)) {
switch ((char)(c = next(port))) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
@ -421,7 +435,7 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
break;
}
}
buf[cnt++] = c;
buf[cnt++] = (char)c;
if (cnt >= size) {
buf = pic_realloc(pic, buf, size *= 2);
}
@ -435,7 +449,7 @@ read_pipe(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
read_unsigned_blob(pic_state *pic, struct pic_port *port, int c)
{
int nbits, n;
size_t len, i;
@ -481,7 +495,7 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_pair(pic_state *pic, struct pic_port *port, char c)
read_pair(pic_state *pic, struct pic_port *port, int c)
{
char tOPEN = c, tCLOSE = (tOPEN == '(') ? ')' : ']';
pic_value car, cdr;
@ -518,7 +532,7 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_vector(pic_state *pic, struct pic_port *port, char c)
read_vector(pic_state *pic, struct pic_port *port, int c)
{
pic_value list;
@ -531,9 +545,9 @@ static pic_value
read_label_set(pic_state *pic, struct pic_port *port, int i)
{
pic_value val;
char c;
int c;
switch (c = skip(port, ' ')) {
switch ((char)(c = skip(port, ' '))) {
case '(': case '[':
{
pic_value tmp;
@ -600,7 +614,7 @@ read_label_ref(pic_state *pic, struct pic_port *port, int i)
}
static pic_value
read_label(pic_state *pic, struct pic_port *port, char c)
read_label(pic_state *pic, struct pic_port *port, int c)
{
int i;
@ -619,11 +633,11 @@ read_label(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_dispatch(pic_state *pic, struct pic_port *port, char c)
read_dispatch(pic_state *pic, struct pic_port *port, int c)
{
c = next(port);
switch (c) {
switch ((char)c) {
case '!':
return read_directive(pic, port, c);
case '|':
@ -647,7 +661,7 @@ read_dispatch(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read_nullable(pic_state *pic, struct pic_port *port, char c)
read_nullable(pic_state *pic, struct pic_port *port, int c)
{
c = skip(port, c);
@ -655,7 +669,9 @@ read_nullable(pic_state *pic, struct pic_port *port, char c)
read_error(pic, "unexpected EOF");
}
switch (c) {
switch ((char)c) {
case ')':
read_error(pic, "unmatched parenthesis");
case ';':
return read_comment(pic, port, c);
case '#':
@ -685,7 +701,7 @@ read_nullable(pic_state *pic, struct pic_port *port, char c)
}
static pic_value
read(pic_state *pic, struct pic_port *port, char c)
read(pic_state *pic, struct pic_port *port, int c)
{
pic_value val;
@ -704,7 +720,7 @@ pic_value
pic_read(pic_state *pic, struct pic_port *port)
{
pic_value val;
char c = next(port);
int c = next(port);
retry:
c = skip(port, c);
@ -787,7 +803,7 @@ pic_read_read(pic_state *pic)
void
pic_init_read(pic_state *pic)
{
pic_deflibrary ("(scheme read)") {
pic_deflibrary (pic, "(scheme read)") {
pic_defun(pic, "read", pic_read_read);
}
}

2
src/record.c
View File

@ -105,7 +105,7 @@ pic_record_record_set(pic_state *pic)
void
pic_init_record(pic_state *pic)
{
pic_deflibrary ("(picrin record-primitive)") {
pic_deflibrary (pic, "(picrin record-primitive)") {
pic_defun(pic, "make-record", pic_record_record);
pic_defun(pic, "record-of?", pic_record_record_of);
pic_defun(pic, "record-ref", pic_record_record_ref);

43
src/state.c
View File

@ -9,6 +9,7 @@
#include "picrin/proc.h"
#include "picrin/macro.h"
#include "picrin/cont.h"
#include "picrin/error.h"
void pic_init_core(pic_state *);
@ -22,18 +23,14 @@ pic_open(int argc, char *argv[], char **envp)
pic = (pic_state *)malloc(sizeof(pic_state));
/* root block */
pic->blk = NULL;
/* command line */
pic->argc = argc;
pic->argv = argv;
pic->envp = envp;
/* root block */
pic->blk = (pic_block *)malloc(sizeof(pic_block));
pic->blk->prev = NULL;
pic->blk->depth = 0;
pic->blk->in = pic->blk->out = NULL;
pic->blk->refcnt = 1;
/* prepare VM stack */
pic->stbase = pic->sp = (pic_value *)calloc(PIC_STACK_SIZE, sizeof(pic_value));
pic->stend = pic->stbase + PIC_STACK_SIZE;
@ -52,25 +49,25 @@ pic_open(int argc, char *argv[], char **envp)
pic->uniq_sym_cnt = 0;
/* global variables */
xh_init_int(&pic->global_tbl, sizeof(size_t));
pic->globals = (pic_value *)calloc(PIC_GLOBALS_SIZE, sizeof(pic_value));
pic->glen = 0;
pic->gcapa = PIC_GLOBALS_SIZE;
xh_init_int(&pic->globals, sizeof(pic_value));
/* macros */
xh_init_int(&pic->macros, sizeof(struct pic_macro *));
/* libraries */
pic->lib_tbl = pic_nil_value();
pic->libs = pic_nil_value();
pic->lib = NULL;
/* reader */
pic->rfcase = false;
xh_init_int(&pic->rlabels, sizeof(pic_value));
/* error handling */
pic->jmp = NULL;
pic->err = NULL;
pic->try_jmps = NULL;
pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf));
pic->try_jmp_idx = 0;
pic->try_jmp_size = PIC_RESCUE_SIZE;
/* GC arena */
pic->arena = (struct pic_object **)calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
@ -132,6 +129,12 @@ pic_open(int argc, char *argv[], char **envp)
register_renamed_symbol(pic, rEXPORT, "export");
pic_gc_arena_restore(pic, ai);
/* root block */
pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
pic->blk->prev = NULL;
pic->blk->depth = 0;
pic->blk->in = pic->blk->out = NULL;
pic_init_core(pic);
/* set library */
@ -147,16 +150,20 @@ pic_close(pic_state *pic)
xh_iter it;
/* invoke exit handlers */
PIC_BLK_EXIT(pic);
while (pic->blk) {
if (pic->blk->out) {
pic_apply0(pic, pic->blk->out);
}
pic->blk = pic->blk->prev;
}
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
pic->arena_idx = 0;
pic->err = NULL;
pic->glen = 0;
xh_clear(&pic->macros);
pic->lib_tbl = pic_nil_value();
pic->libs = pic_nil_value();
/* free all heap objects */
pic_gc_run(pic);
@ -169,9 +176,9 @@ pic_close(pic_state *pic)
free(pic->cibase);
/* free global stacks */
free(pic->globals);
free(pic->try_jmps);
xh_destroy(&pic->syms);
xh_destroy(&pic->global_tbl);
xh_destroy(&pic->globals);
xh_destroy(&pic->macros);
xh_destroy(&pic->rlabels);

4
src/string.c
View File

@ -62,13 +62,13 @@ pic_strlen(pic_str *str)
char
pic_str_ref(pic_state *pic, pic_str *str, size_t i)
{
char c;
int c;
c = xr_at(str->rope, i);
if (c == -1) {
pic_errorf(pic, "index out of range %d", i);
}
return c;
return (char)c;
}
static xrope *

32
src/symbol.c
View File

@ -20,13 +20,13 @@ pic_intern(pic_state *pic, const char *str, size_t len)
cstr[len] = '\0';
memcpy(cstr, str, len);
e = xh_get(&pic->syms, cstr);
e = xh_get_str(&pic->syms, cstr);
if (e) {
return xh_val(e, pic_sym);
}
id = pic->sym_cnt++;
xh_put(&pic->syms, cstr, &id);
xh_put_str(&pic->syms, cstr, &id);
xh_put_int(&pic->sym_names, id, &cstr);
return id;
}
@ -41,12 +41,18 @@ pic_sym
pic_gensym(pic_state *pic, pic_sym base)
{
int uid = pic->uniq_sym_cnt++, len;
char *str;
char *str, mark;
pic_sym uniq;
len = snprintf(NULL, 0, "%s@%d", pic_symbol_name(pic, base), uid);
if (pic_interned_p(pic, base)) {
mark = '@';
} else {
mark = '.';
}
len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
str = pic_alloc(pic, len + 1);
sprintf(str, "%s@%d", pic_symbol_name(pic, base), uid);
sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
/* don't put the symbol to pic->syms to keep it uninterned */
uniq = pic->sym_cnt++;
@ -55,6 +61,22 @@ pic_gensym(pic_state *pic, pic_sym base)
return uniq;
}
pic_sym
pic_ungensym(pic_state *pic, pic_sym base)
{
const char *name, *occr;
if (pic_interned_p(pic, base)) {
return base;
}
name = pic_symbol_name(pic, base);
if ((occr = strrchr(name, '@')) == NULL) {
pic_abort(pic, "logic flaw");
}
return pic_intern(pic, name, occr - name);
}
bool
pic_interned_p(pic_state *pic, pic_sym sym)
{

6
src/system.c
View File

@ -24,7 +24,7 @@ pic_system_cmdline(pic_state *pic)
pic_gc_arena_restore(pic, ai);
}
return v;
return pic_reverse(pic, v);
}
static pic_value
@ -47,7 +47,7 @@ pic_system_exit(pic_state *pic)
}
}
PIC_BLK_EXIT(pic);
pic_close(pic);
exit(status);
}
@ -126,7 +126,7 @@ pic_system_getenvs(pic_state *pic)
void
pic_init_system(pic_state *pic)
{
pic_deflibrary ("(scheme process-context)") {
pic_deflibrary (pic, "(scheme process-context)") {
pic_defun(pic, "command-line", pic_system_cmdline);
pic_defun(pic, "exit", pic_system_exit);
pic_defun(pic, "emergency-exit", pic_system_emergency_exit);

2
src/time.c
View File

@ -41,7 +41,7 @@ pic_jiffies_per_second(pic_state *pic)
void
pic_init_time(pic_state *pic)
{
pic_deflibrary ("(scheme time)") {
pic_deflibrary (pic, "(scheme time)") {
pic_defun(pic, "current-second", pic_current_second);
pic_defun(pic, "current-jiffy", pic_current_jiffy);
pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second);

2
src/var.c
View File

@ -124,7 +124,7 @@ pic_var_parameter_pop(pic_state *pic)
void
pic_init_var(pic_state *pic)
{
pic_deflibrary ("(picrin parameter)") {
pic_deflibrary (pic, "(picrin parameter)") {
pic_defun(pic, "make-parameter", pic_var_make_parameter);
pic_defun(pic, "parameter-ref", pic_var_parameter_ref);
pic_defun(pic, "parameter-set!", pic_var_parameter_set);

143
src/vm.c
View File

@ -52,6 +52,7 @@ pic_get_proc(pic_state *pic)
* l lambda object
* p port object
* d dictionary object
* e error object
*
* | optional operator
* * variable length operator
@ -364,8 +365,25 @@ pic_get_args(pic_state *pic, const char *format, ...)
}
break;
}
case 'e': {
struct pic_error **e;
pic_value v;
e = va_arg(ap, struct pic_error **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_error_p(v)) {
*e = pic_error_ptr(v);
}
else {
pic_error(pic, "pic_get_args, expected error");
}
i++;
}
break;
}
default:
pic_error(pic, "pic_get_args: invalid argument specifier given");
pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c);
}
}
if ('*' == c) {
@ -387,79 +405,38 @@ pic_get_args(pic_state *pic, const char *format, ...)
return i - 1;
}
static size_t
global_ref(pic_state *pic, const char *name)
{
xh_entry *e;
pic_sym sym, rename;
sym = pic_intern_cstr(pic, name);
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
return SIZE_MAX;
}
if (! (e = xh_get_int(&pic->global_tbl, rename))) {
return SIZE_MAX;
}
return xh_val(e, size_t);
}
static size_t
global_def(pic_state *pic, const char *name)
{
pic_sym sym, rename;
size_t gidx;
sym = pic_intern_cstr(pic, name);
if ((gidx = global_ref(pic, name)) != SIZE_MAX) {
pic_warn(pic, "redefining global");
return gidx;
}
/* register to the senv */
rename = pic_add_rename(pic, pic->lib->env, sym);
/* register to the global table */
gidx = pic->glen++;
if (pic->glen >= pic->gcapa) {
pic_error(pic, "global table overflow");
}
xh_put_int(&pic->global_tbl, rename, &gidx);
return gidx;
}
void
pic_define(pic_state *pic, const char *name, pic_value val)
{
pic_sym sym, rename;
sym = pic_intern_cstr(pic, name);
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
rename = pic_add_rename(pic, pic->lib->env, sym);
} else {
pic_warn(pic, "redefining global");
}
/* push to the global arena */
pic->globals[global_def(pic, name)] = val;
xh_put_int(&pic->globals, rename, &val);
/* export! */
pic_export(pic, pic_intern_cstr(pic, name));
pic_export(pic, sym);
}
pic_value
pic_ref(pic_state *pic, const char *name)
{
size_t gid;
pic_sym sym, rename;
gid = global_ref(pic, name);
if (gid == SIZE_MAX) {
sym = pic_intern_cstr(pic, name);
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
pic_errorf(pic, "symbol \"%s\" not defined", name);
}
return pic->globals[gid];
}
void
pic_set(pic_state *pic, const char *name, pic_value value)
{
size_t gid;
gid = global_ref(pic, name);
if (gid == SIZE_MAX) {
pic_error(pic, "symbol not defined");
}
pic->globals[gid] = value;
return xh_val(xh_get_int(&pic->globals, rename), pic_value);
}
pic_value
@ -495,20 +472,36 @@ vm_push_env(pic_state *pic)
}
static void
vm_tear_off(pic_state *pic)
vm_tear_off(pic_callinfo *ci)
{
struct pic_env *env;
int i;
assert(pic->ci->env != NULL);
assert(ci->env != NULL);
env = pic->ci->env;
env = ci->env;
if (env->regs == env->storage) {
return; /* is torn off */
}
for (i = 0; i < env->regc; ++i) {
env->storage[i] = env->regs[i];
}
env->regs = env->storage;
}
void
pic_vm_tear_off(pic_state *pic)
{
pic_callinfo *ci;
for (ci = pic->ci; ci > pic->cibase; ci--) {
if (ci->env != NULL) {
vm_tear_off(ci);
}
}
}
pic_value
pic_apply0(pic_state *pic, struct pic_proc *proc)
{
@ -659,11 +652,19 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
NEXT;
}
CASE(OP_GREF) {
PUSH(pic->globals[c.u.i]);
xh_entry *e;
if ((e = xh_get_int(&pic->globals, c.u.i)) == NULL) {
pic_errorf(pic, "logic flaw; reference to uninitialized global variable: ~s", pic_symbol_name(pic, c.u.i));
}
PUSH(xh_val(e, pic_value));
NEXT;
}
CASE(OP_GSET) {
pic->globals[c.u.i] = POP();
pic_value val;
val = POP();
xh_put_int(&pic->globals, c.u.i, &val);
NEXT;
}
CASE(OP_LREF) {
@ -828,7 +829,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_callinfo *ci;
if (pic->ci->env != NULL) {
vm_tear_off(pic);
vm_tear_off(pic->ci);
}
if (c.u.i == -1) {
@ -854,7 +855,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_callinfo *ci;
if (pic->ci->env != NULL) {
vm_tear_off(pic);
vm_tear_off(pic->ci);
}
pic->ci->retc = c.u.i;
@ -1045,13 +1046,3 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args)
ci->retc = pic_length(pic, args);
return pic_obj_value(proc);
}
pic_value
pic_eval(pic_state *pic, pic_value program)
{
struct pic_proc *proc;
proc = pic_compile(pic, program);
return pic_apply(pic, proc, pic_nil_value());
}

115
src/write.c
View File

@ -2,6 +2,8 @@
* See Copyright Notice in picrin.h
*/
#include <math.h>
#include "picrin.h"
#include "picrin/port.h"
#include "picrin/pair.h"
@ -54,29 +56,22 @@ struct writer_control {
#define WRITE_MODE 1
#define DISPLAY_MODE 2
static struct writer_control *
writer_control_new(pic_state *pic, xFILE *file, int mode)
static void
writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode)
{
struct writer_control *p;
p = (struct writer_control *)pic_alloc(pic, sizeof(struct writer_control));
p->pic = pic;
p->file = file;
p->mode = mode;
p->cnt = 0;
xh_init_ptr(&p->labels, sizeof(int));
xh_init_ptr(&p->visited, sizeof(int));
return p;
}
static void
writer_control_destroy(struct writer_control *p)
{
pic_state *pic = p->pic;
xh_destroy(&p->labels);
xh_destroy(&p->visited);
pic_free(pic, p);
}
static void
@ -89,14 +84,14 @@ traverse_shared(struct writer_control *p, pic_value obj)
switch (pic_type(obj)) {
case PIC_TT_PAIR:
case PIC_TT_VECTOR:
e = xh_get(&p->labels, pic_obj_ptr(obj));
e = xh_get_ptr(&p->labels, pic_obj_ptr(obj));
if (e == NULL) {
c = -1;
xh_put(&p->labels, pic_obj_ptr(obj), &c);
xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c);
}
else if (xh_val(e, int) == -1) {
c = p->cnt++;
xh_put(&p->labels, pic_obj_ptr(obj), &c);
xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c);
break;
}
else {
@ -135,17 +130,17 @@ write_pair(struct writer_control *p, struct pic_pair *pair)
else if (pic_pair_p(pair->cdr)) {
/* shared objects */
if ((e = xh_get(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) {
if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) {
xfprintf(p->file, " . ");
if ((xh_get(&p->visited, pic_obj_ptr(pair->cdr)))) {
if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) {
xfprintf(p->file, "#%d#", xh_val(e, int));
return;
}
else {
xfprintf(p->file, "#%d=", xh_val(e, int));
c = 1;
xh_put(&p->visited, pic_obj_ptr(pair->cdr), &c);
xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c);
}
}
else {
@ -185,19 +180,20 @@ write_core(struct writer_control *p, pic_value obj)
size_t i;
xh_entry *e;
int c;
float f;
/* shared objects */
if (pic_vtype(obj) == PIC_VTYPE_HEAP
&& (e = xh_get(&p->labels, pic_obj_ptr(obj)))
&& (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)))
&& xh_val(e, int) != -1) {
if ((xh_get(&p->visited, pic_obj_ptr(obj)))) {
if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) {
xfprintf(file, "#%d#", xh_val(e, int));
return;
}
else {
xfprintf(file, "#%d=", xh_val(e, int));
c = 1;
xh_put(&p->visited, pic_obj_ptr(obj), &c);
xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c);
}
}
@ -257,7 +253,14 @@ write_core(struct writer_control *p, pic_value obj)
}
break;
case PIC_TT_FLOAT:
xfprintf(file, "%f", pic_float(obj));
f = pic_float(obj);
if (isnan(f)) {
xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0");
} else if (isinf(f)) {
xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0");
} else {
xfprintf(file, "%f", pic_float(obj));
}
break;
case PIC_TT_INT:
xfprintf(file, "%d", pic_int(obj));
@ -303,95 +306,65 @@ write_core(struct writer_control *p, pic_value obj)
}
xfprintf(file, ")");
break;
case PIC_TT_ERROR:
xfprintf(file, "#<error %p>", pic_ptr(obj));
break;
case PIC_TT_ENV:
xfprintf(file, "#<env %p>", pic_ptr(obj));
break;
case PIC_TT_CONT:
xfprintf(file, "#<cont %p>", pic_ptr(obj));
break;
case PIC_TT_SENV:
xfprintf(file, "#<senv %p>", pic_ptr(obj));
break;
case PIC_TT_MACRO:
xfprintf(file, "#<macro %p>", pic_ptr(obj));
break;
case PIC_TT_LIB:
xfprintf(file, "#<lib %p>", pic_ptr(obj));
break;
case PIC_TT_VAR:
xfprintf(file, "#<var %p>", pic_ptr(obj));
break;
case PIC_TT_IREP:
xfprintf(file, "#<irep %p>", pic_ptr(obj));
break;
case PIC_TT_DATA:
xfprintf(file, "#<data %p>", pic_ptr(obj));
break;
case PIC_TT_DICT:
xfprintf(file, "#<dict %p>", pic_ptr(obj));
break;
case PIC_TT_RECORD:
xfprintf(file, "#<record %p>", pic_ptr(obj));
default:
xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
}
}
static void
write(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control *p;
struct writer_control p;
p = writer_control_new(pic, file, WRITE_MODE);
writer_control_init(&p, pic, file, WRITE_MODE);
traverse_shared(p, obj); /* FIXME */
traverse_shared(&p, obj); /* FIXME */
write_core(p, obj);
write_core(&p, obj);
writer_control_destroy(p);
writer_control_destroy(&p);
}
static void
write_simple(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control *p;
struct writer_control p;
p = writer_control_new(pic, file, WRITE_MODE);
writer_control_init(&p, pic, file, WRITE_MODE);
/* no traverse here! */
write_core(p, obj);
write_core(&p, obj);
writer_control_destroy(p);
writer_control_destroy(&p);
}
static void
write_shared(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control *p;
struct writer_control p;
p = writer_control_new(pic, file, WRITE_MODE);
writer_control_init(&p, pic, file, WRITE_MODE);
traverse_shared(p, obj);
traverse_shared(&p, obj);
write_core(p, obj);
write_core(&p, obj);
writer_control_destroy(p);
writer_control_destroy(&p);
}
static void
display(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control *p;
struct writer_control p;
p = writer_control_new(pic, file, DISPLAY_MODE);
writer_control_init(&p, pic, file, DISPLAY_MODE);
traverse_shared(p, obj); /* FIXME */
traverse_shared(&p, obj); /* FIXME */
write_core(p, obj);
write_core(&p, obj);
writer_control_destroy(p);
writer_control_destroy(&p);
}
pic_value
@ -485,7 +458,7 @@ pic_write_display(pic_state *pic)
void
pic_init_write(pic_state *pic)
{
pic_deflibrary ("(scheme write)") {
pic_deflibrary (pic, "(scheme write)") {
pic_defun(pic, "write", pic_write_write);
pic_defun(pic, "write-simple", pic_write_write_simple);
pic_defun(pic, "write-shared", pic_write_write_shared);

328
t/r7rs-tests.scm
View File

@ -34,7 +34,7 @@
(scheme file)
(scheme read)
(scheme write)
; (scheme eval)
(scheme eval)
(scheme process-context)
(scheme case-lambda)
(picrin test))
@ -212,33 +212,33 @@
(let*-values (((root rem) (exact-integer-sqrt 32)))
(test 35 (* root rem)))
(test '(1073741824 0)
(let*-values (((root rem) (exact-integer-sqrt (expt 2 60))))
(list root rem)))
;; (test '(1073741824 0)
;; (let*-values (((root rem) (exact-integer-sqrt (expt 2 60))))
;; (list root rem)))
(test '(1518500249 3000631951)
(let*-values (((root rem) (exact-integer-sqrt (expt 2 61))))
(list root rem)))
;; (test '(1518500249 3000631951)
;; (let*-values (((root rem) (exact-integer-sqrt (expt 2 61))))
;; (list root rem)))
(test '(815238614083298888 443242361398135744)
(let*-values (((root rem) (exact-integer-sqrt (expt 2 119))))
(list root rem)))
;; (test '(815238614083298888 443242361398135744)
;; (let*-values (((root rem) (exact-integer-sqrt (expt 2 119))))
;; (list root rem)))
(test '(1152921504606846976 0)
(let*-values (((root rem) (exact-integer-sqrt (expt 2 120))))
(list root rem)))
;; (test '(1152921504606846976 0)
;; (let*-values (((root rem) (exact-integer-sqrt (expt 2 120))))
;; (list root rem)))
(test '(1630477228166597776 1772969445592542976)
(let*-values (((root rem) (exact-integer-sqrt (expt 2 121))))
(list root rem)))
;; (test '(1630477228166597776 1772969445592542976)
;; (let*-values (((root rem) (exact-integer-sqrt (expt 2 121))))
;; (list root rem)))
(test '(31622776601683793319 62545769258890964239)
(let*-values (((root rem) (exact-integer-sqrt (expt 10 39))))
(list root rem)))
;; (test '(31622776601683793319 62545769258890964239)
;; (let*-values (((root rem) (exact-integer-sqrt (expt 10 39))))
;; (list root rem)))
(let*-values (((root rem) (exact-integer-sqrt (expt 2 140))))
(test 0 rem)
(test (expt 2 140) (square root)))
;; (let*-values (((root rem) (exact-integer-sqrt (expt 2 140))))
;; (test 0 rem)
;; (test (expt 2 140) (square root)))
(test '(x y x y) (let ((a 'a) (b 'b) (x 'x) (y 'y))
(let*-values (((a b) (values x y))
@ -630,7 +630,7 @@
;; (test #f (real? -2.5+0.0i))
;; (test #t (real? #e1e10))
(test #t (real? +inf.0))
(test #f (rational? -inf.0))
;; (test #f (rational? -inf.0))
(test #t (rational? 6/10))
(test #t (rational? 6/3))
;; (test #t (integer? 3+0i))
@ -831,7 +831,7 @@
(test 1.0 (inexact (cos 0))) ;; may return exact number
(test -1.0 (cos 3.14159265358979))
(test 0.0 (inexact (tan 0))) ;; may return exact number
(test 1.5574077246549020703 (tan 1))
(test 1.557407724654902292371616567834 (tan 1))
(test 0.0 (asin 0))
(test 1.5707963267948965580 (asin 1))
@ -1596,7 +1596,6 @@
(test -1 (call-with-values * -))
#;
(test '(connect talk1 disconnect
connect talk2 disconnect)
(let ((path '())
@ -1619,29 +1618,29 @@
(test-begin "6.11 Exceptions")
;; (test 65
;; (with-exception-handler
;; (lambda (con) 42)
;; (lambda ()
;; (+ (raise-continuable "should be a number")
;; 23))))
(test 65
(with-exception-handler
(lambda (con) 42)
(lambda ()
(+ (raise-continuable "should be a number")
23))))
;; (test #t
;; (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
;; (test "BOOM!"
;; (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
;; (test '(1 2 3)
;; (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
(test #t
(error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
(test "BOOM!"
(error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
(test '(1 2 3)
(error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
;; (test #f
;; (file-error? (guard (exn (else exn)) (error "BOOM!"))))
;; (test #t
;; (file-error? (guard (exn (else exn)) (open-input-file " no such file "))))
(test #f
(file-error? (guard (exn (else exn)) (error "BOOM!"))))
(test #t
(file-error? (guard (exn (else exn)) (open-input-file " no such file "))))
;; (test #f
;; (read-error? (guard (exn (else exn)) (error "BOOM!"))))
;; (test #t
;; (read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
(test #f
(read-error? (guard (exn (else exn)) (error "BOOM!"))))
(test #t
(read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
(define something-went-wrong #f)
(define (test-exception-handler-1 v)
@ -1659,126 +1658,126 @@
(test '("condition: " an-error) something-went-wrong)
(set! something-went-wrong #f)
;; (define (test-exception-handler-2 v)
;; (guard (ex (else 'caught-another-exception))
;; (with-exception-handler
;; (lambda (x)
;; (set! something-went-wrong #t)
;; (list "exception:" x))
;; (lambda ()
;; (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
;; (test 106 (test-exception-handler-2 5))
;; (test #f something-went-wrong)
;; (test 'caught-another-exception (test-exception-handler-2 -1))
;; (test #t something-went-wrong)
(define (test-exception-handler-2 v)
(guard (ex (else 'caught-another-exception))
(with-exception-handler
(lambda (x)
(set! something-went-wrong #t)
(list "exception:" x))
(lambda ()
(+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
(test 106 (test-exception-handler-2 5))
(test #f something-went-wrong)
(test 'caught-another-exception (test-exception-handler-2 -1))
(test #t something-went-wrong)
;; Based on an example from R6RS-lib section 7.1 Exceptions.
;; R7RS section 6.11 Exceptions has a simplified version.
;; (let* ((out (open-output-string))
;; (value (with-exception-handler
;; (lambda (con)
;; (cond
;; ((not (list? con))
;; (raise con))
;; ((list? con)
;; (display (car con) out))
;; (else
;; (display "a warning has been issued" out)))
;; 42)
;; (lambda ()
;; (+ (raise-continuable
;; (list "should be a number"))
;; 23)))))
;; (test "should be a number" (get-output-string out))
;; (test 65 value))
(let* ((out (open-output-string))
(value (with-exception-handler
(lambda (con)
(cond
((not (list? con))
(raise con))
((list? con)
(display (car con) out))
(else
(display "a warning has been issued" out)))
42)
(lambda ()
(+ (raise-continuable
(list "should be a number"))
23)))))
(test "should be a number" (get-output-string out))
(test 65 value))
;; From SRFI-34 "Examples" section - #3
;; (define (test-exception-handler-3 v out)
;; (guard (condition
;; (else
;; (display "condition: " out)
;; (write condition out)
;; (display #\! out)
;; 'exception))
;; (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
;; (let* ((out (open-output-string))
;; (value (test-exception-handler-3 0 out)))
;; (test 'exception value)
;; (test "condition: an-error!" (get-output-string out)))
(define (test-exception-handler-3 v out)
(guard (condition
(else
(display "condition: " out)
(write condition out)
(display #\! out)
'exception))
(+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
(let* ((out (open-output-string))
(value (test-exception-handler-3 0 out)))
(test 'exception value)
(test "condition: an-error!" (get-output-string out)))
;; (define (test-exception-handler-4 v out)
;; (call-with-current-continuation
;; (lambda (k)
;; (with-exception-handler
;; (lambda (x)
;; (display "reraised " out)
;; (write x out) (display #\! out)
;; (k 'zero))
;; (lambda ()
;; (guard (condition
;; ((positive? condition)
;; 'positive)
;; ((negative? condition)
;; 'negative))
;; (raise v)))))))
(define (test-exception-handler-4 v out)
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (x)
(display "reraised " out)
(write x out) (display #\! out)
(k 'zero))
(lambda ()
(guard (condition
((positive? condition)
'positive)
((negative? condition)
'negative))
(raise v)))))))
;; From SRFI-34 "Examples" section - #5
;; (let* ((out (open-output-string))
;; (value (test-exception-handler-4 1 out)))
;; (test "" (get-output-string out))
;; (test 'positive value))
;; ;; From SRFI-34 "Examples" section - #6
;; (let* ((out (open-output-string))
;; (value (test-exception-handler-4 -1 out)))
;; (test "" (get-output-string out))
;; (test 'negative value))
;; ;; From SRFI-34 "Examples" section - #7
;; (let* ((out (open-output-string))
;; (value (test-exception-handler-4 0 out)))
;; (test "reraised 0!" (get-output-string out))
;; (test 'zero value))
(let* ((out (open-output-string))
(value (test-exception-handler-4 1 out)))
(test "" (get-output-string out))
(test 'positive value))
;; From SRFI-34 "Examples" section - #6
(let* ((out (open-output-string))
(value (test-exception-handler-4 -1 out)))
(test "" (get-output-string out))
(test 'negative value))
;; From SRFI-34 "Examples" section - #7
(let* ((out (open-output-string))
(value (test-exception-handler-4 0 out)))
(test "reraised 0!" (get-output-string out))
(test 'zero value))
;; From SRFI-34 "Examples" section - #8
;; (test 42
;; (guard (condition
;; ((assq 'a condition) => cdr)
;; ((assq 'b condition)))
;; (raise (list (cons 'a 42)))))
(test 42
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'a 42)))))
;; ;; From SRFI-34 "Examples" section - #9
;; (test '(b . 23)
;; (guard (condition
;; ((assq 'a condition) => cdr)
;; ((assq 'b condition)))
;; (raise (list (cons 'b 23)))))
;; From SRFI-34 "Examples" section - #9
(test '(b . 23)
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'b 23)))))
;; (test 'caught-d
;; (guard (condition
;; ((assq 'c condition) 'caught-c)
;; ((assq 'd condition) 'caught-d))
;; (list
;; (sqrt 8)
;; (guard (condition
;; ((assq 'a condition) => cdr)
;; ((assq 'b condition)))
;; (raise (list (cons 'd 24)))))))
(test 'caught-d
(guard (condition
((assq 'c condition) 'caught-c)
((assq 'd condition) 'caught-d))
(list
(sqrt 8)
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'd 24)))))))
(test-end)
(test-begin "6.12 Environments and evaluation")
;; (test 21 (eval '(* 7 3) (scheme-report-environment 5)))
(test 21 (eval '(* 7 3) (scheme-report-environment 5)))
;; (test 20
;; (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
;; (f + 10)))
(test 20
(let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
(f + 10)))
;; (test 1024 (eval '(expt 2 10) (environment '(scheme base))))
;; ;; (sin 0) may return exact number
;; (test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact)))))
;; ;; ditto
;; (test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0)))
;; (environment '(scheme base) '(scheme inexact))))
(test 1024 (eval '(expt 2 10) (environment '(scheme base))))
;; (sin 0) may return exact number
(test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact)))))
;; ditto
(test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0)))
(environment '(scheme base) '(scheme inexact))))
(test-end)
@ -2013,7 +2012,7 @@
(test 'Hello (read (open-input-string "|H\\x65;llo|")))
(test 'abc (read (open-input-string "#!fold-case ABC")))
(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
(test '|ABC| (read (open-input-string "#!fold-case #!no-fold-case ABC")))
(test 'def (read (open-input-string "#; abc def")))
(test 'def (read (open-input-string "; abc \ndef")))
@ -2026,6 +2025,12 @@
(test '(a . c) (read (open-input-string "(a . #;b c)")))
(test '(a . b) (read (open-input-string "(a . b #;c)")))
;; (define (test-read-error str)
;; (test #t
;; (guard (exn (else #t))
;; (read (open-input-string str))
;; #f)))
;; (test-read-error "(#;a . b)")
;; (test-read-error "(a . #;b)")
;; (test-read-error "(a #;. b)")
@ -2069,6 +2074,15 @@
(test-begin "Numeric syntax")
(define-syntax test-numeric-syntax
(syntax-rules ()
((test-numeric-syntax str expect strs ...)
(let* ((z (read (open-input-string str)))
(out (open-output-string))
(z-str (begin (write z out) (get-output-string out))))
(test expect (values z))
(test #t (and (member z-str '(str strs ...)) #t))))))
;; Simple
(test-numeric-syntax "1" 1)
;; (test-numeric-syntax "+1" 1 "1")
@ -2077,13 +2091,13 @@
;; (test-numeric-syntax "#I1" 1.0 "1.0" "1.")
;; (test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.")
;; ;; Decimal
(test-numeric-syntax "1.0" 1.0 "1.0" "1.")
(test-numeric-syntax "1." 1.0 "1.0" "1.")
(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
;; (test-numeric-syntax "1.0" 1.0 "1.0" "1.")
;; (test-numeric-syntax "1." 1.0 "1.0" "1.")
;; (test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
;; (test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
;; ;; Some Schemes don't allow negative zero. This is okay with the standard
(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
;; (test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
;; (test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
;; (test-numeric-syntax "#i1.0" 1.0 "1.0" "1.")
;; (test-numeric-syntax "#e1.0" 1 "1")
;; (test-numeric-syntax "#e-.0" 0 "0")
@ -2100,8 +2114,8 @@
;; (test-numeric-syntax "1l2" 100.0 "100.0" "100.")
;; (test-numeric-syntax "1L2" 100.0 "100.0" "100.")
;; ;; NaN, Inf
(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
;; (test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
;; (test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
@ -2110,10 +2124,10 @@
;; (test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0")
;; (test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0")
;; ;; Exact ratios
(test-numeric-syntax "1/2" (/ 1 2))
;; (test-numeric-syntax "1/2" (/ 1 2))
;; (test-numeric-syntax "#e1/2" (/ 1 2) "1/2")
(test-numeric-syntax "10/2" 5 "5")
(test-numeric-syntax "-1/2" (- (/ 1 2)))
;; (test-numeric-syntax "-1/2" (- (/ 1 2)))
(test-numeric-syntax "0/10" 0 "0")
;; (test-numeric-syntax "#e0/10" 0 "0")
;; (test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5")

11
t/renaming-import.scm Normal file
View File

@ -0,0 +1,11 @@
(define-library (foo)
(import (except (rename (prefix (only (scheme base) car cdr cons) my-)
(my-car my-kar)
(my-cdr my-kdr))
my-kar))
;; (import (rename (scheme base)
;; (car my-kar)
;; (cdr my-cdr)))
(export my-kdr my-cons))

306
tools/main.c
View File

@ -2,317 +2,27 @@
* See Copyright Notice in picrin.h
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <getopt.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/error.h"
#if PIC_ENABLE_READLINE
# include <editline/readline.h>
#endif
#define CODE_MAX_LENGTH 1024
#define LINE_MAX_LENGTH 256
void
print_help(void)
{
const char *help =
"picrin scheme\n"
"\n"
"Usage: picrin [options] [file]\n"
"\n"
"Options:\n"
" -e [program] run one liner ecript\n"
" -h show this help";
puts(help);
}
void
import_repllib(pic_state *pic)
{
int ai = pic_gc_arena_preserve(pic);
pic_import(pic, pic_read_cstr(pic, "(scheme base)"));
pic_import(pic, pic_read_cstr(pic, "(scheme load)"));
pic_import(pic, pic_read_cstr(pic, "(scheme process-context)"));
pic_import(pic, pic_read_cstr(pic, "(scheme read)"));
pic_import(pic, pic_read_cstr(pic, "(scheme write)"));
pic_import(pic, pic_read_cstr(pic, "(scheme file)"));
pic_import(pic, pic_read_cstr(pic, "(scheme inexact)"));
pic_import(pic, pic_read_cstr(pic, "(scheme cxr)"));
pic_import(pic, pic_read_cstr(pic, "(scheme lazy)"));
pic_import(pic, pic_read_cstr(pic, "(scheme time)"));
pic_import(pic, pic_read_cstr(pic, "(picrin macro)"));
#if DEBUG
puts("* imported repl libraries");
#endif
pic_gc_arena_restore(pic, ai);
}
int exit_status;
void
repl(pic_state *pic)
{
char code[CODE_MAX_LENGTH] = "", line[LINE_MAX_LENGTH];
char *prompt;
pic_value v, exprs;
int ai;
#if PIC_ENABLE_READLINE
char *read_line;
#else
char last_char;
int char_index;
#endif
#if PIC_ENABLE_READLINE
using_history();
char histfile[snprintf(NULL, 0, "%s/.picrin_history", getenv("HOME")) + 1];
sprintf(histfile, "%s/.picrin_history", getenv("HOME"));
read_history(histfile);
#endif
ai = pic_gc_arena_preserve(pic);
while (1) {
prompt = code[0] == '\0' ? "> " : "* ";
#if DEBUG
printf("[current ai = %d]\n", ai);
#endif
#if PIC_ENABLE_READLINE
read_line = readline(prompt);
if (read_line == NULL) {
goto eof;
}
else {
strncpy(line, read_line, LINE_MAX_LENGTH - 1);
add_history(read_line);
free(read_line);
}
#else
printf("%s", prompt);
char_index = 0;
while ((last_char = getchar()) != '\n') {
if (last_char == EOF)
goto eof;
if (char_index == LINE_MAX_LENGTH)
goto overflow;
line[char_index++] = last_char;
}
line[char_index] = '\0';
#endif
if (strlen(code) + strlen(line) >= CODE_MAX_LENGTH)
goto overflow;
strcat(code, line);
pic_try {
/* read */
exprs = pic_parse_cstr(pic, code);
if (pic_undef_p(exprs)) {
/* wait for more input */
}
else {
code[0] = '\0';
pic_for_each (v, exprs) {
/* eval */
v = pic_eval(pic, v);
/* print */
pic_printf(pic, "=> ~s\n", v);
}
}
}
pic_catch {
pic_print_backtrace(pic, pic->err);
pic->err = NULL;
code[0] = '\0';
}
pic_gc_arena_restore(pic, ai);
}
eof:
puts("");
exit_status = 0;
#if PIC_ENABLE_READLINE
write_history(histfile);
#endif
return;
overflow:
puts("** [fatal] line input overflow");
exit_status = 1;
return;
}
void
exec_file(pic_state *pic, const char *fname)
{
FILE *file;
pic_value v, exprs;
struct pic_proc *proc;
file = fopen(fname, "r");
if (file == NULL) {
fprintf(stderr, "fatal error: could not read %s\n", fname);
goto abort;
}
exprs = pic_parse_file(pic, file);
if (pic_undef_p(exprs)) {
fprintf(stderr, "fatal error: %s broken\n", fname);
goto abort;
}
pic_for_each (v, exprs) {
proc = pic_compile(pic, v);
if (proc == NULL) {
fputs(pic_errmsg(pic), stderr);
fprintf(stderr, "fatal error: %s compilation failure\n", fname);
goto abort;
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic_undef_p(v)) {
fputs(pic_errmsg(pic), stderr);
fprintf(stderr, "fatal error: %s evaluation failure\n", fname);
goto abort;
}
}
return;
abort:
exit_status = 1;
return;
}
void
exec_string(pic_state *pic, const char *str)
{
pic_value v, exprs;
struct pic_proc *proc;
int ai;
exprs = pic_parse_cstr(pic, str);
if (pic_undef_p(exprs)) {
goto abort;
}
ai = pic_gc_arena_preserve(pic);
pic_for_each (v, exprs) {
proc = pic_compile(pic, v);
if (proc == NULL) {
goto abort;
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic_undef_p(v)) {
goto abort;
}
pic_gc_arena_restore(pic, ai);
}
return;
abort:
exit_status = 1;
return;
}
static char *fname;
static char *script;
enum {
NO_MODE = 0,
INTERACTIVE_MODE,
FILE_EXEC_MODE,
ONE_LINER_MODE,
} mode;
void
parse_opt(int argc, char *argv[])
{
int r;
while (~(r = getopt(argc, argv, "he:"))) {
switch (r) {
case 'h':
print_help();
exit(0);
case 'e':
script = optarg;
mode = ONE_LINER_MODE;
}
}
argc -= optind;
argv += optind;
if (argc == 0) {
if (mode == NO_MODE)
mode = INTERACTIVE_MODE;
}
else {
fname = argv[0];
mode = FILE_EXEC_MODE;
}
}
int
main(int argc, char *argv[], char **envp)
{
pic_state *pic;
int status = 0;
pic = pic_open(argc, argv, envp);
parse_opt(argc, argv);
if (mode == INTERACTIVE_MODE || mode == ONE_LINER_MODE) {
import_repllib(pic);
pic_try {
pic_import(pic, pic_read_cstr(pic, "(picrin repl)"));
pic_funcall(pic, "repl", pic_nil_value());
}
switch (mode) {
case NO_MODE:
puts("logic flaw");
abort();
case INTERACTIVE_MODE:
repl(pic);
break;
case FILE_EXEC_MODE:
exec_file(pic, fname);
break;
case ONE_LINER_MODE:
exec_string(pic, script);
break;
pic_catch {
pic_print_backtrace(pic, pic->err);
status = 1;
}
pic_close(pic);
#if DEBUG
puts("* picrin successfully closed");
#endif
return exit_status;
return status;
}