Merge branch 'master' into doc

Conflicts:
	CMakeLists.txt

.gitmodules

@@ -1,12 +1,3 @@
-[submodule "extlib/xhash"]
-	path = extlib/xhash
-	url = git://github.com/wasabiz/xhash.git
-[submodule "extlib/xfile"]
-	path = extlib/xfile
-	url = git://github.com/wasabiz/xfile.git
-[submodule "extlib/xrope"]
-	path = extlib/xrope
-	url = git://github.com/wasabiz/xrope.git
-[submodule "extlib/xvect"]
-	path = extlib/xvect
-	url = git://github.com/wasabiz/xvect.git
+[submodule "extlib/benz"]
+	path = extlib/benz
+	url = git://github.com/picrin-scheme/benz.git

CMakeLists.txt

@@ -26,13 +26,12 @@ else()
   add_definitions(-std=c99)     # at least c99 is required
 endif()
 
-include_directories(include extlib)
+include_directories(extlib/benz/include)
 
 # build picrin
 include(piclib/CMakeLists.txt)
 include(contrib/CMakeLists.txt)
 include(src/CMakeLists.txt)
-include(tools/CMakeLists.txt)
 include(docs/CMakeLists.txt)
 
 # ----

README.md

@@ -1,21 +1,9 @@
-# Picrin [![Build Status](https://travis-ci.org/picrin-scheme/picrin.png)](https://travis-ci.org/picrin-scheme/picrin)
+<img width="500" src="https://raw.githubusercontent.com/picrin-scheme/picrin/master/etc/picrin-logo-fin01-02.png"></img>
 
-Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not requires any special external libraries installed on the platform.
+[![Build Status](https://travis-ci.org/picrin-scheme/picrin.png)](https://travis-ci.org/picrin-scheme/picrin)
+[![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)
 
-## Features
-
-- R7RS compatibility
-- reentrant design (all VM states are stored in single global state object)
-- bytecode interpreter (based on stack VM)
-- direct threaded VM
-- internal representation by nan-boxing
-- conservative call/cc implementation (users can freely interleave native stack with VM stack)
-- exact GC (simple mark and sweep, partially reference count is used as well)
-- string representation by rope data structure
-- support full set hygienic macro transformers, including implicit renaming macros
-- extended library syntax
-- advanced REPL support (multi-line input, etc)
-- tiny & portable library (all functions will be in `libpicrin.so`)
+Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not require any special external libraries installed on the platform.
 
 ## Documentation
 
@@ -83,7 +71,6 @@ If you execute `cmake` with debug flag `-DCMAKE_BUILD_TYPE=Debug`, it builds the
 Picrin scheme depends on some external libraries to build the binary:
 
 - perl
-- getopt
 - libedit (optional)
 - regex.h of POSIX.1 (optional)
 

contrib/05.r7rs/CMakeLists.txt

@@ -0,0 +1,15 @@
+list(APPEND PICLIB_SCHEME_LIBS
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/base.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/cxr.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/read.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/write.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/file.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/case-lambda.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/lazy.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/eval.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/inexact.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/load.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/process-context.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/time.scm
+  ${PROJECT_SOURCE_DIR}/contrib/05.r7rs/scheme/r5rs.scm
+  )

contrib/05.r7rs/scheme/base.scm

@@ -0,0 +1,519 @@
+(define-library (scheme base)
+  (import (picrin base)
+          (picrin macro)
+          (picrin record)
+          (picrin syntax-rules))
+
+  ;; 4.1.2. Literal expressions
+
+  (export quote)
+
+  ;; 4.1.4. Procedures
+
+  (export lambda)
+
+  ;; 4.1.5. Conditionals
+
+  (export if)
+
+  ;; 4.1.6. Assignments
+
+  (export set!)
+
+  ;; 4.1.7. Inclusion
+
+  (define-syntax include
+    (letrec ((read-file
+              (lambda (filename)
+                (call-with-port (open-input-file filename)
+                  (lambda (port)
+                    (let loop ((expr (read port)) (exprs '()))
+                      (if (eof-object? expr)
+                          (reverse exprs)
+                          (loop (read port) (cons expr exprs)))))))))
+      (er-macro-transformer
+       (lambda (form rename compare)
+         (let ((filenames (cdr form)))
+           (let ((exprs (apply append (map read-file filenames))))
+             `(,(rename 'begin) ,@exprs)))))))
+
+  (export include)
+
+  ;; 4.2.1. Conditionals
+
+  (export cond
+          case
+          else
+          =>
+          and
+          or
+          when
+          unless)
+
+  ;; 4.2.2. Binding constructs
+
+  (export let
+          let*
+          letrec
+          letrec*
+          let-values
+          let*-values)
+
+  ;; 4.2.3. Sequencing
+
+  (export begin)
+
+  ;; 4.2.4. Iteration
+
+  (export do)
+
+  ;; 4.2.6. Dynamic bindings
+
+  (export make-parameter
+          parameterize)
+
+  ;; 4.2.7. Exception handling
+
+  (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)
+
+  ;; 4.2.8. Quasiquotation
+
+  (export quasiquote
+          unquote
+          unquote-splicing)
+
+  ;; 4.3.1. Binding constructs for syntactic keywords
+
+  (export let-syntax
+          letrec-syntax)
+
+  ;; 4.3.2 Pattern language
+
+  (export syntax-rules
+          _
+          ...)
+
+  ;; 4.3.3. Signaling errors in macro transformers
+
+  (export syntax-error)
+
+  ;; 5.3. Variable definitions
+
+  (export define)
+
+  ;; 5.3.3. Multiple-value definitions
+
+  (export define-values)
+
+  ;; 5.4. Syntax definitions
+
+  (export define-syntax)
+
+  ;; 5.5 Recored-type definitions
+
+  (export define-record-type)
+
+  ;; 6.1. Equivalence predicates
+
+  (export eq?
+          eqv?
+          equal?)
+
+  ;; 6.2. Numbers
+
+  (define (exact-integer? x)
+    (and (exact? x)
+         (integer? x)))
+
+  (define (zero? x)
+    (= x 0))
+
+  (define (positive? x)
+    (> x 0))
+
+  (define (negative? x)
+    (< x 0))
+
+  (define (even? x)
+    (= x (* (exact (floor (/ x 2))) 2)))
+
+  (define (odd? x)
+    (not (even? x)))
+
+  (define (min . args)
+    (define (min a b)
+      (if (< a b) a b))
+    (let loop ((args args) (acc +inf.0) (exactp #t))
+      (if (null? args)
+          (if exactp acc (inexact acc))
+          (loop (cdr args) (min (car args) acc) (and (exact? (car args)) exactp)))))
+
+  (define (max . args)
+    (define (max a b)
+      (if (> a b) a b))
+    (let loop ((args args) (acc -inf.0) (exactp #t))
+      (if (null? args)
+          (if exactp acc (inexact acc))
+          (loop (cdr args) (max (car args) acc) (and (exact? (car args)) exactp)))))
+
+  (define (floor-quotient i j)
+    (call-with-values (lambda () (floor/ i j))
+      (lambda (q r)
+        q)))
+
+  (define (floor-remainder i j)
+    (call-with-values (lambda () (floor/ i j))
+      (lambda (q r)
+        r)))
+
+  (define (truncate-quotient i j)
+    (call-with-values (lambda () (truncate/ i j))
+      (lambda (q r)
+        q)))
+
+  (define (truncate-remainder i j)
+    (call-with-values (lambda () (truncate/ i j))
+      (lambda (q r)
+        r)))
+
+  (define (gcd . args)
+    (define (gcd i j)
+      (cond
+       ((> i j) (gcd j i))
+       ((< i 0) (gcd (- i) j))
+       ((> i 0) (gcd (truncate-remainder j i) i))
+       (else j)))
+    (let loop ((args args) (acc 0))
+      (if (null? args)
+          acc
+          (loop (cdr args)
+                (gcd acc (car args))))))
+
+  (define (lcm . args)
+    (define (lcm i j)
+      (/ (abs (* i j)) (gcd i j)))
+    (let loop ((args args) (acc 1))
+      (if (null? args)
+          acc
+          (loop (cdr args)
+                (lcm acc (car args))))))
+
+  (define (square x)
+    (* x x))
+
+  (define (exact-integer-sqrt k)
+    (let ((s (exact (sqrt k))))
+      (values s (- k (square s)))))
+
+  (export number?
+          complex?
+          real?
+          rational?
+          integer?
+          exact?
+          inexact?
+          exact-integer?
+          exact
+          inexact
+          =
+          <
+          >
+          <=
+          >=
+          zero?
+          positive?
+          negative?
+          odd?
+          even?
+          min
+          max
+          +
+          -
+          *
+          /
+          abs
+          floor-quotient
+          floor-remainder
+          floor/
+          truncate-quotient
+          truncate-remainder
+          truncate/
+          (rename truncate-quotient quotient)
+          (rename truncate-remainder remainder)
+          (rename floor-remainder modulo)
+          gcd
+          lcm
+          floor
+          ceiling
+          truncate
+          round
+          exact-integer-sqrt
+          square
+          expt
+          number->string
+          string->number)
+
+  ;; 6.3. Booleans
+
+  (export boolean?
+          boolean=?
+          not)
+
+  ;; 6.4 Pairs and lists
+
+  (export pair?
+          cons
+          car
+          cdr
+          set-car!
+          set-cdr!
+          null?
+          caar
+          cadr
+          cdar
+          cddr
+          list?
+          make-list
+          list
+          length
+          append
+          reverse
+          list-tail
+          list-ref
+          list-set!
+          list-copy
+          memq
+          memv
+          member
+          assq
+          assv
+          assoc)
+
+  ;; 6.5. Symbols
+
+  (export symbol?
+          symbol=?
+          symbol->string
+          string->symbol)
+
+  ;; 6.6. Characters
+
+  (export char?
+          char->integer
+          integer->char
+          char=?
+          char<?
+          char>?
+          char<=?
+          char>=?)
+
+  ;; 6.7. Strings
+
+  (export string?
+          string
+          make-string
+          string-length
+          string-ref
+          string-set!
+          string-copy
+          string-copy!
+          string-append
+          (rename string-copy substring)
+          string-fill!
+          string->list
+          list->string
+          string=?
+          string<?
+          string>?
+          string<=?
+          string>=?)
+
+  ;; 6.8. Vectors
+
+  (export vector?
+          vector
+          make-vector
+          vector-length
+          vector-ref
+          vector-set!
+          vector-copy!
+          vector-copy
+          vector-append
+          vector-fill!
+          list->vector
+          vector->list
+          string->vector
+          vector->string)
+
+  ;; 6.9. Bytevectors
+
+  (define (utf8->string v . opts)
+    (let ((start (if (pair? opts) (car opts) 0))
+          (end (if (>= (length opts) 2)
+                   (cadr opts)
+                   (bytevector-length v))))
+      (list->string (map integer->char (bytevector->list v start end)))))
+
+  (define (string->utf8 s . opts)
+    (let ((start (if (pair? opts) (car opts) 0))
+          (end (if (>= (length opts) 2)
+                   (cadr opts)
+                   (string-length s))))
+      (list->bytevector (map char->integer (string->list s start end)))))
+
+  (export bytevector?
+          bytevector
+          make-bytevector
+          bytevector-length
+          bytevector-u8-ref
+          bytevector-u8-set!
+          bytevector-copy
+          bytevector-copy!
+          bytevector-append
+          bytevector->list
+          list->bytevector
+          utf8->string
+          string->utf8)
+
+  ;; 6.10. Control features
+
+  (export procedure?
+          apply
+          map
+          for-each
+          string-map
+          string-for-each
+          vector-map
+          vector-for-each
+          call-with-current-continuation
+          call/cc
+          dynamic-wind
+          values
+          call-with-values)
+
+  ;; 6.11. Exceptions
+
+  (define (read-error? obj)
+    (and (error-object? obj)
+         (eq? (error-object-type obj) 'read)))
+
+  (define (file-error? obj)
+    (and (error-object? obj)
+         (eq? (error-object-type obj) 'file)))
+
+  (export with-exception-handler
+          raise
+          raise-continuable
+          error
+          error-object?
+          error-object-message
+          error-object-irritants
+          read-error?
+          file-error?)
+
+  ;; 6.13. Input and output
+
+  (export current-input-port
+          current-output-port
+          current-error-port
+
+          call-with-port
+
+          port?
+          input-port?
+          output-port?
+          textual-port?
+          binary-port?
+
+          (rename port-open? input-port-open?)
+          (rename port-open? output-port-open?)
+          close-port
+          (rename close-port close-input-port)
+          (rename close-port close-output-port)
+
+          open-input-string
+          open-output-string
+          get-output-string
+          open-input-bytevector
+          open-output-bytevector
+          get-output-bytevector
+
+          eof-object?
+          eof-object
+
+          read-char
+          peek-char
+          char-ready?
+          read-line
+          read-string
+
+          read-u8
+          peek-u8
+          u8-ready?
+          read-bytevector
+          read-bytevector!
+
+          newline
+          write-char
+          write-string
+          write-u8
+          write-bytevector
+          flush-output-port))

contrib/05.r7rs/scheme/eval.scm

@@ -1,15 +1,5 @@
 (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)))
+  (import (picrin base))
 
   (define environment
     (let ((counter 0))
@@ -24,6 +14,4 @@
            '(scheme base))
           library-name))))
 
-  (export null-environment
-          scheme-report-environment
-          environment))
+  (export environment eval))

contrib/05.r7rs/scheme/file.scm

@@ -1,5 +1,6 @@
 (define-library (scheme file)
-  (import (scheme base))
+  (import (picrin base)
+          (scheme base))
 
   (define (call-with-input-file filename callback)
     (call-with-port (open-input-file filename) callback))
@@ -19,7 +20,13 @@
         (parameterize ((current-output-port port))
           (thunk)))))
 
-  (export call-with-input-file
+  (export open-input-file
+          open-binary-input-file
+          open-output-file
+          open-binary-output-file
+          delete-file
+          file-exists?
+          call-with-input-file
           call-with-output-file
           with-input-from-file
           with-output-to-file))

contrib/05.r7rs/scheme/inexact.scm

@@ -0,0 +1,15 @@
+(define-library (scheme inexact)
+  (import (picrin base))
+
+  (export acos
+          asin
+          atan
+          cos
+          exp
+          finite?
+          infinite?
+          log
+          nan?
+          sin
+          sqrt
+          tan))

contrib/05.r7rs/scheme/load.scm

@@ -0,0 +1,4 @@
+(define-library (scheme load)
+  (import (picrin base))
+
+  (export load))

contrib/05.r7rs/scheme/process-context.scm

@@ -0,0 +1,8 @@
+(define-library (scheme process-context)
+  (import (picrin base))
+
+  (export command-line
+          emergency-exit
+          exit
+          get-environment-variable
+          get-environment-variables))

contrib/05.r7rs/scheme/r5rs.scm

@@ -9,6 +9,29 @@
           (scheme eval)
           (scheme load))
 
+  (define-library (scheme null)
+    (import (scheme base))
+    (export define
+            lambda
+            if
+            quote
+            quasiquote
+            unquote
+            unquote-splicing
+            begin
+            set!
+            define-syntax))
+
+  (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)))
+
   (export * + - / < <= = > >=
           abs acos and
           ;; angle

contrib/05.r7rs/scheme/read.scm

@@ -0,0 +1,4 @@
+(define-library (scheme read)
+  (import (picrin base))
+
+  (export read))

contrib/05.r7rs/scheme/time.scm

@@ -0,0 +1,6 @@
+(define-library (scheme time)
+  (import (picrin base))
+
+  (export current-jiffy
+          current-second
+          jiffies-per-second))

contrib/05.r7rs/scheme/write.scm

@@ -0,0 +1,7 @@
+(define-library (scheme write)
+  (import (picrin base))
+
+  (export write
+          write-simple
+          write-shared
+          display))

contrib/10.readline/CMakeLists.txt

@@ -4,8 +4,7 @@ set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${PROJECT_SOURCE_DIR}/contrib/10.rea
 
 find_package(Libedit)
 if (Libedit_FOUND)
-  add_definitions(${Libedit_DEFINITIONS} -DPIC_READLINE_FOUND=1)
-  add_definitions(${Libedit_DEFINITIONS} -DPIC_READLINE_INCLUDE_DIR_SUFFIX=${Libedit_INCLUDE_DIR_SUFFIX})
+  add_definitions(${Libedit_DEFINITIONS} -DPIC_READLINE_FOUND=1 -DPIC_READLINE_INCLUDE_DIR_SUFFIX=${Libedit_INCLUDE_DIR_SUFFIX})
   include_directories(${Libedit_INCLUDE_DIR})
 
   file(GLOB PICRIN_READLINE_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.readline/src/*.c)
@@ -15,4 +14,4 @@ if (Libedit_FOUND)
   list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_READLINE_SOURCES})
   add_custom_target(test-readline for test in ${PROJECT_SOURCE_DIR}/contrib/10.readline/t/*.scm \; do bin/picrin "$$test" \; done DEPENDS repl)
   set(CONTRIB_TESTS ${CONTRIB_TESTS} test-readline)
-endif()
+endif(Libedit_FOUND)

contrib/10.readline/cmake/FindLibedit.cmake

@@ -32,16 +32,14 @@ else (Libedit_LIBRARIES AND Libedit_INCLUDE_DIRS)
   endif (${CMAKE_MAJOR_VERSION} EQUAL 2 AND ${CMAKE_MINOR_VERSION} EQUAL 4)
   find_path(Libedit_EDITLINE_INCLUDE_DIR
     NAMES
-      readline.h
-      history.h
+      editline/readline.h
+      editline/history.h
     PATHS
       ${_Libedit_INCLUDEDIR}
       /usr/include
       /usr/local/include
       /opt/local/include
       /sw/include
-    PATH_SUFFIXES
-      editline
   )
   if (Libedit_EDITLINE_INCLUDE_DIR)
     set(Libedit_INCLUDE_DIR_SUFFIX editline)
@@ -49,15 +47,13 @@ else (Libedit_LIBRARIES AND Libedit_INCLUDE_DIRS)
   else (Libedit_EDITLINE_INCLUDE_DIR)
     find_path(Libedit_READLINE_INCLUDE_DIR
       NAMES
-        readline.h
-        history.h
+        readline/readline.h
+        readline/history.h
       PATHS
         /usr/include/edit
         /usr/local/include/edit
         /opt/local/include/edit
         /sw/include/edit
-      PATH_SUFFIXES
-        readline
         )
     if (Libedit_READLINE_INCLUDE_DIR)
       set(Libedit_INCLUDE_DIR_SUFFIX readline)
@@ -97,7 +93,7 @@ else (Libedit_LIBRARIES AND Libedit_INCLUDE_DIRS)
 
   if (Libedit_FOUND)
     if (NOT Libedit_FIND_QUIETLY)
-      message(STATUS "Found libedit: ${Libedit_LIBRARY}")
+      message(STATUS "Found libedit: ${Libedit_LIBRARY}, ${Libedit_INCLUDE_DIR}")
     endif (NOT Libedit_FIND_QUIETLY)
   else (Libedit_FOUND)
     if (Libedit_FIND_REQUIRED)

contrib/10.readline/src/readline.c

@@ -28,7 +28,7 @@ pic_rl_readline(pic_state *pic)
   result = readline(prompt);
 
   if(result)
-    return pic_obj_value(pic_str_new_cstr(pic, result));
+    return pic_obj_value(pic_make_str_cstr(pic, result));
   else
     return pic_eof_object();
 }
@@ -96,7 +96,7 @@ pic_rl_current_history(pic_state *pic)
 {
   pic_get_args(pic, "");
 
-  return pic_obj_value(pic_str_new_cstr(pic, current_history()->line));
+  return pic_obj_value(pic_make_str_cstr(pic, current_history()->line));
 }
 
 static pic_value
@@ -109,7 +109,7 @@ pic_rl_history_get(pic_state *pic)
   
   e = history_get(i);
 
-  return e ? pic_obj_value(pic_str_new_cstr(pic, e->line))
+  return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
     : pic_false_value();
 }
 
@@ -123,7 +123,7 @@ pic_rl_remove_history(pic_state *pic)
   
   e = remove_history(i);
 
-  return e ? pic_obj_value(pic_str_new_cstr(pic, e->line))
+  return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
     : pic_false_value();
 }
 
@@ -157,7 +157,7 @@ pic_rl_previous_history(pic_state *pic)
 
   e = previous_history();
 
-  return e ? pic_obj_value(pic_str_new_cstr(pic, e->line))
+  return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
     : pic_false_value();
 }
 
@@ -170,7 +170,7 @@ pic_rl_next_history(pic_state *pic)
 
   e = next_history();
 
-  return e ? pic_obj_value(pic_str_new_cstr(pic, e->line))
+  return e ? pic_obj_value(pic_make_str_cstr(pic, e->line))
     : pic_false_value();
 }
 
@@ -249,7 +249,7 @@ pic_rl_history_expand(pic_state *pic)
   if(status == -1 || status == 2)
     pic_errorf(pic, "%s\n", result);
 
-  return pic_obj_value(pic_str_new_cstr(pic, result));
+  return pic_obj_value(pic_make_str_cstr(pic, result));
 }
 
 void

contrib/10.regexp/src/regexp.c

@@ -21,7 +21,7 @@ regexp_dtor(pic_state *pic, void *data)
   pic_free(pic, data);
 }
 
-static const pic_data_type regexp_type = { "regexp", regexp_dtor };
+static const pic_data_type regexp_type = { "regexp", regexp_dtor, NULL };
 
 #define pic_regexp_p(o) (pic_data_type_p((o), &regexp_type))
 #define pic_regexp_data_ptr(o) ((struct pic_regexp_t *)pic_data_ptr(o)->data)
@@ -101,7 +101,7 @@ pic_regexp_regexp_match(pic_state *pic)
 
     offset = 0;
     while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, match, 0) != REG_NOMATCH) {
-      pic_push(pic, pic_obj_value(pic_str_new(pic, input, match[0].rm_eo - match[0].rm_so)), matches);
+      pic_push(pic, pic_obj_value(pic_make_str(pic, input, match[0].rm_eo - match[0].rm_so)), matches);
       pic_push(pic, pic_int_value(offset), positions);
 
       offset += match[0].rm_eo;
@@ -115,7 +115,7 @@ pic_regexp_regexp_match(pic_state *pic)
         if (match[i].rm_so == -1) {
           break;
         }
-        str = pic_str_new(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so);
+        str = pic_make_str(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so);
         pic_push(pic, pic_obj_value(str), matches);
         pic_push(pic, pic_int_value(match[i].rm_so), positions);
       }
@@ -145,12 +145,12 @@ pic_regexp_regexp_split(pic_state *pic)
   pic_assert_type(pic, reg, regexp);
 
   while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, &match, 0) != REG_NOMATCH) {
-    pic_push(pic, pic_obj_value(pic_str_new(pic, input, match.rm_so)), output);
+    pic_push(pic, pic_obj_value(pic_make_str(pic, input, match.rm_so)), output);
 
     input += match.rm_eo;
   }
 
-  pic_push(pic, pic_obj_value(pic_str_new_cstr(pic, input)), output);
+  pic_push(pic, pic_obj_value(pic_make_str_cstr(pic, input)), output);
 
   return pic_reverse(pic, output);
 }
@@ -161,20 +161,20 @@ pic_regexp_regexp_replace(pic_state *pic)
   pic_value reg;
   const char *input;
   regmatch_t match;
-  pic_str *txt, *output = pic_str_new(pic, NULL, 0);
+  pic_str *txt, *output = pic_make_str(pic, NULL, 0);
 
   pic_get_args(pic, "ozs", &reg, &input, &txt);
 
   pic_assert_type(pic, reg, regexp);
 
   while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, &match, 0) != REG_NOMATCH) {
-    output = pic_strcat(pic, output, pic_str_new(pic, input, match.rm_so));
+    output = pic_strcat(pic, output, pic_make_str(pic, input, match.rm_so));
     output = pic_strcat(pic, output, txt);
 
     input += match.rm_eo;
   }
 
-  output = pic_strcat(pic, output, pic_str_new(pic, input, strlen(input)));
+  output = pic_strcat(pic, output, pic_make_str(pic, input, strlen(input)));
 
   return pic_obj_value(output);
 }

contrib/10.srfi/CMakeLists.txt

@@ -0,0 +1,10 @@
+list(APPEND PICLIB_CONTRIB_LIBS
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/1.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/8.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/17.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/26.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/43.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/60.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/95.scm
+  ${PROJECT_SOURCE_DIR}/contrib/10.srfi/srfi/111.scm
+  )

contrib/10.srfi/srfi/17.scm

@@ -3,10 +3,10 @@
   (import (except (scheme base) set!)
           (prefix (only (scheme base) set!) %)
           (picrin dictionary)
-          (picrin attribute)
+          (except (picrin base) set!)
           (srfi 1)
           (srfi 8))
-  
+
   (define-syntax set!
     (syntax-rules ()
       ((_ (proc args ...) val)

contrib/20.repl/repl.scm

@@ -2,51 +2,70 @@
   (import (scheme base)
           (scheme read)
           (scheme write)
-          (scheme eval)
-          (picrin macro)
-          (picrin library))
+          (scheme eval))
 
-  ;; FIXME picrin doesn't offer cond-expand for now, so we define a macro ourselves
-  (define-syntax define-readline
-    (er-macro-transformer
-     (lambda (form rename compare)
-       (if (member '(picrin readline) (libraries))
-           `(import (picrin readline)
-                    (picrin readline history))
-           `(begin
-              (define (readline str)
-                (display str)
-                (read-line))
-              (define (add-history str)
-                #f))))))
+  (cond-expand
+   ((library (picrin readline))
+    (import (picrin readline)
+            (picrin readline history)))
+   (else
+    (begin
+      (define (readline str)
+        (display str)
+        (read-line))
+      (define (add-history str)
+        #f))))
 
-  (define-readline)
+  (eval
+   '(import (scheme base)
+            (scheme load)
+            (scheme process-context)
+            (scheme read)
+            (scheme write)
+            (scheme file)
+            (scheme inexact)
+            (scheme cxr)
+            (scheme lazy)
+            (scheme time)
+            (picrin macro)
+            (picrin dictionary)
+            (picrin array)
+            (picrin library))
+   '(picrin user))
 
   (define (repl)
-    (let ((line (readline "> ")))
-      (if (eof-object? line)
-          (newline)                     ; exit
-          (begin
-            (add-history line)
-            (call/cc
-             (lambda (exit)
-              (with-exception-handler
-               (lambda (condition)
-                 (display (error-object-message condition) (current-error-port))
-                 (newline)
-                 (exit))
-               (lambda ()
-                 ;; FIXME
-                 ;; non-local exception jump from inside call-with-port
-                 ;; fails with segv, though i don't know why...
-                 (let ((port (open-input-string line)))
-                   (let loop ((expr (read port)))
-                     (unless (eof-object? expr)
-                       (write (eval expr '(picrin user)))
-                       (newline)
-                       (loop (read port))))
-                   (close-port port))))))
-            (repl)))))
+    (let loop ((buf ""))
+      (let ((line (readline (if (equal? buf "") "> " "* "))))
+        (if (eof-object? line)
+            (newline)                   ; exit
+            (let ((str (string-append buf line "\n")))
+              (add-history line)
+              (call/cc
+               (lambda (exit)
+                 (with-exception-handler
+                  (lambda (condition)
+                    (if (error-object? condition)
+                        (unless (equal? (error-object-message condition) "unexpected EOF")
+                          (display "error: ")
+                          (display (error-object-message condition))
+                          (newline)
+                          (set! str ""))
+                        (begin
+                          (display "raised: ")
+                          (write condition)
+                          (newline)
+                          (set! str "")))
+                    (exit))
+                  (lambda ()
+                    (call-with-port (open-input-string str)
+                      (lambda (port)
+                        (let next ((expr (read port)))
+                          (unless (eof-object? expr)
+                            (write (eval expr '(picrin user)))
+                            (newline)
+                            (set! str "")
+                            (next (read port))))))))))
+              (loop str))))))
 
   (export repl))
 

contrib/30.main/main.scm

@@ -14,6 +14,7 @@
     (display "\n")
     (display "Options:\n")
     (display "  -e [program]		run one liner script\n")
+    (display "  -l [file]		load the file then enter repl\n")
     (display "  -h or --help		show this help\n"))
 
   (define (getopt)
@@ -26,6 +27,8 @@
              (exit 1))
             ((-e)
              (values 'line (cadr args)))
+            ((-l)
+             (values 'load (cadr args)))
             (else
              (values 'file (car args)))))))
 
@@ -45,6 +48,7 @@
       (lambda (type dat)
         (case type
           ((repl) (repl))
+          ((load) (load dat) (repl))
           ((line) (exec-line dat))
           ((file) (exec-file dat))))))
 

docs/deploy.rst

@@ -64,7 +64,6 @@ Requirement
 Picrin scheme depends on some external libraries to build the binary:
 
 - perl
-- getopt
 - readline (optional)
 - regex.h of POSIX.1 (optional)
 

docs/intro.rst

@@ -1,7 +1,7 @@
 Introduction
 ============
 
-Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not requires any special external libraries installed on the platform.
+Picrin is a lightweight scheme implementation intended to comply with full R7RS specification. Its code is written in pure C99 and does not require any special external libraries installed on the platform.
 
 - R7RS compatibility
 - reentrant design (all VM states are stored in single global state object)

docs/lang.rst

@@ -42,7 +42,7 @@ section                                          status     comments
 4.1.5 Conditionals                               yes        In picrin ``(if #f #f)`` returns ``#f``
 4.1.6 Assignments                                yes
 4.1.7 Inclusion                                  incomplete ``include-ci``
-4.2.1 Conditionals                               incomplete TODO: ``cond-expand``
+4.2.1 Conditionals                               yes
 4.2.2 Binding constructs                         yes
 4.2.3 Sequencing                                 yes
 4.2.4 Iteration                                  yes
@@ -57,7 +57,7 @@ section                                          status     comments
 5.1 Programs                                     yes
 5.2 Import declarations                          yes
 5.3.1 Top level definitions                      yes
-5.3.2 Internal definitions                       yes        TODO: interreferential definitions
+5.3.2 Internal definitions                       yes
 5.3.3 Multiple-value definitions                 yes
 5.4 Syntax definitions                           yes
 5.5 Recored-type definitions                     yes

docs/libs.rst

@@ -18,30 +18,46 @@ Scheme standard libraries
 SRFI libraries
 --------------
 
-- (srfi 1)
+- `(srfi 1)
+  <http://srfi.schemers.org/srfi-0/>`_
 
   List library.
 
-- (srfi 8)
+- `(srfi 8)
+  <http://srfi.schemers.org/srfi-8/>`_
 
   ``receive`` macro.
 
-- (srfi 26)
+- `(srfi 17)
+  <http://srfi.schemers.org/srfi-17/>`_
+
+  Generalized set!
+
+- `(srfi 26)
+  <http://srfi.schemers.org/srfi-26/>`_
 
   Cut/cute macros.
 
-- (srfi 43)
+- `(srfi 43)
+  <http://srfi.schemers.org/srfi-43/>`_
 
   Vector library.
 
-- (srfi 60)
+- `(srfi 60)
+  <http://srfi.schemers.org/srfi-60/>`_
 
   Bitwise operations.
 
-- (srfi 95)
+- `(srfi 95)
+  <http://srfi.schemers.org/srfi-95/>`_
 
   Sorting and Marging.
 
+- `(srfi 111)
+  <http://srfi.schemers.org/srfi-111/>`_
+
+  Boxes
+
 (picrin macro)
 --------------
 
@@ -140,7 +156,7 @@ Technically, picrin's array is implemented as a ring-buffer, effective double-en
 (picrin dictionary)
 -------------------
 
-Symbol to Object table. Internally it is implemented on hash-table.
+Object-to-object table. Internally it is implemented on hash-table. Equivalence is tested with equal? procedure.
 
 Note that dictionary is not a weak map; if you are going to make a highly memory-consuming program with dictionaries, you should know that dictionaries keep their bound objects and never let them free until you explicitly deletes bindings.
 
@@ -154,7 +170,7 @@ Note that dictionary is not a weak map; if you are going to make a highly memory
 
 - **(dictionary-ref dict key)**
 
-  Look up dictionary dict for a value associated with symbol key. It returns two values: first is the associated value if exists, and second is a boolean of lookup result.
+  Look up dictionary dict for a value associated with key. It returns two values: first is the associated value if exists, and second is a boolean of lookup result.
 
 - **(dictionary-set! dict key obj)**
 

etc/srfi.txt

@@ -12,7 +12,7 @@ y  SRFI 1: List Library
    SRFI 13: String Library
    SRFI 14: Character-Set Library
 7  SRFI 16: Syntax for procedures of variable arity
-   SRFI 17: Generalized set!
+y  SRFI 17: Generalized set!
    SRFI 18: Multithreading support
    SRFI 19: Time Data Types and Procedures
    SRFI 21: Real-time multithreading support
@@ -78,4 +78,4 @@ y  SRFI 1: List Library
    SRFI 108: Named quasi-literal constructors
    SRFI 109: Extended string quasi-literals
    SRFI 110: Sweet-expressions (t-expressions)
-   SRFI 111: Boxes
+y  SRFI 111: Boxes

extlib/benz

@@ -0,0 +1 @@
+Subproject commit 1d7669a5d4a1ece8d73268166917677e99671136

extlib/xfile

@@ -1 +0,0 @@
-Subproject commit e9d634ff99d1a954af3fa80dc2f2ccb1227b4a2b

extlib/xhash

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

extlib/xrope

@@ -1 +0,0 @@
-Subproject commit 32d99fae069c1ec7bf0fc31345bfc27cae84b47a

extlib/xvect

@@ -1 +0,0 @@
-Subproject commit 973b9f3d89ff4669d08f1bc28e205bd9834bef10

include/picrin.h

@@ -1,223 +0,0 @@
-/**
- * Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors.
- *
- * Permission is hereby granted, free of charge, to any person obtaining
- * a copy of this software and associated documentation files (the
- * "Software"), to deal in the Software without restriction, including
- * without limitation the rights to use, copy, modify, merge, publish,
- * distribute, sublicense, and/or sell copies of the Software, and to
- * permit persons to whom the Software is furnished to do so, subject to
- * the following conditions:
- *
- * The above copyright notice and this permission notice shall be
- * included in all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
- * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
- * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
- * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
- * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
- */
-
-#ifndef PICRIN_H__
-#define PICRIN_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-#include <stddef.h>
-#include <stdbool.h>
-#include <setjmp.h>
-#include <stdio.h>
-#include <stdint.h>
-#include <limits.h>
-#include <assert.h>
-
-#include "xvect/xvect.h"
-#include "xhash/xhash.h"
-#include "xfile/xfile.h"
-#include "xrope/xrope.h"
-
-#include "picrin/config.h"
-#include "picrin/util.h"
-#include "picrin/value.h"
-
-typedef struct pic_code pic_code;
-
-typedef struct {
-  int argc, retc;
-  pic_code *ip;
-  pic_value *fp;
-  struct pic_env *env;
-  int regc;
-  pic_value *regs;
-  struct pic_env *up;
-} pic_callinfo;
-
-typedef struct {
-  int argc;
-  char **argv, **envp;
-
-  struct pic_block *blk;
-
-  pic_value *sp;
-  pic_value *stbase, *stend;
-
-  pic_callinfo *ci;
-  pic_callinfo *cibase, *ciend;
-
-  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, sIMPORT, sEXPORT;
-  pic_sym sDEFINE_LIBRARY, sIN_LIBRARY;
-  pic_sym sCONS, sCAR, sCDR, sNILP;
-  pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
-  pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
-
-  pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
-  pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT;
-  pic_sym rDEFINE_LIBRARY, rIN_LIBRARY;
-
-  xhash syms;                   /* name to symbol */
-  xhash sym_names;              /* symbol to name */
-  int sym_cnt;
-  int uniq_sym_cnt;
-
-  xhash globals;
-  xhash macros;
-  pic_value libs;
-
-  struct pic_reader *reader;
-
-  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;
-  size_t arena_size, arena_idx;
-
-  char *native_stack_start;
-} pic_state;
-
-typedef pic_value (*pic_func_t)(pic_state *);
-
-void *pic_alloc(pic_state *, size_t);
-#define pic_malloc(pic,size) pic_alloc(pic,size) /* obsoleted */
-void *pic_realloc(pic_state *, void *, size_t);
-void *pic_calloc(pic_state *, size_t, size_t);
-struct pic_object *pic_obj_alloc(pic_state *, size_t, enum pic_tt);
-struct pic_object *pic_obj_alloc_unsafe(pic_state *, size_t, enum pic_tt);
-void pic_free(pic_state *, void *);
-
-void pic_gc_run(pic_state *);
-pic_value pic_gc_protect(pic_state *, pic_value);
-size_t pic_gc_arena_preserve(pic_state *);
-void pic_gc_arena_restore(pic_state *, size_t);
-#define pic_void(exec)                          \
-  pic_void_(GENSYM(ai), exec)
-#define pic_void_(ai,exec) do {                 \
-    size_t ai = pic_gc_arena_preserve(pic);     \
-    exec;                                       \
-    pic_gc_arena_restore(pic, ai);              \
-  } while (0)
-
-pic_state *pic_open(int argc, char *argv[], char **envp);
-void pic_close(pic_state *);
-
-void pic_define(pic_state *, const char *, pic_value); /* automatic export */
-pic_value pic_ref(pic_state *, const char *);
-void pic_set(pic_state *, const char *, pic_value);
-
-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);
-
-bool pic_equal_p(pic_state *, pic_value, pic_value);
-
-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 *);
-char *pic_strndup(pic_state *, const char *, size_t);
-
-pic_value pic_read(pic_state *, struct pic_port *);
-pic_value pic_read_cstr(pic_state *, const char *);
-pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */
-pic_list pic_parse_cstr(pic_state *, const char *);
-
-pic_value pic_load(pic_state *, const char *);
-pic_value pic_load_cstr(pic_state *, const char *);
-
-pic_value pic_apply(pic_state *, struct pic_proc *, pic_value);
-pic_value pic_apply0(pic_state *, struct pic_proc *);
-pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value);
-pic_value pic_apply2(pic_state *, struct pic_proc *, pic_value, pic_value);
-pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value);
-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_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(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)
-
-void pic_import(pic_state *, pic_value);
-void pic_export(pic_state *, pic_sym);
-
-noreturn void pic_abort(pic_state *, const char *);
-noreturn void pic_errorf(pic_state *, const char *, ...);
-void pic_warnf(pic_state *, const char *, ...);
-pic_str *pic_get_backtrace(pic_state *);
-void pic_print_backtrace(pic_state *, struct pic_error *);
-
-/* obsoleted */
-noreturn static inline void pic_error(pic_state *pic, const char *msg)
-{
-  pic_errorf(pic, msg);
-}
-static inline void pic_warn(pic_state *pic, const char *msg)
-{
-  pic_warnf(pic, msg);
-}
-
-const char *pic_errmsg(pic_state *);
-
-pic_value pic_write(pic_state *, pic_value); /* returns given obj */
-pic_value pic_fwrite(pic_state *, pic_value, xFILE *);
-void pic_printf(pic_state *, const char *, ...);
-pic_value pic_display(pic_state *, pic_value);
-pic_value pic_fdisplay(pic_state *, pic_value, xFILE *);
-/* obsoleted macros */
-#define pic_debug(pic,obj) pic_write(pic,obj)
-#define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file)
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/blob.h

@@ -1,27 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_BLOB_H__
-#define PICRIN_BLOB_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_blob {
-  PIC_OBJECT_HEADER
-  char *data;
-  size_t len;
-};
-
-#define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB)
-#define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v))
-
-struct pic_blob *pic_blob_new(pic_state *, size_t);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/config.h

@@ -1,115 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-/** contribution libraries */
-/* #define PIC_CONTRIB_INITS */
-
-/** switch normal VM and direct threaded VM */
-/* #define PIC_DIRECT_THREADED_VM 1 */
-
-/** switch internal value representation */
-/* #define PIC_NAN_BOXING 1 */
-
-/** enable readline module */
-/* #define PIC_ENABLE_READLINE 1 */
-
-/** treat false value as none */
-/* #define PIC_NONE_IS_FALSE 1 */
-
-/** initial memory size (to be dynamically extended if necessary) */
-/* #define PIC_ARENA_SIZE 1000 */
-
-/* #define PIC_HEAP_PAGE_SIZE 10000 */
-
-/* #define PIC_STACK_SIZE 1024 */
-
-/* #define PIC_RESCUE_SIZE 30 */
-
-/* #define PIC_SYM_POOL_SIZE 128 */
-
-/* #define PIC_IREP_SIZE 8 */
-
-/* #define PIC_POOL_SIZE 8 */
-
-/* #define PIC_ISEQ_SIZE 1024 */
-
-/** enable all debug flags */
-/* #define DEBUG 1 */
-
-/** auxiliary debug flags */
-/* #define GC_STRESS 1 */
-/* #define VM_DEBUG 1 */
-/* #define GC_DEBUG 1 */
-/* #define GC_DEBUG_DETAIL 1 */
-
-#if __STDC_VERSION__ < 199901L
-# error please activate c99 features
-#endif
-
-#ifndef PIC_CONTRIB_INITS
-# define PIC_CONTRIB_INITS
-#endif
-
-#ifndef PIC_DIRECT_THREADED_VM
-# if defined(__GNUC__) || defined(__CLANG__)
-#  define PIC_DIRECT_THREADED_VM 1
-# endif
-#endif
-
-#ifndef PIC_NAN_BOXING
-# if __x86_64__ && __STDC_VERSION__ >= 201112L
-#  define PIC_NAN_BOXING 1
-# endif
-#endif
-
-#ifndef PIC_ENABLE_READLINE
-# if PIC_READLINE_FOUND
-#  define PIC_ENABLE_READLINE 1
-# else
-#  define PIC_ENABLE_READLINE 0
-# endif
-#endif
-
-#ifndef PIC_NONE_IS_FALSE
-# define PIC_NONE_IS_FALSE 1
-#endif
-
-#ifndef PIC_ARENA_SIZE
-# define PIC_ARENA_SIZE 1000
-#endif
-
-#ifndef PIC_HEAP_PAGE_SIZE
-# define PIC_HEAP_PAGE_SIZE 10000
-#endif
-
-#ifndef PIC_STACK_SIZE
-# define PIC_STACK_SIZE 1024
-#endif
-
-#ifndef PIC_RESCUE_SIZE
-# define PIC_RESCUE_SIZE 30
-#endif
-
-#ifndef PIC_SYM_POOL_SIZE
-# define PIC_SYM_POOL_SIZE 128
-#endif
-
-#ifndef PIC_IREP_SIZE
-# define PIC_IREP_SIZE 8
-#endif
-
-#ifndef PIC_POOL_SIZE
-# define PIC_POOL_SIZE 8
-#endif
-
-#ifndef PIC_ISEQ_SIZE
-# define PIC_ISEQ_SIZE 1024
-#endif
-
-#if DEBUG
-# define GC_STRESS 0
-# define VM_DEBUG 1
-# define GC_DEBUG 0
-# define GC_DEBUG_DETAIL 0
-#endif

include/picrin/cont.h

@@ -1,62 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_CONT_H__
-#define PICRIN_CONT_H__
-
-#if defined(__cplusplus)
-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;
-
-  struct pic_block *blk;
-
-  char *stk_pos, *stk_ptr;
-  ptrdiff_t stk_len;
-
-  pic_value *st_ptr;
-  size_t sp_offset, st_len;
-
-  pic_callinfo *ci_ptr;
-  size_t ci_offset, ci_len;
-
-  pic_code *ip;
-
-  struct pic_object **arena;
-  size_t arena_size;
-  int arena_idx;
-
-  struct pic_jmpbuf *try_jmps;
-  size_t try_jmp_idx, try_jmp_size;
-
-  pic_value results;
-};
-
-pic_value pic_values0(pic_state *);
-pic_value pic_values1(pic_state *, pic_value);
-pic_value pic_values2(pic_state *, pic_value, pic_value);
-pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value);
-pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_values_by_array(pic_state *, size_t, pic_value *);
-pic_value pic_values_by_list(pic_state *, pic_value);
-size_t pic_receive(pic_state *, size_t, pic_value *);
-
-pic_value pic_callcc(pic_state *, struct pic_proc *);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/data.h

@@ -1,37 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_DATA_H__
-#define PICRIN_DATA_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-typedef struct {
-  const char *type_name;
-  void (*dtor)(pic_state *, void *);
-} pic_data_type;
-
-struct pic_data {
-  PIC_OBJECT_HEADER;
-  const pic_data_type *type;
-  xhash storage;                /* const char * to pic_value table */
-  void *data;
-};
-
-#define pic_data_p(o) (pic_type(o) == PIC_TT_DATA)
-#define pic_data_ptr(o) ((struct pic_data *)pic_ptr(o))
-
-static inline bool pic_data_type_p(const pic_value obj, const pic_data_type *type) {
-  return pic_data_p(obj) && pic_data_ptr(obj)->type == type;
-}
-
-struct pic_data *pic_data_alloc(pic_state *, const pic_data_type *, void *);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/dict.h

@@ -1,32 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_DICT_H__
-#define PICRIN_DICT_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_dict {
-  PIC_OBJECT_HEADER
-  xhash hash;
-};
-
-#define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT)
-#define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v))
-
-struct pic_dict *pic_dict_new(pic_state *);
-
-pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym);
-void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value);
-void pic_dict_del(pic_state *, struct pic_dict *, pic_sym);
-size_t pic_dict_size(pic_state *, struct pic_dict *);
-bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/error.h

@@ -1,60 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_ERROR_H__
-#define PICRIN_ERROR_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_jmpbuf {
-  jmp_buf here;
-  struct pic_proc *handler;
-  ptrdiff_t ci_offset;
-  ptrdiff_t sp_offset;
-  pic_code *ip;
-  jmp_buf *prev_jmp;
-};
-
-/* do not return from try block! */
-
-#define pic_try                                 \
-  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                               \
-    while (pic_pop_try(pic), 0);                \
-  else                                          \
-    if (pic_pop_try(pic), 1)
-
-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);
-noreturn void pic_throw_error(pic_state *, struct pic_error *);
-
-struct pic_error {
-  PIC_OBJECT_HEADER
-  enum pic_error_kind {
-    PIC_ERROR_OTHER,
-    PIC_ERROR_FILE,
-    PIC_ERROR_READ,
-    PIC_ERROR_RAISED
-  } type;
-  struct pic_string *msg;
-  pic_value irrs;
-  pic_str *stack;
-};
-
-#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR)
-#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v))
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/gc.h

@@ -1,24 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_GC_H__
-#define PICRIN_GC_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-#define PIC_GC_UNMARK 0
-#define PIC_GC_MARK 1
-
-struct pic_heap;
-
-struct pic_heap *pic_heap_open();
-void pic_heap_close(struct pic_heap *);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/irep.h

@@ -1,206 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_IREP_H__
-#define PICRIN_IREP_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-enum pic_opcode {
-  OP_NOP,
-  OP_POP,
-  OP_PUSHNIL,
-  OP_PUSHTRUE,
-  OP_PUSHFALSE,
-  OP_PUSHINT,
-  OP_PUSHCHAR,
-  OP_PUSHCONST,
-  OP_GREF,
-  OP_GSET,
-  OP_LREF,
-  OP_LSET,
-  OP_CREF,
-  OP_CSET,
-  OP_JMP,
-  OP_JMPIF,
-  OP_NOT,
-  OP_CALL,
-  OP_TAILCALL,
-  OP_RET,
-  OP_LAMBDA,
-  OP_CONS,
-  OP_CAR,
-  OP_CDR,
-  OP_NILP,
-  OP_ADD,
-  OP_SUB,
-  OP_MUL,
-  OP_DIV,
-  OP_MINUS,
-  OP_EQ,
-  OP_LT,
-  OP_LE,
-  OP_STOP
-};
-
-struct pic_code {
-  enum pic_opcode insn;
-  union {
-    int i;
-    char c;
-    struct {
-      short depth;
-      short idx;
-    } r;
-  } u;
-};
-
-struct pic_irep {
-  PIC_OBJECT_HEADER
-  pic_sym name;
-  pic_code *code;
-  int argc, localc, capturec;
-  bool varg;
-  struct pic_irep **irep;
-  pic_value *pool;
-  size_t clen, ilen, plen;
-};
-
-pic_value pic_analyze(pic_state *, pic_value);
-struct pic_irep *pic_codegen(pic_state *, pic_value);
-
-static inline void
-pic_dump_code(pic_code c)
-{
-  printf("[%2d] ", c.insn);
-  switch (c.insn) {
-  case OP_NOP:
-    puts("OP_NOP");
-    break;
-  case OP_POP:
-    puts("OP_POP");
-    break;
-  case OP_PUSHNIL:
-    puts("OP_PUSHNIL");
-    break;
-  case OP_PUSHTRUE:
-    puts("OP_PUSHTRUE");
-    break;
-  case OP_PUSHFALSE:
-    puts("OP_PUSHFALSE");
-    break;
-  case OP_PUSHINT:
-    printf("OP_PUSHINT\t%d\n", c.u.i);
-    break;
-  case OP_PUSHCHAR:
-    printf("OP_PUSHCHAR\t%c\n", c.u.c);
-    break;
-  case OP_PUSHCONST:
-    printf("OP_PUSHCONST\t%d\n", c.u.i);
-    break;
-  case OP_GREF:
-    printf("OP_GREF\t%i\n", c.u.i);
-    break;
-  case OP_GSET:
-    printf("OP_GSET\t%i\n", c.u.i);
-    break;
-  case OP_LREF:
-    printf("OP_LREF\t%d\n", c.u.i);
-    break;
-  case OP_LSET:
-    printf("OP_LSET\t%d\n", c.u.i);
-    break;
-  case OP_CREF:
-    printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
-    break;
-  case OP_CSET:
-    printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx);
-    break;
-  case OP_JMP:
-    printf("OP_JMP\t%x\n", c.u.i);
-    break;
-  case OP_JMPIF:
-    printf("OP_JMPIF\t%x\n", c.u.i);
-    break;
-  case OP_NOT:
-    puts("OP_NOT");
-    break;
-  case OP_CALL:
-    printf("OP_CALL\t%d\n", c.u.i);
-    break;
-  case OP_TAILCALL:
-    printf("OP_TAILCALL\t%d\n", c.u.i);
-    break;
-  case OP_RET:
-    printf("OP_RET\t%d\n", c.u.i);
-    break;
-  case OP_LAMBDA:
-    printf("OP_LAMBDA\t%d\n", c.u.i);
-    break;
-  case OP_CONS:
-    puts("OP_CONS");
-    break;
-  case OP_CAR:
-    puts("OP_CAR");
-    break;
-  case OP_NILP:
-    puts("OP_NILP");
-    break;
-  case OP_CDR:
-    puts("OP_CDR");
-    break;
-  case OP_ADD:
-    puts("OP_ADD");
-    break;
-  case OP_SUB:
-    puts("OP_SUB");
-    break;
-  case OP_MUL:
-    puts("OP_MUL");
-    break;
-  case OP_DIV:
-    puts("OP_DIV");
-    break;
-  case OP_MINUS:
-    puts("OP_MINUS");
-    break;
-  case OP_EQ:
-    puts("OP_EQ");
-    break;
-  case OP_LT:
-    puts("OP_LT");
-    break;
-  case OP_LE:
-    puts("OP_LE");
-    break;
-  case OP_STOP:
-    puts("OP_STOP");
-    break;
-  }
-}
-
-static inline void
-pic_dump_irep(struct pic_irep *irep)
-{
-  unsigned i;
-
-  printf("## irep %p\n", (void *)irep);
-  printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec);
-  for (i = 0; i < irep->clen; ++i) {
-    printf("%02x ", i);
-    pic_dump_code(irep->code[i]);
-  }
-
-  for (i = 0; i < irep->ilen; ++i) {
-    pic_dump_irep(irep->irep[i]);
-  }
-}
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/lib.h

@@ -1,25 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_LIB_H__
-#define PICRIN_LIB_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_lib {
-  PIC_OBJECT_HEADER
-  pic_value name;
-  struct pic_senv *env;
-  xhash exports;
-};
-
-#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o))
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/macro.h

@@ -1,47 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_MACRO_H__
-#define PICRIN_MACRO_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_senv {
-  PIC_OBJECT_HEADER
-  xhash map;
-  struct pic_senv *up;
-};
-
-struct pic_macro {
-  PIC_OBJECT_HEADER
-  struct pic_proc *proc;
-  struct pic_senv *senv;
-};
-
-#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
-#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v))
-
-#define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
-#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
-
-struct pic_senv *pic_null_syntactic_environment(pic_state *);
-
-bool pic_identifier_p(pic_state *pic, pic_value obj);
-bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym);
-
-struct pic_senv *pic_senv_new(pic_state *, struct pic_senv *);
-
-pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
-bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */);
-void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);
-
-void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/pair.h

@@ -1,76 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_PAIR_H__
-#define PICRIN_PAIR_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_pair {
-  PIC_OBJECT_HEADER
-  pic_value car;
-  pic_value cdr;
-};
-
-#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR)
-#define pic_pair_ptr(o) ((struct pic_pair *)pic_ptr(o))
-
-pic_value pic_cons(pic_state *, pic_value, pic_value);
-pic_value pic_car(pic_state *, pic_value);
-pic_value pic_cdr(pic_state *, pic_value);
-void pic_set_car(pic_state *, pic_value, pic_value);
-void pic_set_cdr(pic_state *, pic_value, pic_value);
-
-bool pic_list_p(pic_value);
-pic_value pic_list1(pic_state *, pic_value);
-pic_value pic_list2(pic_state *, pic_value, pic_value);
-pic_value pic_list3(pic_state *, pic_value, pic_value, pic_value);
-pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value);
-pic_value pic_list_by_array(pic_state *, size_t, pic_value *);
-pic_value pic_make_list(pic_state *, int, pic_value);
-
-#define pic_for_each(var, list)                                 \
-  pic_for_each_helper__(var, GENSYM(tmp), list)
-#define pic_for_each_helper__(var, tmp, list)                           \
-  for (pic_value tmp = (list);                                          \
-       pic_nil_p(tmp) ? false : ((var = pic_car(pic, tmp)), true);      \
-       tmp = pic_cdr(pic, tmp))
-
-#define pic_push(pic, item, place) (place = pic_cons(pic, item, place))
-#define pic_pop(pic, place) (place = pic_cdr(pic, place))
-
-int pic_length(pic_state *, pic_value);
-pic_value pic_reverse(pic_state *, pic_value);
-pic_value pic_append(pic_state *, pic_value, pic_value);
-
-pic_value pic_memq(pic_state *, pic_value key, pic_value list);
-pic_value pic_memv(pic_state *, pic_value key, pic_value list);
-pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */);
-
-pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
-pic_value pic_assv(pic_state *, pic_value key, pic_value assoc);
-pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */);
-
-pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
-
-pic_value pic_caar(pic_state *, pic_value);
-pic_value pic_cadr(pic_state *, pic_value);
-pic_value pic_cdar(pic_state *, pic_value);
-pic_value pic_cddr(pic_state *, pic_value);
-
-pic_value pic_list_tail(pic_state *, pic_value, int);
-pic_value pic_list_ref(pic_state *, pic_value, int);
-void pic_list_set(pic_state *, pic_value, int, pic_value);
-pic_value pic_list_copy(pic_state *, pic_value);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/port.h

@@ -1,50 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_PORT_H__
-#define PICRIN_PORT_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-enum pic_port_flag {
-  PIC_PORT_IN = 1,
-  PIC_PORT_OUT = 2,
-  PIC_PORT_TEXT = 4,
-  PIC_PORT_BINARY = 8,
-};
-
-enum pic_port_status {
-  PIC_PORT_OPEN,
-  PIC_PORT_CLOSE,
-};
-
-struct pic_port {
-  PIC_OBJECT_HEADER
-  xFILE *file;
-  int flags;
-  int status;
-};
-
-#define pic_port_p(v) (pic_type(v) == PIC_TT_PORT)
-#define pic_port_ptr(v) ((struct pic_port *)pic_ptr(v))
-
-pic_value pic_eof_object();
-
-struct pic_port *pic_stdin(pic_state *);
-struct pic_port *pic_stdout(pic_state *);
-struct pic_port *pic_stderr(pic_state *);
-
-struct pic_port *pic_open_input_string(pic_state *, const char *);
-struct pic_port *pic_open_output_string(pic_state *);
-struct pic_string *pic_get_output_string(pic_state *, struct pic_port *);
-
-void pic_close_port(pic_state *pic, struct pic_port *);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/proc.h

@@ -1,62 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_PROC_H__
-#define PICRIN_PROC_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-/* native C function */
-struct pic_func {
-  pic_func_t f;
-  pic_sym name;
-};
-
-struct pic_env {
-  PIC_OBJECT_HEADER
-  pic_value *regs;
-  int regc;
-  struct pic_env *up;
-  pic_value storage[];
-};
-
-struct pic_proc {
-  PIC_OBJECT_HEADER
-  char kind;
-  union {
-    struct pic_func func;
-    struct pic_irep *irep;
-  } u;
-  struct pic_env *env;
-  struct pic_dict *attr;
-};
-
-#define PIC_PROC_KIND_FUNC 1
-#define PIC_PROC_KIND_IREP 2
-
-#define pic_proc_func_p(proc) ((proc)->kind == PIC_PROC_KIND_FUNC)
-#define pic_proc_irep_p(proc) ((proc)->kind == PIC_PROC_KIND_IREP)
-
-#define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC)
-#define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o))
-
-#define pic_env_p(o) (pic_type(o) == PIC_TT_ENV)
-#define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o))
-
-struct pic_proc *pic_proc_new(pic_state *, pic_func_t, const char *);
-struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_env *);
-
-pic_sym pic_proc_name(struct pic_proc *);
-
-struct pic_dict *pic_attr(pic_state *, struct pic_proc *);
-pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *);
-void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/read.h

@@ -1,39 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_READ_H__
-#define PICRIN_READ_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-enum pic_typecase {
-  PIC_CASE_DEFAULT,
-  PIC_CASE_FOLD,
-};
-
-struct pic_trie {
-  struct pic_trie *table[256];
-  struct pic_proc *proc;
-};
-
-struct pic_reader {
-  short typecase;
-  xhash labels;
-  struct pic_trie *trie;
-};
-
-void pic_init_reader(pic_state *);
-
-void pic_define_reader(pic_state *, const char *, pic_func_t);
-
-struct pic_trie *pic_trie_new(pic_state *);
-void pic_trie_delete(pic_state *, struct pic_trie *);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/record.h

@@ -1,30 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_RECORD_H
-#define PICRIN_RECORD_H
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_record {
-  PIC_OBJECT_HEADER
-  xhash     hash;
-};
-
-#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD)
-#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v))
-
-struct pic_record *pic_record_new(pic_state *, pic_value);
-
-pic_value pic_record_type(pic_state *, struct pic_record *);
-pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym);
-void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/string.h

@@ -1,42 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_STRING_H__
-#define PICRIN_STRING_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_string {
-  PIC_OBJECT_HEADER
-  xrope *rope;
-};
-
-#define pic_str_p(v) (pic_type(v) == PIC_TT_STRING)
-#define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o))
-
-pic_str *pic_str_new(pic_state *, const char * /* nullable */, size_t);
-pic_str *pic_str_new_cstr(pic_state *, const char *);
-pic_str *pic_str_new_fill(pic_state *, size_t, char);
-
-size_t pic_strlen(pic_str *);
-char pic_str_ref(pic_state *, pic_str *, size_t);
-void pic_str_set(pic_state *, pic_str *, size_t, char);
-
-pic_str *pic_strcat(pic_state *, pic_str *, pic_str *);
-pic_str *pic_substr(pic_state *, pic_str *, size_t, size_t);
-int pic_strcmp(pic_str *, pic_str *);
-
-const char *pic_str_cstr(pic_str *);
-
-pic_value pic_format(pic_state *, const char *, ...);
-pic_value pic_vformat(pic_state *, const char *, va_list);
-pic_value pic_vfformat(pic_state *, xFILE *, const char *, va_list);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/util.h

@@ -1,51 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_UTIL_H__
-#define PICRIN_UTIL_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-#if __STDC_VERSION__ >= 201112L
-# include <stdnoreturn.h>
-#elif __GNUC__ || __clang__
-# define noreturn __attribute__((noreturn))
-#else
-# define noreturn
-#endif
-
-#define FALLTHROUGH ((void)0)
-#define UNUSED(v) ((void)(v))
-
-#define GENSYM2__(x,y) G##x##_##y##__
-#define GENSYM1__(x,y) GENSYM2__(x,y)
-#if defined(__COUNTER__)
-# define GENSYM(x) GENSYM1__(__COUNTER__,x)
-#else
-# define GENSYM(x) GENSYM1__(__LINE__,x)
-#endif
-
-#if GCC_VERSION >= 40500 || __clang__
-# define UNREACHABLE() (__builtin_unreachable())
-#else
-# include <assert.h>
-# define UNREACHABLE() (assert(false))
-#endif
-
-#define SWAP(type,a,b)                          \
-  SWAP_HELPER__(type,GENSYM(tmp),a,b)
-#define SWAP_HELPER__(type,tmp,a,b)             \
-  do {                                          \
-    type tmp = (a);                             \
-    (a) = (b);                                  \
-    (b) = tmp;                                  \
-  } while (0)
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/value.h

@@ -1,484 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_VALUE_H__
-#define PICRIN_VALUE_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-/**
- * pic_sym is just an alias to unsigned int.
- */
-
-typedef int pic_sym;
-
-/**
- * `undef` values never seen from user-end: that is,
- *  it's used only for repsenting internal special state
- */
-
-enum pic_vtype {
-  PIC_VTYPE_NIL = 1,
-  PIC_VTYPE_TRUE,
-  PIC_VTYPE_FALSE,
-  PIC_VTYPE_UNDEF,
-  PIC_VTYPE_FLOAT,
-  PIC_VTYPE_INT,
-  PIC_VTYPE_SYMBOL,
-  PIC_VTYPE_CHAR,
-  PIC_VTYPE_EOF,
-  PIC_VTYPE_HEAP
-};
-
-#if PIC_NAN_BOXING
-
-/**
- * value representation by nan-boxing:
- *   float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
- *   ptr   : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
- *   int   : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
- *   sym   : 1111111111110111 0000000000000000 SSSSSSSSSSSSSSSS SSSSSSSSSSSSSSSS
- *   char  : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC ................
- */
-
-typedef struct {
-  union {
-    void *data;
-    double f;
-    struct {
-      union {
-	int i;
-	pic_sym sym;
-	char c;
-      };
-      uint32_t type_;
-    };
-  } u;
-} pic_value;
-
-#define pic_ptr(v) ((void *)((uint64_t)0xffffffffffff & (uint64_t)(v).u.data))
-#define pic_init_value(v,vtype) (((v).u.type_ = (((uint32_t)0xfff00000)|((uint32_t)((vtype)<<16)))), (v).u.i = 0)
-
-static inline enum pic_vtype
-pic_vtype(pic_value v)
-{
-  return 0xfff00000 >= v.u.type_
-    ? PIC_VTYPE_FLOAT
-    : (v.u.type_ & 0xf0000)>>16;
-}
-
-#else
-
-typedef struct {
-  enum pic_vtype type;
-  union {
-    void *data;
-    double f;
-    int i;
-    pic_sym sym;
-    char c;
-  } u;
-} pic_value;
-
-#define pic_ptr(v) ((v).u.data)
-#define pic_vtype(v) ((v).type)
-#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL)
-
-#endif
-
-enum pic_tt {
-  /* immediate */
-  PIC_TT_NIL,
-  PIC_TT_BOOL,
-  PIC_TT_FLOAT,
-  PIC_TT_INT,
-  PIC_TT_SYMBOL,
-  PIC_TT_CHAR,
-  PIC_TT_EOF,
-  PIC_TT_UNDEF,
-  /* heap */
-  PIC_TT_PAIR,
-  PIC_TT_STRING,
-  PIC_TT_VECTOR,
-  PIC_TT_BLOB,
-  PIC_TT_PROC,
-  PIC_TT_PORT,
-  PIC_TT_ERROR,
-  PIC_TT_ENV,
-  PIC_TT_CONT,
-  PIC_TT_SENV,
-  PIC_TT_MACRO,
-  PIC_TT_LIB,
-  PIC_TT_VAR,
-  PIC_TT_IREP,
-  PIC_TT_DATA,
-  PIC_TT_DICT,
-  PIC_TT_RECORD,
-  PIC_TT_BLK,
-};
-
-#define PIC_OBJECT_HEADER			\
-  enum pic_tt tt;
-
-struct pic_object {
-  PIC_OBJECT_HEADER
-};
-
-struct pic_pair;
-struct pic_string;
-struct pic_vector;
-struct pic_blob;
-
-struct pic_proc;
-struct pic_port;
-
-/* set aliases to basic types */
-typedef pic_value pic_list;
-typedef struct pic_pair pic_pair;
-typedef struct pic_string pic_str;
-typedef struct pic_vector pic_vec;
-typedef struct pic_blob pic_blob;
-
-#define pic_float(v) ((v).u.f)
-#define pic_int(v) ((v).u.i)
-#define pic_sym(v) ((v).u.sym)
-#define pic_char(v) ((v).u.c)
-
-#define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP)
-#define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v))
-
-#define pic_nil_p(v) (pic_vtype(v) == PIC_VTYPE_NIL)
-#define pic_true_p(v) (pic_vtype(v) == PIC_VTYPE_TRUE)
-#define pic_false_p(v) (pic_vtype(v) == PIC_VTYPE_FALSE)
-#define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF)
-#define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT)
-#define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT)
-#define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL)
-#define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR)
-#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF)
-
-#define pic_test(v) (! pic_false_p(v))
-
-static inline enum pic_tt pic_type(pic_value);
-static inline const char *pic_type_repr(enum pic_tt);
-
-#define pic_assert_type(pic, v, type)                           \
-  if (! pic_##type##_p(v)) {                                    \
-    pic_errorf(pic, "expected " #type ", but got ~s", v);       \
-  }
-
-static inline bool pic_valid_int(double);
-
-static inline pic_value pic_nil_value();
-static inline pic_value pic_true_value();
-static inline pic_value pic_false_value();
-static inline pic_value pic_bool_value(bool);
-static inline pic_value pic_undef_value();
-static inline pic_value pic_obj_value(void *);
-static inline pic_value pic_float_value(double);
-static inline pic_value pic_int_value(int);
-static inline pic_value pic_sym_value(pic_sym);
-static inline pic_value pic_char_value(char c);
-static inline pic_value pic_none_value();
-
-#define pic_symbol_value(sym) pic_sym_value(sym)
-
-static inline bool pic_eq_p(pic_value, pic_value);
-static inline bool pic_eqv_p(pic_value, pic_value);
-
-static inline enum pic_tt
-pic_type(pic_value v)
-{
-  switch (pic_vtype(v)) {
-  case PIC_VTYPE_NIL:
-    return PIC_TT_NIL;
-  case PIC_VTYPE_TRUE:
-    return PIC_TT_BOOL;
-  case PIC_VTYPE_FALSE:
-    return PIC_TT_BOOL;
-  case PIC_VTYPE_UNDEF:
-    return PIC_TT_UNDEF;
-  case PIC_VTYPE_FLOAT:
-    return PIC_TT_FLOAT;
-  case PIC_VTYPE_INT:
-    return PIC_TT_INT;
-  case PIC_VTYPE_SYMBOL:
-    return PIC_TT_SYMBOL;
-  case PIC_VTYPE_CHAR:
-    return PIC_TT_CHAR;
-  case PIC_VTYPE_EOF:
-    return PIC_TT_EOF;
-  case PIC_VTYPE_HEAP:
-    return ((struct pic_object *)pic_ptr(v))->tt;
-  default:
-    return -1;                  /* logic flaw */
-  }
-}
-
-static inline const char *
-pic_type_repr(enum pic_tt tt)
-{
-  switch (tt) {
-  case PIC_TT_NIL:
-    return "nil";
-  case PIC_TT_BOOL:
-    return "boolean";
-  case PIC_TT_FLOAT:
-    return "float";
-  case PIC_TT_INT:
-    return "int";
-  case PIC_TT_SYMBOL:
-    return "symbol";
-  case PIC_TT_CHAR:
-    return "char";
-  case PIC_TT_EOF:
-    return "eof";
-  case PIC_TT_UNDEF:
-    return "undef";
-  case PIC_TT_PAIR:
-    return "pair";
-  case PIC_TT_STRING:
-    return "string";
-  case PIC_TT_VECTOR:
-    return "vector";
-  case PIC_TT_BLOB:
-    return "blob";
-  case PIC_TT_PORT:
-    return "port";
-  case PIC_TT_ERROR:
-    return "error";
-  case PIC_TT_ENV:
-    return "env";
-  case PIC_TT_CONT:
-    return "cont";
-  case PIC_TT_PROC:
-    return "proc";
-  case PIC_TT_SENV:
-    return "senv";
-  case PIC_TT_MACRO:
-    return "macro";
-  case PIC_TT_LIB:
-    return "lib";
-  case PIC_TT_VAR:
-    return "var";
-  case PIC_TT_IREP:
-    return "irep";
-  case PIC_TT_DATA:
-    return "data";
-  case PIC_TT_DICT:
-    return "dict";
-  case PIC_TT_RECORD:
-    return "record";
-  case PIC_TT_BLK:
-    return "block";
-  }
-  UNREACHABLE();
-}
-
-static inline bool
-pic_valid_int(double v)
-{
-  return INT_MIN <= v && v <= INT_MAX;
-}
-
-static inline pic_value
-pic_nil_value()
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_NIL);
-  return v;
-}
-
-static inline pic_value
-pic_true_value()
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_TRUE);
-  return v;
-}
-
-static inline pic_value
-pic_false_value()
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_FALSE);
-  return v;
-}
-
-static inline pic_value
-pic_bool_value(bool b)
-{
-  pic_value v;
-
-  pic_init_value(v, b ? PIC_VTYPE_TRUE : PIC_VTYPE_FALSE);
-  return v;
-}
-
-#if PIC_NAN_BOXING
-
-static inline pic_value
-pic_obj_value(void *ptr)
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_HEAP);
-  v.u.data = (void*)((long long)v.u.data | ((long long)ptr));
-  return v;
-}
-
-static inline pic_value
-pic_float_value(double f)
-{
-  pic_value v;
-
-  if (f != f) {
-    v.u.type_ = 0x7ff80000;
-    v.u.i = 0;
-  } else {
-    v.u.f = f;
-  }
-  return v;
-}
-
-#else
-
-static inline pic_value
-pic_obj_value(void *ptr)
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_HEAP);
-  v.u.data = ptr;
-  return v;
-}
-
-static inline pic_value
-pic_float_value(double f)
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_FLOAT);
-  v.u.f = f;
-  return v;
-}
-
-#endif
-
-static inline pic_value
-pic_int_value(int i)
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_INT);
-  v.u.i = i;
-  return v;
-}
-
-static inline pic_value
-pic_symbol_value(pic_sym sym)
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_SYMBOL);
-  v.u.sym = sym;
-  return v;
-}
-
-static inline pic_value
-pic_char_value(char c)
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_CHAR);
-  v.u.c = c;
-  return v;
-}
-
-static inline pic_value
-pic_undef_value()
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_UNDEF);
-  return v;
-}
-
-static inline pic_value
-pic_none_value()
-{
-#if PIC_NONE_IS_FALSE
-  return pic_false_value();
-#else
-# error enable PIC_NONE_IS_FALSE
-#endif
-}
-
-#if PIC_NAN_BOXING
-
-static inline bool
-pic_eq_p(pic_value x, pic_value y)
-{
-  return x.u.data == y.u.data;
-}
-
-static inline bool
-pic_eqv_p(pic_value x, pic_value y)
-{
-  return x.u.data == y.u.data;
-}
-
-#else
-
-static inline bool
-pic_eq_p(pic_value x, pic_value y)
-{
-  if (pic_type(x) != pic_type(y))
-    return false;
-
-  switch (pic_type(x)) {
-  case PIC_TT_NIL:
-    return true;
-  case PIC_TT_BOOL:
-    return pic_vtype(x) == pic_vtype(y);
-  case PIC_TT_SYMBOL:
-    return pic_sym(x) == pic_sym(y);
-  default:
-    return pic_ptr(x) == pic_ptr(y);
-  }
-}
-
-static inline bool
-pic_eqv_p(pic_value x, pic_value y)
-{
-  if (pic_type(x) != pic_type(y))
-    return false;
-
-  switch (pic_type(x)) {
-  case PIC_TT_NIL:
-    return true;
-  case PIC_TT_BOOL:
-    return pic_vtype(x) == pic_vtype(y);
-  case PIC_TT_SYMBOL:
-    return pic_sym(x) == pic_sym(y);
-  case PIC_TT_FLOAT:
-    return pic_float(x) == pic_float(y);
-  case PIC_TT_INT:
-    return pic_int(x) == pic_int(y);
-  default:
-    return pic_ptr(x) == pic_ptr(y);
-  }
-}
-
-#endif
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/var.h

@@ -1,32 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_VAR_H__
-#define PICRIN_VAR_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_var {
-  PIC_OBJECT_HEADER
-  pic_value stack;
-  struct pic_proc *conv;
-};
-
-#define pic_var_p(o) (pic_type(o) == PIC_TT_VAR)
-#define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o))
-
-struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc * /* = NULL */);
-
-pic_value pic_var_ref(pic_state *, struct pic_var *);
-void pic_var_set(pic_state *, struct pic_var *, pic_value);
-void pic_var_push(pic_state *, struct pic_var *, pic_value);
-void pic_var_pop(pic_state *, struct pic_var *);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/vector.h

@@ -1,29 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_VECTOR_H__
-#define PICRIN_VECTOR_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_vector {
-  PIC_OBJECT_HEADER
-  pic_value *data;
-  size_t len;
-};
-
-#define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR)
-#define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o))
-
-struct pic_vector *pic_vec_new(pic_state *, size_t);
-struct pic_vector *pic_vec_new_from_list(pic_state *, pic_value);
-void pic_vec_extend_ip(pic_state *, struct pic_vector *, size_t);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

piclib/CMakeLists.txt

@@ -1,33 +1,10 @@
 list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
-  ${PROJECT_SOURCE_DIR}/piclib/picrin/list.scm
-  ${PROJECT_SOURCE_DIR}/piclib/picrin/symbol.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
-
-  ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
-
   ${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
-  ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm
-
-  ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
-  ${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/17.scm
-  ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm
-  ${PROJECT_SOURCE_DIR}/piclib/srfi/43.scm
-  ${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/syntax-rules.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
   )

piclib/picrin/array.scm

@@ -1,6 +1,5 @@
 (define-library (picrin array)
-  (import (scheme base)
-          (scheme write)
+  (import (picrin base)
           (picrin record))
 
   (define-record-type <array>
@@ -11,6 +10,11 @@
     (head array-head set-array-head!)
     (tail array-tail set-array-tail!))
 
+  (define (floor-remainder i j)
+    (call-with-values (lambda () (floor/ i j))
+      (lambda (q r)
+        r)))
+
   (define (translate ary i)
     (floor-remainder i (array-size ary)))
 
@@ -39,7 +43,7 @@
     (if (null? rest)
         (make-array 0)
         (let ((capacity (car rest))
-              (ary (create-array (vector) 0 0 0)))
+              (ary (create-array (make-vector 0) 0 0 0)))
           (array-reserve! ary capacity)
           ary)))
 
@@ -90,16 +94,17 @@
     (for-each proc (array->list ary)))
 
   (define-record-writer (<array> array)
-    (call-with-port (open-output-string)
-     (lambda (port)
-       (display "#.(array" port)
-       (array-for-each
-        (lambda (obj)
-          (display " " port)
-          (write obj port))
-        array)
-       (display ")" port)
-       (get-output-string port))))
+    (let ((port (open-output-string)))
+      (display "#.(array" port)
+      (array-for-each
+       (lambda (obj)
+         (display " " port)
+         (write obj port))
+       array)
+      (display ")" port)
+      (let ((str (get-output-string port)))
+        (close-port port)
+        str)))
 
   (export make-array
           array

piclib/picrin/base.scm

@@ -1,24 +1,293 @@
 (define-library (picrin base)
-  (import (rename (picrin base core) (define define*))
-          (picrin base macro)
-          (picrin base list)
-          (picrin base symbol))
-
-  (define-syntax define
-    (lambda (form use-env mac-env)
-      (if (symbol? (car (cdr form)))
-          (cons (make-identifier 'define* mac-env) (cdr form))
-          (cons (make-identifier 'define mac-env)
-                (cons (car (car (cdr form)))
-                      (cons (cons (make-identifier 'lambda mac-env)
-                                  (cons (cdr (car (cdr form)))
-                                        (cdr (cdr form))))
-                            '()))))))
 
   (export define
-          set!
-          quote
           lambda
           if
+          quote
+          set!
           begin
-          define-syntax))
+          define-syntax)
+
+  (export syntax-error
+          let-syntax
+          letrec-syntax)
+
+  (export let
+          let*
+          letrec
+          letrec*
+          quasiquote
+          unquote
+          unquote-splicing
+          and
+          or
+          cond
+          case
+          =>
+          else
+          do
+          when
+          unless)
+
+  (export let-values
+          let*-values
+          define-values)
+
+  (export eq?
+          eqv?
+          equal?)
+
+  (export boolean?
+          boolean=?
+          not)
+
+  (export symbol?
+          symbol->string
+          string->symbol
+          symbol=?)
+
+  (export char?
+          char->integer
+          integer->char
+          char=?
+          char<?
+          char>?
+          char<=?
+          char>=?)
+
+  (export number?
+          complex?
+          real?
+          rational?
+          integer?
+          exact?
+          inexact?
+          =
+          <
+          >
+          <=
+          >=
+          +
+          -
+          *
+          /
+          abs
+          floor/
+          truncate/
+          floor
+          ceiling
+          truncate
+          round
+          expt
+          number->string
+          string->number
+          finite?
+          infinite?
+          nan?
+          exp
+          log
+          sin
+          cos
+          tan
+          acos
+          asin
+          atan
+          sqrt)
+
+  (export pair?
+          cons
+          car
+          cdr
+          set-car!
+          set-cdr!
+          null?
+          caar
+          cadr
+          cdar
+          cddr)
+
+  (export list?
+          make-list
+          list
+          length
+          append
+          reverse
+          list-tail
+          list-ref
+          list-set!
+          list-copy
+          map
+          for-each
+          memq
+          memv
+          member
+          assq
+          assv
+          assoc)
+
+  (export bytevector?
+          bytevector
+          make-bytevector
+          bytevector-length
+          bytevector-u8-ref
+          bytevector-u8-set!
+          bytevector-copy
+          bytevector-copy!
+          bytevector-append
+          bytevector->list
+          list->bytevector)
+
+  (export vector?
+          vector
+          make-vector
+          vector-length
+          vector-ref
+          vector-set!
+          vector-copy!
+          vector-copy
+          vector-append
+          vector-fill!
+          vector-map
+          vector-for-each
+          list->vector
+          vector->list
+          string->vector
+          vector->string)
+
+  (export string?
+          string
+          make-string
+          string-length
+          string-ref
+          string-set!
+          string-copy
+          string-copy!
+          string-append
+          string-fill!
+          string-map
+          string-for-each
+          string->list
+          list->string
+          string=?
+          string<?
+          string>?
+          string<=?
+          string>=?)
+
+  (export make-dictionary
+          dictionary?
+          dictionary
+          dictionary-ref
+          dictionary-set!
+          dictionary-delete!
+          dictionary-size
+          dictionary-map
+          dictionary-for-each
+          dictionary->plist
+          plist->dictionary
+          dictionary->alist
+          alist->dictionary)
+
+  (export make-record
+          record?
+          record-type
+          record-ref
+          record-set!)
+
+  (export current-input-port
+          current-output-port
+          current-error-port
+
+          call-with-port
+
+          port?
+          input-port?
+          output-port?
+          textual-port?
+          binary-port?
+
+          port-open?
+          close-port
+
+          open-input-file
+          open-output-file
+          open-binary-input-file
+          open-binary-output-file
+          open-input-string
+          open-output-string
+          get-output-string
+          open-input-bytevector
+          open-output-bytevector
+          get-output-bytevector
+
+          eof-object?
+          eof-object
+
+          read-char
+          peek-char
+          char-ready?
+          read-line
+          read-string
+
+          read-u8
+          peek-u8
+          u8-ready?
+          read-bytevector
+          read-bytevector!
+
+          newline
+          write-char
+          write-string
+          write-u8
+          write-bytevector
+          flush-output-port)
+
+  (export make-parameter
+          parameterize)
+
+  (export identifier?
+          identifier=?
+          make-identifier)
+
+  (export call-with-current-continuation
+          call/cc
+          dynamic-wind
+          values
+          call-with-values)
+
+  (export with-exception-handler
+          raise
+          raise-continuable
+          error
+          make-error-object
+          error-object?
+          error-object-message
+          error-object-irritants
+          error-object-type)
+
+  (export procedure?
+          apply
+          attribute)
+
+  (export read)
+
+  (export write
+          write-simple
+          write-shared
+          display)
+
+  (export command-line
+          exit
+          emergency-exit
+          file-exists?
+          delete-file
+          get-environment-variable
+          get-environment-variables)
+
+  (export current-second
+          current-jiffy
+          jiffies-per-second)
+
+  (export eval)
+
+  (export load))

piclib/picrin/dictionary.scm

@@ -1,47 +1,13 @@
 (define-library (picrin dictionary)
-  (import (scheme base))
+  (import (picrin base))
 
-  (define (dictionary-map proc dict)
-    (let ((kvs '()))
-      (dictionary-for-each
-       (lambda (key val)
-         (set! kvs (cons (proc key val) kvs)))
-       dict)
-      (reverse kvs)))
-
-  (define (dictionary->plist dict)
-    (let ((kvs '()))
-      (dictionary-for-each
-       (lambda (key val)
-         (set! kvs (cons val (cons key kvs))))
-       dict)
-      (reverse kvs)))
-
-  (define (plist->dictionary plist)
-    (let ((dict (make-dictionary)))
-      (do ((kv plist (cddr kv)))
-          ((null? kv)
-           dict)
-        (dictionary-set! dict (car kv) (cadr kv)))))
-
-  (define (dictionary->alist dict)
-    (dictionary-map
-     (lambda (key val)
-       (cons key val))
-     dict))
-
-  (define (alist->dictionary alist)
-    (let ((dict (make-dictionary)))
-      (do ((kv alist (cdr kv)))
-          ((null? kv)
-           dict)
-        (dictionary-set! dict (car kv) (cdr kv)))))
-
-  (define (dictionary . plist)
-    (plist->dictionary plist))
-
-  (export dictionary
-          dictionary-map
+  (export dictionary?
+          dictionary
+          make-dictionary
+          dictionary-ref
+          dictionary-set!
+          dictionary-delete!
+          dictionary-size
           dictionary->plist
           plist->dictionary
           dictionary->alist

piclib/picrin/experimental/lambda.scm

@@ -1,5 +1,6 @@
 (define-library (picrin experimental lambda)
   (import (scheme base)
+          (picrin base)
           (picrin macro))
 
   (define-syntax destructuring-bind

piclib/picrin/list.scm

@@ -1,30 +0,0 @@
-(define-library (picrin list)
-  (import (picrin base list))
-
-  (export pair?
-          cons
-          car
-          cdr
-          set-car!
-          set-cdr!
-          null?
-          caar
-          cadr
-          cdar
-          cddr
-          list?
-          make-list
-          list
-          length
-          append
-          reverse
-          list-tail
-          list-ref
-          list-set!
-          list-copy
-          memq
-          memv
-          member
-          assq
-          assv
-          assoc))

piclib/picrin/macro.scm

@@ -1,12 +1,5 @@
-;;; Hygienic Macros
-
 (define-library (picrin macro)
-  (import (picrin base macro)
-          (picrin base)
-          (picrin list)
-          (picrin symbol)
-          (scheme base)
-          (picrin dictionary))
+  (import (picrin base))
 
   ;; assumes no derived expressions are provided yet
 
@@ -36,18 +29,6 @@
                 (dictionary-set! cache sym val)
                 val))))))
 
-  (define (identifier=? env1 sym1 env2 sym2)
-
-    (define (resolve sym env)
-      (define x (make-identifier sym env))
-      (define y (make-identifier sym env))
-      (if (eq? x y)
-          x
-          sym))          ; resolved to no variable
-
-    (eq? (resolve sym1 env1)
-         (resolve sym2 env2)))
-
   (define (make-syntactic-closure env free form)
 
     (define resolve
@@ -126,8 +107,8 @@
                       (rename sym)))))
             (f (walk inject expr) inject compare))))
 
-  (define (strip-syntax form)
-    (walk ungensym form))
+  ;; (define (strip-syntax form)
+  ;;   (walk ungensym form))
 
   (define-syntax define-macro
     (er-macro-transformer
@@ -153,5 +134,5 @@
           rsc-macro-transformer
           er-macro-transformer
           ir-macro-transformer
-          strip-syntax
+          ;; strip-syntax
           define-macro))

piclib/picrin/record.scm

@@ -1,17 +1,109 @@
 (define-library (picrin record)
-  (import (scheme base))
+  (import (picrin base)
+          (picrin macro))
 
-  (define (define-record-writer* record-type writer)
+  ;; define-record-writer
+
+  (define (set-record-writer! record-type writer)
     (record-set! record-type 'writer writer))
 
   (define-syntax define-record-writer
-    (syntax-rules ()
-      ((_ (type obj) body ...)
-       (define-record-writer* type
-         (lambda (obj)
-           body ...)))
-      ((_ type writer)
-       (define-record-writer* type
-         writer))))
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((formal (cadr form)))
+         (if (pair? formal)
+             `(,(r 'set-record-writer!) ,(car formal)
+               (,(r 'lambda) (,(cadr formal))
+                ,@(cddr form)))
+             `(,(r 'set-record-writer!) ,formal
+               ,@(cddr form)))))))
 
-  (export define-record-writer))
+  ;; define-record-type
+
+  (define ((default-record-writer ctor) obj)
+    (let ((port (open-output-string)))
+      (display "#.(" port)
+      (display (car ctor) port)
+      (for-each
+       (lambda (field)
+         (display " " port)
+         (write (record-ref obj field) port))
+       (cdr ctor))
+      (display ")" port)
+      (get-output-string port)))
+
+  (define ((boot-make-record-type <meta-type>) name ctor)
+    (let ((rectype (make-record <meta-type>)))
+      (record-set! rectype 'name name)
+      (record-set! rectype 'writer (default-record-writer ctor))
+      rectype))
+
+  (define <record-type>
+    (let ((<record-type>
+           ((boot-make-record-type #t) 'record-type '(record-type name writer))))
+      (record-set! <record-type> '@@type <record-type>)
+      <record-type>))
+
+  (define make-record-type (boot-make-record-type <record-type>))
+
+  (define-syntax define-record-constructor
+    (ir-macro-transformer
+     (lambda (form inject compare?)
+       (let ((rectype (car (cdr form)))
+	     (name    (car (cdr (cdr form))))
+	     (fields  (cdr (cdr (cdr form)))))
+	 `(define (,name ,@fields)
+	    (let ((record (make-record ,rectype)))
+	      ,@(map (lambda (field)
+		       `(record-set! record ',field ,field))
+		     fields)
+	      record))))))
+
+  (define-syntax define-record-predicate
+    (ir-macro-transformer
+     (lambda (form inject compare?)
+       (let ((rectype (car (cdr form)))
+	     (name    (car (cdr (cdr form)))))
+	 `(define (,name obj)
+	    (and (record? obj)
+		 (eq? (record-type obj)
+                      ,rectype)))))))
+
+  (define-syntax define-record-field
+    (ir-macro-transformer
+     (lambda (form inject compare?)
+       (let ((pred       (car (cdr form)))
+	     (field-name (car (cdr (cdr form))))
+	     (accessor   (car (cdr (cdr (cdr form)))))
+	     (modifier?  (cdr (cdr (cdr (cdr form))))))
+	 (if (null? modifier?)
+	     `(define (,accessor record)
+		(if (,pred record)
+		    (record-ref record ',field-name)
+		    (error "wrong record type")))
+	     `(begin
+		(define (,accessor record)
+		  (if (,pred record)
+		      (record-ref record ',field-name)
+		      (error "wrong record type")))
+		(define (,(car modifier?) record val)
+		  (if (,pred record)
+		      (record-set! record ',field-name val)
+		      (error "wrong record type")))))))))
+
+  (define-syntax define-record-type
+    (ir-macro-transformer
+     (lambda (form inject compare?)
+       (let ((name   (car (cdr form)))
+	     (ctor   (car (cdr (cdr form))))
+	     (pred   (car (cdr (cdr (cdr form)))))
+	     (fields (cdr (cdr (cdr (cdr form))))))
+	 `(begin
+	    (define ,name (make-record-type ',name ',ctor))
+	    (define-record-constructor ,name ,@ctor)
+	    (define-record-predicate ,name ,pred)
+	    ,@(map (lambda (field) `(define-record-field ,pred ,@field))
+		   fields))))))
+
+  (export define-record-type
+          define-record-writer))

piclib/picrin/symbol.scm

@@ -1,7 +0,0 @@
-(define-library (picrin symbol)
-  (import (picrin base symbol))
-
-  (export symbol?
-          symbol=?
-          symbol->string
-          string->symbol))

piclib/picrin/syntax-rules.scm

@@ -0,0 +1,347 @@
+(define-library (picrin syntax-rules)
+  (import (picrin base)
+          (picrin macro))
+
+  (define-syntax define-auxiliary-syntax
+    (er-macro-transformer
+     (lambda (expr r c)
+       (list (r 'define-syntax) (cadr expr)
+             (list (r 'lambda) '_
+                   (list (r 'error) "invalid use of auxiliary syntax"))))))
+
+  (define-auxiliary-syntax _)
+  (define-auxiliary-syntax ...)
+
+  (define (walk proc expr)
+    (cond
+     ((null? expr)
+      '())
+     ((pair? expr)
+      (cons (walk proc (car expr))
+            (walk proc (cdr expr))))
+     ((vector? expr)
+      (list->vector (map proc (vector->list expr))))
+     (else
+      (proc expr))))
+
+  (define (flatten expr)
+    (let ((list '()))
+      (walk
+       (lambda (x)
+         (set! list (cons x list)))
+       expr)
+      (reverse list)))
+
+  (define (reverse* l)
+    ;; (reverse* '(a b c d . e)) => (e d c b a)
+    (let loop ((a '())
+               (d l))
+      (if (pair? d)
+          (loop (cons (car d) a) (cdr d))
+          (cons d a))))
+
+  (define (every? pred l)
+    (if (null? l)
+        #t
+        (and (pred (car l)) (every? pred (cdr l)))))
+
+  (define-syntax syntax-rules
+    (er-macro-transformer
+     (lambda (form r compare)
+       (define _define (r 'define))
+       (define _let (r 'let))
+       (define _if (r 'if))
+       (define _begin (r 'begin))
+       (define _lambda (r 'lambda))
+       (define _set! (r 'set!))
+       (define _not (r 'not))
+       (define _and (r 'and))
+       (define _car (r 'car))
+       (define _cdr (r 'cdr))
+       (define _cons (r 'cons))
+       (define _pair? (r 'pair?))
+       (define _null? (r 'null?))
+       (define _symbol? (r 'symbol?))
+       (define _vector? (r 'vector?))
+       (define _eqv? (r 'eqv?))
+       (define _string=? (r 'string=?))
+       (define _map (r 'map))
+       (define _vector->list (r 'vector->list))
+       (define _list->vector (r 'list->vector))
+       (define _quote (r 'quote))
+       (define _quasiquote (r 'quasiquote))
+       (define _unquote (r 'unquote))
+       (define _unquote-splicing (r 'unquote-splicing))
+       (define _syntax-error (r 'syntax-error))
+       (define _call/cc (r 'call/cc))
+       (define _er-macro-transformer (r 'er-macro-transformer))
+
+       (define (var->sym v)
+         (let loop ((cnt 0)
+                    (v v))
+           (if (symbol? v)
+               (string->symbol
+                (string-append (symbol->string v) "/" (number->string cnt)))
+               (loop (+ 1 cnt) (car v)))))
+
+       (define push-var list)
+
+       (define (compile-match ellipsis literals pattern)
+	 (letrec ((compile-match-base
+		   (lambda (pattern)
+		     (cond ((member pattern literals compare)
+			    (values
+                              `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
+                                     #f
+                                     (exit #f))
+                              '()))
+			   ((compare pattern (r '_)) (values #f '()))
+			   ((and ellipsis (compare pattern ellipsis))
+			    (values `(,_syntax-error "invalid pattern") '()))
+			   ((symbol? pattern)
+			    (values `(,_set! ,(var->sym pattern) expr) (list pattern)))
+			   ((pair? pattern)
+			    (compile-match-list pattern))
+			   ((vector? pattern)
+			    (compile-match-vector pattern))
+			   ((string? pattern)
+			    (values
+                              `(,_if (,_not (,_string=? ',pattern expr))
+                                     (exit #f))
+                              '()))
+			   (else
+			    (values
+                              `(,_if (,_not (,_eqv? ',pattern expr))
+                                     (exit #f))
+                              '())))))
+
+		  (compile-match-list
+		   (lambda (pattern)
+		     (let loop ((pattern pattern)
+				(matches '())
+				(vars '())
+				(accessor 'expr))
+		       (cond ;; (hoge)
+			((not (pair? (cdr pattern)))
+			 (let*-values (((match1 vars1) (compile-match-base (car pattern)))
+				       ((match2 vars2) (compile-match-base (cdr pattern))))
+			   (values
+                             `(,_begin ,@(reverse matches)
+                                       (,_if (,_pair? ,accessor)
+                                             (,_begin
+                                              (,_let ((expr (,_car ,accessor)))
+                                                     ,match1)
+                                              (,_let ((expr (,_cdr ,accessor)))
+                                                     ,match2))
+                                             (exit #f)))
+                             (append vars (append vars1 vars2)))))
+			;; (hoge ... rest args)
+			((and ellipsis (compare (cadr pattern) ellipsis))
+			 (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
+			   (values
+                             `(,_begin ,@(reverse matches)
+                                       (,_let ((expr (,_let loop ((a ())
+                                                                  (d ,accessor))
+                                                            (,_if (,_pair? d)
+                                                                  (loop (,_cons (,_car d) a) (,_cdr d))
+                                                                  (,_cons d a)))))
+                                              ,match-r))
+                             (append vars vars-r))))
+			(else
+			 (let-values (((match1 vars1) (compile-match-base (car pattern))))
+			   (loop (cdr pattern)
+				 (cons `(,_if (,_pair? ,accessor)
+					      (,_let ((expr (,_car ,accessor)))
+						     ,match1)
+					      (exit #f))
+				       matches)
+				 (append vars vars1)
+				 `(,_cdr ,accessor))))))))
+
+		  (compile-match-list-reverse
+		   (lambda (pattern)
+		     (let loop ((pattern (reverse* pattern))
+				(matches '())
+				(vars '())
+				(accessor 'expr))
+		       (cond ((and ellipsis (compare (car pattern) ellipsis))
+			      (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
+				(values
+                                  `(,_begin ,@(reverse matches)
+                                            (,_let ((expr ,accessor))
+                                                   ,match1))
+                                  (append vars vars1))))
+			     (else
+			      (let-values (((match1 vars1) (compile-match-base (car pattern))))
+				(loop (cdr pattern)
+				      (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)
+				      (append vars vars1)
+				      `(,_cdr ,accessor))))))))
+
+		  (compile-match-ellipsis
+		   (lambda (pattern)
+		     (let-values (((match vars) (compile-match-base pattern)))
+		       (values
+                         `(,_let loop ((expr expr))
+                                 (,_if (,_not (,_null? expr))
+                                       (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)
+                                              (,_let ((expr (,_car expr)))
+                                                     ,match)
+                                              ,@(map
+                                                 (lambda (var)
+                                                   `(,_set! ,(var->sym (push-var var))
+                                                            (,_cons ,(var->sym var) ,(var->sym (push-var var)))))
+                                                 vars)
+                                              (loop (,_cdr expr)))))
+                         (map push-var vars)))))
+
+		  (compile-match-vector
+		   (lambda (pattern)
+		     (let-values (((match vars) (compile-match-base (vector->list pattern))))
+		       (values
+                         `(,_if (,_vector? expr)
+                                (,_let ((expr (,_vector->list expr)))
+                                       ,match)
+                                (exit #f))
+                         vars)))))
+
+	   (let-values (((match vars) (compile-match-base (cdr pattern))))
+	     (values `(,_let ((expr (,_cdr expr)))
+			     ,match
+			     #t)
+		     vars))))
+
+;;; compile expand
+       (define (compile-expand ellipsis reserved template)
+	 (letrec ((compile-expand-base
+		   (lambda (template ellipsis-valid)
+		     (cond ((member template reserved eq?)
+			    (values (var->sym template) (list template)))
+			   ((symbol? template)
+			    (values `(rename ',template) '()))
+			   ((pair? template)
+			    (compile-expand-list template ellipsis-valid))
+			   ((vector? template)
+			    (compile-expand-vector template ellipsis-valid))
+			   (else
+			    (values `',template '())))))
+
+		  (compile-expand-list
+		   (lambda (template ellipsis-valid)
+		     (let loop ((template template)
+				(expands '())
+				(vars '()))
+		       (cond ;; (... hoge)
+			((and ellipsis-valid
+			      (pair? template)
+			      (compare (car template) ellipsis))
+			 (if (and (pair? (cdr template)) (null? (cddr template)))
+			     (compile-expand-base (cadr template) #f)
+			     (values '(,_syntax-error "invalid template") '())))
+			;; hoge
+			((not (pair? template))
+			 (let-values (((expand1 vars1)
+				       (compile-expand-base template ellipsis-valid)))
+			   (values
+                             `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
+                             (append vars vars1))))
+			;; (a ... rest syms)
+			((and ellipsis-valid
+			      (pair? (cdr template))
+			      (compare (cadr template) ellipsis))
+			 (let-values (((expand1 vars1)
+				       (compile-expand-base (car template) ellipsis-valid)))
+			   (loop (cddr template)
+				 (cons
+				  `(,_unquote-splicing
+				    (,_map (,_lambda ,(map var->sym vars1) ,expand1)
+					   ,@(map (lambda (v) (var->sym (push-var v))) vars1)))
+				  expands)
+				 (append vars (map push-var vars1)))))
+			(else
+			 (let-values (((expand1 vars1)
+				       (compile-expand-base (car template) ellipsis-valid)))
+			   (loop (cdr template)
+				 (cons
+				  `(,_unquote ,expand1)
+				  expands)
+				 (append vars vars1))))))))
+
+		  (compile-expand-vector
+		   (lambda (template ellipsis-valid)
+		     (let-values (((expand1 vars1)
+				   (compile-expand-base (vector->list template) ellipsis-valid)))
+		       (values
+                         `(,_list->vector ,expand1)
+                         vars1)))))
+
+	   (compile-expand-base template ellipsis)))
+
+       (define (check-vars vars-pattern vars-template)
+	 ;;fixme
+	 #t)
+
+       (define (compile-rule ellipsis literals rule)
+	 (let ((pattern (car rule))
+	       (template (cadr rule)))
+	   (let*-values (((match vars-match)
+			  (compile-match ellipsis literals pattern))
+			 ((expand vars-expand)
+			  (compile-expand ellipsis (flatten vars-match) template)))
+	     (if (check-vars vars-match vars-expand)
+		 (list vars-match match expand)
+		 'mismatch))))
+
+       (define (expand-clauses clauses rename)
+	 (cond ((null? clauses)
+		`(,_quote (syntax-error "no matching pattern")))
+	       ((compare (car clauses) 'mismatch)
+		`(,_syntax-error "invalid rule"))
+	       (else
+		(let ((vars (list-ref (car clauses) 0))
+		      (match (list-ref (car clauses) 1))
+		      (expand (list-ref (car clauses) 2)))
+		  `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
+			  (,_let ((result (,_call/cc (,_lambda (exit) ,match))))
+				 (,_if result
+				       ,expand
+				       ,(expand-clauses (cdr clauses) rename))))))))
+
+       (define (normalize-form form)
+	 (if (and (list? form) (>= (length form) 2))
+	     (let ((ellipsis '...)
+		   (literals (cadr form))
+		   (rules (cddr form)))
+
+	       (when (symbol? literals)
+                 (set! ellipsis literals)
+                 (set! literals (car rules))
+                 (set! rules (cdr rules)))
+
+	       (if (and (symbol? ellipsis)
+			(list? literals)
+			(every? symbol? literals)
+			(list? rules)
+			(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
+		   (if (member ellipsis literals compare)
+		       `(syntax-rules #f ,literals ,@rules)
+		       `(syntax-rules ,ellipsis ,literals ,@rules))
+		   #f))
+	     #f))
+
+       (let ((form (normalize-form form)))
+	 (if form
+	     (let ((ellipsis (list-ref form 1))
+		   (literals (list-ref form 2))
+		   (rules (list-tail form 3)))
+	       (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
+				   rules)))
+		 `(,_er-macro-transformer
+		   (,_lambda (expr rename cmp)
+			     ,(expand-clauses clauses r)))))
+
+	     `(,_syntax-error "malformed syntax-rules"))))))
+
+  (export syntax-rules
+          _
+          ...))

piclib/picrin/test.scm

@@ -1,8 +1,7 @@
 (define-library (picrin test)
-  (import (scheme base)
-          (scheme write)
-          (scheme read)
-          (scheme process-context))
+  (import (picrin base)
+          (picrin syntax-rules))
+
   (define test-counter 0)
   (define counter 0)
   (define failure-counter 0)
@@ -77,7 +76,7 @@
     (length fails))
 
   (define (test-exit)
-    (exit (zero? (test-failure-count))))
+    (exit (= (test-failure-count) 0)))
 
   (define-syntax test-syntax-error
     (syntax-rules ()

piclib/picrin/user.scm

@@ -1,17 +0,0 @@
-;  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)
-          (picrin dictionary)
-          (picrin array)
-          (picrin library)))

piclib/scheme/null.scm

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

src/CMakeLists.txt

@@ -1,7 +1,12 @@
+### libpicrin ###
+
 find_package(Perl REQUIRED)
 
-# xfile
-set(XFILE_SOURCES extlib/xfile/xfile.c)
+# benz
+file(GLOB BENZ_SOURCES extlib/benz/*.c)
+
+# srcs
+file(GLOB PICRIN_SOURCES src/*.c)
 
 # piclib
 set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c)
@@ -21,12 +26,22 @@ add_custom_command(
   WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
   )
 
-# build!
-file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c)
-add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
+add_library(picrin SHARED ${BENZ_SOURCES} ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
 target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
 
 # install
 set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib)
 install(TARGETS picrin DESTINATION lib)
-install(DIRECTORY include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
+install(DIRECTORY extlib/benz/include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
+
+### picrin ###
+
+list(APPEND REPL_LIBRARIES picrin)
+
+# build
+add_executable(repl src/main.c)
+set_target_properties(repl PROPERTIES OUTPUT_NAME picrin)
+target_link_libraries(repl ${REPL_LIBRARIES})
+
+# install
+install(TARGETS repl RUNTIME DESTINATION bin)

src/blob.c

@@ -1,196 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <string.h>
-
-#include "picrin.h"
-#include "picrin/blob.h"
-
-char *
-pic_strndup(pic_state *pic, const char *s, size_t n)
-{
-  char *r;
-
-  r = pic_alloc(pic, n + 1);
-  memcpy(r, s, n);
-  r[n] = '\0';
-  return r;
-}
-
-char *
-pic_strdup(pic_state *pic, const char *s)
-{
-  return pic_strndup(pic, s, strlen(s));
-}
-
-struct pic_blob *
-pic_blob_new(pic_state *pic, size_t len)
-{
-  struct pic_blob *bv;
-
-  bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
-  bv->data = pic_alloc(pic, len);
-  bv->len = len;
-  return bv;
-}
-
-static pic_value
-pic_blob_bytevector_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_blob_p(v));
-}
-
-static pic_value
-pic_blob_make_bytevector(pic_state *pic)
-{
-  pic_blob *blob;
-  int k, b = 0, i;
-
-  pic_get_args(pic, "i|i", &k, &b);
-
-  if (b < 0 || b > 255)
-    pic_error(pic, "byte out of range");
-
-  blob = pic_blob_new(pic, k);
-  for (i = 0; i < k; ++i) {
-    blob->data[i] = b;
-  }
-
-  return pic_obj_value(blob);
-}
-
-static pic_value
-pic_blob_bytevector_length(pic_state *pic)
-{
-  struct pic_blob *bv;
-
-  pic_get_args(pic, "b", &bv);
-
-  return pic_int_value(bv->len);
-}
-
-static pic_value
-pic_blob_bytevector_u8_ref(pic_state *pic)
-{
-  struct pic_blob *bv;
-  int k;
-
-  pic_get_args(pic, "bi", &bv, &k);
-
-  return pic_int_value(bv->data[k]);
-}
-
-static pic_value
-pic_blob_bytevector_u8_set(pic_state *pic)
-{
-  struct pic_blob *bv;
-  int k, v;
-
-  pic_get_args(pic, "bii", &bv, &k, &v);
-
-  if (v < 0 || v > 255)
-    pic_error(pic, "byte out of range");
-
-  bv->data[k] = v;
-  return pic_none_value();
-}
-
-static pic_value
-pic_blob_bytevector_copy_i(pic_state *pic)
-{
-  pic_blob *to, *from;
-  int n, at, start, end;
-
-  n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end);
-
-  switch (n) {
-  case 3:
-    start = 0;
-  case 4:
-    end = from->len;
-  }
-
-  if (to == from && (start <= at && at < end)) {
-    /* copy in reversed order */
-    at += end - start;
-    while (start < end) {
-      to->data[--at] = from->data[--end];
-    }
-    return pic_none_value();
-  }
-
-  while (start < end) {
-    to->data[at++] = from->data[start++];
-  }
-
-  return pic_none_value();
-}
-
-static pic_value
-pic_blob_bytevector_copy(pic_state *pic)
-{
-  pic_blob *from, *to;
-  int n, start, end, i = 0;
-
-  n = pic_get_args(pic, "b|ii", &from, &start, &end);
-
-  switch (n) {
-  case 1:
-    start = 0;
-  case 2:
-    end = from->len;
-  }
-
-  to = pic_blob_new(pic, end - start);
-  while (start < end) {
-    to->data[i++] = from->data[start++];
-  }
-
-  return pic_obj_value(to);
-}
-
-static pic_value
-pic_blob_bytevector_append(pic_state *pic)
-{
-  size_t argc, i, j, len;
-  pic_value *argv;
-  pic_blob *blob;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  len = 0;
-  for (i = 0; i < argc; ++i) {
-    pic_assert_type(pic, argv[i], blob);
-    len += pic_blob_ptr(argv[i])->len;
-  }
-
-  blob = pic_blob_new(pic, len);
-
-  len = 0;
-  for (i = 0; i < argc; ++i) {
-    for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) {
-      blob->data[len + j] = pic_blob_ptr(argv[i])->data[j];
-    }
-    len += pic_blob_ptr(argv[i])->len;
-  }
-
-  return pic_obj_value(blob);
-}
-
-void
-pic_init_blob(pic_state *pic)
-{
-  pic_defun(pic, "bytevector?", pic_blob_bytevector_p);
-  pic_defun(pic, "make-bytevector", pic_blob_make_bytevector);
-  pic_defun(pic, "bytevector-length", pic_blob_bytevector_length);
-  pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref);
-  pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set);
-  pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i);
-  pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy);
-  pic_defun(pic, "bytevector-append", pic_blob_bytevector_append);
-}

src/bool.c

@@ -1,201 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <string.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/vector.h"
-#include "picrin/blob.h"
-#include "picrin/string.h"
-
-static bool
-str_equal_p(struct pic_string *str1, struct pic_string *str2)
-{
-  return pic_strcmp(str1, str2) == 0;
-}
-
-static bool
-blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
-{
-  size_t i;
-
-  if (blob1->len != blob2->len) {
-    return false;
-  }
-  for (i = 0; i < blob1->len; ++i) {
-    if (blob1->data[i] != blob2->data[i])
-      return false;
-  }
-  return true;
-}
-
-static bool
-internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
-{
-  pic_value local = pic_nil_value();
-  size_t c;
-
-  if (depth > 10) {
-    if (depth > 200) {
-      pic_errorf(pic, "Stack overflow in equal\n");
-    }
-    if (pic_pair_p(x) || pic_vec_p(x)) {
-      if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) {
-        return true;            /* `x' was seen already.  */
-      } else {
-        xh_put_ptr(ht, pic_obj_ptr(x), NULL);
-      }
-    }
-  }
-
-  c = 0;
-
- LOOP:
-
-  if (pic_eqv_p(x, y))
-    return true;
-
-  if (pic_type(x) != pic_type(y))
-    return false;
-
-  switch (pic_type(x)) {
-  case PIC_TT_STRING:
-    return str_equal_p(pic_str_ptr(x), pic_str_ptr(y));
-
-  case PIC_TT_BLOB:
-    return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
-
-  case PIC_TT_PAIR: {
-    if (pic_nil_p(local)) {
-      local = x;
-    }
-    if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
-      x = pic_cdr(pic, x);
-      y = pic_cdr(pic, y);
-
-      c++;
-
-      if (c == 2) {
-        c = 0;
-        local = pic_cdr(pic, local);
-        if (pic_eq_p(local, x)) {
-          return true;
-        }
-      }
-      goto LOOP;
-    } else {
-      return false;
-    }
-  }
-  case PIC_TT_VECTOR: {
-    size_t i;
-    struct pic_vector *u, *v;
-
-    u = pic_vec_ptr(x);
-    v = pic_vec_ptr(y);
-
-    if (u->len != v->len) {
-      return false;
-    }
-    for (i = 0; i < u->len; ++i) {
-      if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
-        return false;
-    }
-    return true;
-  }
-  default:
-    return false;
-  }
-}
-
-bool
-pic_equal_p(pic_state *pic, pic_value x, pic_value y){
-  xhash ht;
-
-  xh_init_ptr(&ht, 0);
-
-  return internal_equal_p(pic, x, y, 0, &ht);
-}
-
-static pic_value
-pic_bool_eq_p(pic_state *pic)
-{
-  pic_value x, y;
-
-  pic_get_args(pic, "oo", &x, &y);
-
-  return pic_bool_value(pic_eq_p(x, y));
-}
-
-static pic_value
-pic_bool_eqv_p(pic_state *pic)
-{
-  pic_value x, y;
-
-  pic_get_args(pic, "oo", &x, &y);
-
-  return pic_bool_value(pic_eqv_p(x, y));
-}
-
-static pic_value
-pic_bool_equal_p(pic_state *pic)
-{
-  pic_value x, y;
-
-  pic_get_args(pic, "oo", &x, &y);
-
-  return pic_bool_value(pic_equal_p(pic, x, y));
-}
-
-static pic_value
-pic_bool_not(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_false_p(v) ? pic_true_value() : pic_false_value();
-}
-
-static pic_value
-pic_bool_boolean_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value();
-}
-
-static pic_value
-pic_bool_boolean_eq_p(pic_state *pic)
-{
-  size_t argc, i;
-  pic_value *argv;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  for (i = 0; i < argc; ++i) {
-    if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) {
-      return pic_false_value();
-    }
-    if (! pic_eq_p(argv[i], argv[0])) {
-      return pic_false_value();
-    }
-  }
-  return pic_true_value();
-}
-
-void
-pic_init_bool(pic_state *pic)
-{
-  pic_defun(pic, "eq?", pic_bool_eq_p);
-  pic_defun(pic, "eqv?", pic_bool_eqv_p);
-  pic_defun(pic, "equal?", pic_bool_equal_p);
-
-  pic_defun(pic, "not", pic_bool_not);
-  pic_defun(pic, "boolean?", pic_bool_boolean_p);
-  pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
-}

src/char.c

@@ -1,43 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-
-static pic_value
-pic_char_char_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_char_p(v) ? pic_true_value() : pic_false_value();
-}
-
-static pic_value
-pic_char_char_to_integer(pic_state *pic)
-{
-  char c;
-
-  pic_get_args(pic, "c", &c);
-
-  return pic_int_value(c);
-}
-
-static pic_value
-pic_char_integer_to_char(pic_state *pic)
-{
-  int i;
-
-  pic_get_args(pic, "i", &i);
-
-  return pic_char_value(i);
-}
-
-void
-pic_init_char(pic_state *pic)
-{
-  pic_defun(pic, "char?", pic_char_char_p);
-  pic_defun(pic, "char->integer", pic_char_char_to_integer);
-  pic_defun(pic, "integer->char", pic_char_integer_to_char);
-}

src/cont.c

@@ -1,371 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <setjmp.h>
-#include <string.h>
-#include <stdarg.h>
-
-#include "picrin.h"
-#include "picrin/proc.h"
-#include "picrin/cont.h"
-#include "picrin/pair.h"
-#include "picrin/error.h"
-
-pic_value
-pic_values0(pic_state *pic)
-{
-  return pic_values_by_list(pic, pic_nil_value());
-}
-
-pic_value
-pic_values1(pic_state *pic, pic_value arg1)
-{
-  return pic_values_by_list(pic, pic_list1(pic, arg1));
-}
-
-pic_value
-pic_values2(pic_state *pic, pic_value arg1, pic_value arg2)
-{
-  return pic_values_by_list(pic, pic_list2(pic, arg1, arg2));
-}
-
-pic_value
-pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3)
-{
-  return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3));
-}
-
-pic_value
-pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4)
-{
-  return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4));
-}
-
-pic_value
-pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5)
-{
-  return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5));
-}
-
-pic_value
-pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
-{
-  size_t i;
-
-  for (i = 0; i < argc; ++i) {
-    pic->sp[i] = argv[i];
-  }
-  pic->ci->retc = argc;
-
-  return argc == 0 ? pic_none_value() : pic->sp[0];
-}
-
-pic_value
-pic_values_by_list(pic_state *pic, pic_value list)
-{
-  pic_value v;
-  size_t i;
-
-  i = 0;
-  pic_for_each (v, list) {
-    pic->sp[i++] = v;
-  }
-  pic->ci->retc = i;
-
-  return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
-}
-
-size_t
-pic_receive(pic_state *pic, size_t n, pic_value *argv)
-{
-  pic_callinfo *ci;
-  size_t i, retc;
-
-  /* take info from discarded frame */
-  ci = pic->ci + 1;
-  retc = ci->retc;
-
-  for (i = 0; i < retc && i < n; ++i) {
-    argv[i] = ci->fp[i];
-  }
-
-  return retc;
-}
-
-static void save_cont(pic_state *, struct pic_cont **);
-static void restore_cont(pic_state *, struct pic_cont *);
-
-static ptrdiff_t
-native_stack_length(pic_state *pic, char **pos)
-{
-  char t;
-
-  *pos = (pic->native_stack_start > &t)
-    ? &t
-    : pic->native_stack_start;
-
-  return (pic->native_stack_start > &t)
-    ? pic->native_stack_start - &t
-    : &t - pic->native_stack_start;
-}
-
-static void
-save_cont(pic_state *pic, struct pic_cont **c)
-{
-  struct pic_cont *cont;
-  char *pos;
-
-  cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT);
-
-  cont->blk = pic->blk;
-
-  cont->stk_len = native_stack_length(pic, &pos);
-  cont->stk_pos = pos;
-  assert(cont->stk_len > 0);
-  cont->stk_ptr = pic_alloc(pic, cont->stk_len);
-  memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len);
-
-  cont->sp_offset = pic->sp - pic->stbase;
-  cont->st_len = pic->stend - pic->stbase;
-  cont->st_ptr = (pic_value *)pic_alloc(pic, sizeof(pic_value) * cont->st_len);
-  memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len);
-
-  cont->ci_offset = pic->ci - pic->cibase;
-  cont->ci_len = pic->ciend - pic->cibase;
-  cont->ci_ptr = (pic_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len);
-  memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
-
-  cont->ip = pic->ip;
-
-  cont->arena_idx = pic->arena_idx;
-  cont->arena_size = pic->arena_size;
-  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();
-}
-
-static void
-native_stack_extend(pic_state *pic, struct pic_cont *cont)
-{
-  volatile pic_value v[1024];
-
-  ((void)v);
-  restore_cont(pic, 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);
-  }
-  else {
-    if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
-  }
-
-  blk = pic->blk;
-  pic->blk = cont->blk;
-
-  pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
-  memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);
-  pic->sp = pic->stbase + cont->sp_offset;
-  pic->stend = pic->stbase + cont->st_len;
-
-  pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
-  memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len);
-  pic->ci = pic->cibase + cont->ci_offset;
-  pic->ciend = pic->cibase + cont->ci_len;
-
-  pic->ip = cont->ip;
-
-  pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
-  memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size);
-  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, struct pic_block *here, struct pic_block *there)
-{
-  if (here == there)
-    return;
-
-  if (here->depth < there->depth) {
-    walk_to_block(pic, here, there->prev);
-    pic_apply0(pic, there->in);
-  }
-  else {
-    pic_apply0(pic, there->out);
-    walk_to_block(pic, here->prev, there);
-  }
-}
-
-static pic_value
-pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
-{
-  struct pic_block *here;
-  pic_value val;
-
-  if (in != NULL) {
-    pic_apply0(pic, in);        /* enter */
-  }
-
-  here = pic->blk;
-  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;
-
-  val = pic_apply0(pic, thunk);
-
-  pic->blk = here;
-
-  if (out != NULL) {
-    pic_apply0(pic, out);       /* exit */
-  }
-
-  return val;
-}
-
-noreturn static pic_value
-cont_call(pic_state *pic)
-{
-  struct pic_proc *proc;
-  size_t argc;
-  pic_value *argv;
-  struct pic_cont *cont;
-
-  proc = pic_get_proc(pic);
-  pic_get_args(pic, "*", &argc, &argv);
-
-  cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont"));
-  cont->results = pic_list_by_array(pic, argc, argv);
-
-  /* execute guard handlers */
-  walk_to_block(pic, pic->blk, cont->blk);
-
-  restore_cont(pic, cont);
-}
-
-pic_value
-pic_callcc(pic_state *pic, struct pic_proc *proc)
-{
-  struct pic_cont *cont;
-
-  save_cont(pic, &cont);
-  if (setjmp(cont->jmp)) {
-    return pic_values_by_list(pic, cont->results);
-  }
-  else {
-    struct pic_proc *c;
-
-    c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
-
-    /* save the continuation object in proc */
-    pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
-
-    return pic_apply1(pic, proc, pic_obj_value(c));
-  }
-}
-
-static pic_value
-pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
-{
-  struct pic_cont *cont;
-
-  save_cont(pic, &cont);
-  if (setjmp(cont->jmp)) {
-    return pic_values_by_list(pic, cont->results);
-  }
-  else {
-    struct pic_proc *c;
-
-    c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
-
-    /* save the continuation object in proc */
-    pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
-
-    return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
-  }
-}
-
-static pic_value
-pic_cont_callcc(pic_state *pic)
-{
-  struct pic_proc *cb;
-
-  pic_get_args(pic, "l", &cb);
-
-  return pic_callcc_trampoline(pic, cb);
-}
-
-static pic_value
-pic_cont_dynamic_wind(pic_state *pic)
-{
-  struct pic_proc *in, *thunk, *out;
-
-  pic_get_args(pic, "lll", &in, &thunk, &out);
-
-  return pic_dynamic_wind(pic, in, thunk, out);
-}
-
-static pic_value
-pic_cont_values(pic_state *pic)
-{
-  size_t argc;
-  pic_value *argv;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  return pic_values_by_array(pic, argc, argv);
-}
-
-static pic_value
-pic_cont_call_with_values(pic_state *pic)
-{
-  struct pic_proc *producer, *consumer;
-  size_t argc;
-  pic_value args[256];
-
-  pic_get_args(pic, "ll", &producer, &consumer);
-
-  pic_apply(pic, producer, pic_nil_value());
-
-  argc = pic_receive(pic, 256, args);
-
-  return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args));
-}
-
-void
-pic_init_cont(pic_state *pic)
-{
-  pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
-  pic_defun(pic, "call/cc", pic_cont_callcc);
-  pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
-  pic_defun(pic, "values", pic_cont_values);
-  pic_defun(pic, "call-with-values", pic_cont_call_with_values);
-}

src/data.c

@@ -1,15 +0,0 @@
-#include "picrin.h"
-#include "picrin/data.h"
-
-struct pic_data *
-pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata)
-{
-  struct pic_data *data;
-
-  data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA);
-  data->type = type;
-  data->data = userdata;
-  xh_init_str(&data->storage, sizeof(pic_value));
-
-  return data;
-}

src/debug.c

@@ -1,74 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/string.h"
-#include "picrin/error.h"
-#include "picrin/proc.h"
-
-pic_str *
-pic_get_backtrace(pic_state *pic)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_callinfo *ci;
-  pic_str *trace;
-
-  trace = pic_str_new(pic, NULL, 0);
-
-  for (ci = pic->ci; ci != pic->cibase; --ci) {
-    struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
-
-    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "  at "));
-    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
-
-    if (pic_proc_func_p(proc)) {
-      trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (native function)\n"));
-    } else if (pic_proc_irep_p(proc)) {
-      trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (unknown location)\n")); /* TODO */
-    }
-  }
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, pic_obj_value(trace));
-
-  return trace;
-}
-
-void
-pic_print_backtrace(pic_state *pic, struct pic_error *e)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_str *trace;
-
-  assert(pic->err != NULL);
-
-  trace = pic_str_new(pic, NULL, 0);
-
-  switch (e->type) {
-  case PIC_ERROR_OTHER:
-    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "error: "));
-    break;
-  case PIC_ERROR_FILE:
-    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "file error: "));
-    break;
-  case PIC_ERROR_READ:
-    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "read error: "));
-    break;
-  case PIC_ERROR_RAISED:
-    trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "raised: "));
-    break;
-  }
-
-  trace = pic_strcat(pic, trace, e->msg);
-
-  /* TODO: print error irritants */
-
-  trace = pic_strcat(pic, trace, pic_str_new(pic, "\n", 1));
-  trace = pic_strcat(pic, trace, e->stack);
-
-  /* print! */
-  printf("%s", pic_str_cstr(trace));
-
-  pic_gc_arena_restore(pic, ai);
-}

src/dict.c

@@ -1,169 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/dict.h"
-#include "picrin/cont.h"
-
-struct pic_dict *
-pic_dict_new(pic_state *pic)
-{
-  struct pic_dict *dict;
-
-  dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
-  xh_init_int(&dict->hash, sizeof(pic_value));
-
-  return dict;
-}
-
-pic_value
-pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key)
-{
-  xh_entry *e;
-
-  e = xh_get_int(&dict->hash, key);
-  if (! e) {
-    pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key));
-  }
-  return xh_val(e, pic_value);
-}
-
-void
-pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym key, pic_value val)
-{
-  UNUSED(pic);
-
-  xh_put_int(&dict->hash, key, &val);
-}
-
-size_t
-pic_dict_size(pic_state *pic, struct pic_dict *dict)
-{
-  UNUSED(pic);
-
-  return dict->hash.count;
-}
-
-bool
-pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key)
-{
-  UNUSED(pic);
-
-  return xh_get_int(&dict->hash, key) != NULL;
-}
-
-void
-pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key)
-{
-  if (xh_get_int(&dict->hash, key) == NULL) {
-    pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key));
-  }
-
-  xh_del_int(&dict->hash, key);
-}
-
-static pic_value
-pic_dict_dict(pic_state *pic)
-{
-  struct pic_dict *dict;
-
-  pic_get_args(pic, "");
-
-  dict = pic_dict_new(pic);
-
-  return pic_obj_value(dict);
-}
-
-static pic_value
-pic_dict_dict_p(pic_state *pic)
-{
-  pic_value obj;
-
-  pic_get_args(pic, "o", &obj);
-
-  return pic_bool_value(pic_dict_p(obj));
-}
-
-static pic_value
-pic_dict_dict_ref(pic_state *pic)
-{
-  struct pic_dict *dict;
-  pic_sym key;
-
-  pic_get_args(pic, "dm", &dict, &key);
-
-  if (pic_dict_has(pic, dict, key)) {
-    return pic_values2(pic, pic_dict_ref(pic, dict , key), pic_true_value());
-  } else {
-    return pic_values2(pic, pic_none_value(), pic_false_value());
-  }
-}
-
-static pic_value
-pic_dict_dict_set(pic_state *pic)
-{
-  struct pic_dict *dict;
-  pic_sym key;
-  pic_value val;
-
-  pic_get_args(pic, "dmo", &dict, &key, &val);
-
-  pic_dict_set(pic, dict, key, val);
-
-  return pic_none_value();
-}
-
-static pic_value
-pic_dict_dict_del(pic_state *pic)
-{
-  struct pic_dict *dict;
-  pic_sym key;
-
-  pic_get_args(pic, "dm", &dict, &key);
-
-  pic_dict_del(pic, dict, key);
-
-  return pic_none_value();
-}
-
-static pic_value
-pic_dict_dict_size(pic_state *pic)
-{
-  struct pic_dict *dict;
-
-  pic_get_args(pic, "d", &dict);
-
-  return pic_int_value(pic_dict_size(pic, dict));
-}
-
-static pic_value
-pic_dict_dict_for_each(pic_state *pic)
-{
-  struct pic_proc *proc;
-  struct pic_dict *dict;
-  xh_iter it;
-
-  pic_get_args(pic, "ld", &proc, &dict);
-
-  xh_begin(&it, &dict->hash);
-  while (xh_next(&it)) {
-    pic_apply2(pic, proc, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value));
-  }
-
-  return pic_none_value();
-}
-
-void
-pic_init_dict(pic_state *pic)
-{
-  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-ref", pic_dict_dict_ref);
-    pic_defun(pic, "dictionary-set!", pic_dict_dict_set);
-    pic_defun(pic, "dictionary-delete", pic_dict_dict_del);
-    pic_defun(pic, "dictionary-size", pic_dict_dict_size);
-    pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each);
-  }
-}

src/error.c

@@ -1,286 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <stdlib.h>
-#include <string.h>
-#include <stdarg.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/error.h"
-
-void
-pic_abort(pic_state *pic, const char *msg)
-{
-  UNUSED(pic);
-
-  fprintf(stderr, "abort: %s\n", msg);
-  abort();
-}
-
-void
-pic_warnf(pic_state *pic, const char *fmt, ...)
-{
-  va_list ap;
-  pic_value err_line;
-
-  va_start(ap, fmt);
-  err_line = pic_vformat(pic, fmt, ap);
-  va_end(ap);
-
-  fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))));
-}
-
-void
-pic_push_try(pic_state *pic, struct pic_proc *handler)
-{
-  struct pic_jmpbuf *try_jmp;
-
-  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 = 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;
-}
-
-void
-pic_pop_try(pic_state *pic)
-{
-  struct pic_jmpbuf *try_jmp;
-
-  try_jmp = pic->try_jmps + --pic->try_jmp_idx;
-
-  /* assert(pic->jmp == &try_jmp->here); */
-
-  pic->ci = try_jmp->ci_offset + pic->cibase;
-  pic->sp = try_jmp->sp_offset + pic->stbase;
-  pic->ip = try_jmp->ip;
-
-  pic->jmp = try_jmp->prev_jmp;
-}
-
-static struct pic_error *
-error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
-{
-  struct pic_error *e;
-  pic_str *stack;
-
-  stack = pic_get_backtrace(pic);
-
-  e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
-  e->type = type;
-  e->msg = msg;
-  e->irrs = irrs;
-  e->stack = stack;
-
-  return e;
-}
-
-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);
-}
-
-noreturn void
-pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs)
-{
-  struct pic_error *e;
-
-  e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs);
-
-  pic_throw_error(pic, e);
-}
-
-const char *
-pic_errmsg(pic_state *pic)
-{
-  assert(pic->err != NULL);
-
-  return pic_str_cstr(pic->err->msg);
-}
-
-void
-pic_errorf(pic_state *pic, const char *fmt, ...)
-{
-  va_list ap;
-  pic_value err_line, irrs;
-  const char *msg;
-
-  va_start(ap, fmt);
-  err_line = pic_vformat(pic, fmt, ap);
-  va_end(ap);
-
-  msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
-  irrs = pic_cdr(pic, err_line);
-
-  pic_throw(pic, PIC_ERROR_OTHER, msg, irrs);
-}
-
-static pic_value
-pic_error_with_exception_handler(pic_state *pic)
-{
-  struct pic_proc *handler, *thunk;
-  pic_value v;
-
-  pic_get_args(pic, "ll", &handler, &thunk);
-
-  pic_try_with_handler(handler) {
-    v = pic_apply0(pic, thunk);
-  }
-  pic_catch {
-    struct pic_error *e = pic->err;
-
-    pic->err = NULL;
-
-    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;
-}
-
-noreturn static pic_value
-pic_error_raise(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  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)
-{
-  const char *str;
-  size_t argc;
-  pic_value *argv;
-
-  pic_get_args(pic, "z*", &str, &argc, &argv);
-
-  pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv));
-}
-
-static pic_value
-pic_error_error_object_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_error_p(v));
-}
-
-static pic_value
-pic_error_error_object_message(pic_state *pic)
-{
-  struct pic_error *e;
-
-  pic_get_args(pic, "e", &e);
-
-  return pic_obj_value(e->msg);
-}
-
-static pic_value
-pic_error_error_object_irritants(pic_state *pic)
-{
-  struct pic_error *e;
-
-  pic_get_args(pic, "e", &e);
-
-  return e->irrs;
-}
-
-static pic_value
-pic_error_read_error_p(pic_state *pic)
-{
-  pic_value v;
-  struct pic_error *e;
-
-  pic_get_args(pic, "o", &v);
-
-  if (! pic_error_p(v)) {
-    return pic_false_value();
-  }
-
-  e = pic_error_ptr(v);
-  return pic_bool_value(e->type == PIC_ERROR_READ);
-}
-
-static pic_value
-pic_error_file_error_p(pic_state *pic)
-{
-  pic_value v;
-  struct pic_error *e;
-
-  pic_get_args(pic, "o", &v);
-
-  if (! pic_error_p(v)) {
-    return pic_false_value();
-  }
-
-  e = pic_error_ptr(v);
-  return pic_bool_value(e->type == PIC_ERROR_FILE);
-}
-
-void
-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);
-  pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
-  pic_defun(pic, "read-error?", pic_error_read_error_p);
-  pic_defun(pic, "file-error?", pic_error_file_error_p);
-}

src/eval.c

@@ -1,39 +0,0 @@
-/**
- * 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);
-  }
-}

src/file.c

@@ -1,119 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#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)
-{
-  struct pic_port *port;
-  xFILE *file;
-
-  file = xfopen(fname, mode);
-  if (! file) {
-    file_error(pic, "could not open file");
-  }
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
-  port->file = file;
-  port->flags = flags;
-  port->status = PIC_PORT_OPEN;
-
-  return pic_obj_value(port);
-}
-
-pic_value
-pic_file_open_input_file(pic_state *pic)
-{
-  static const short flags = PIC_PORT_IN | PIC_PORT_TEXT;
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  return generic_open_file(pic, fname, "r", flags);
-}
-
-pic_value
-pic_file_open_input_binary_file(pic_state *pic)
-{
-  static const short flags = PIC_PORT_IN | PIC_PORT_BINARY;
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  return generic_open_file(pic, fname, "rb", flags);
-}
-
-pic_value
-pic_file_open_output_file(pic_state *pic)
-{
-  static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT;
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  return generic_open_file(pic, fname, "w", flags);
-}
-
-pic_value
-pic_file_open_output_binary_file(pic_state *pic)
-{
-  static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY;
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  return generic_open_file(pic, fname, "wb", flags);
-}
-
-pic_value
-pic_file_exists_p(pic_state *pic)
-{
-  char *fname;
-  FILE *fp;
-
-  pic_get_args(pic, "z", &fname);
-
-  fp = fopen(fname, "r");
-  if (fp) {
-    fclose(fp);
-    return pic_true_value();
-  } else {
-    return pic_false_value();
-  }
-}
-
-pic_value
-pic_file_delete(pic_state *pic)
-{
-  char *fname;
-
-  pic_get_args(pic, "z", &fname);
-
-  if (remove(fname) != 0) {
-    file_error(pic, "file cannot be deleted");
-  }
-  return pic_none_value();
-}
-
-void
-pic_init_file(pic_state *pic)
-{
-  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);
-    pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file);
-    pic_defun(pic, "file-exists?", pic_file_exists_p);
-    pic_defun(pic, "delete-file", pic_file_delete);
-  }
-}

src/gc.c

@@ -1,872 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/gc.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/vector.h"
-#include "picrin/irep.h"
-#include "picrin/proc.h"
-#include "picrin/port.h"
-#include "picrin/blob.h"
-#include "picrin/cont.h"
-#include "picrin/error.h"
-#include "picrin/macro.h"
-#include "picrin/lib.h"
-#include "picrin/var.h"
-#include "picrin/data.h"
-#include "picrin/dict.h"
-#include "picrin/record.h"
-#include "picrin/read.h"
-
-#if GC_DEBUG
-# include <string.h>
-#endif
-
-union header {
-  struct {
-    union header *ptr;
-    size_t size;
-    unsigned int mark : 1;
-  } s;
-  long alignment[4];
-};
-
-struct heap_page {
-  union header *basep, *endp;
-  struct heap_page *next;
-};
-
-struct pic_heap {
-  union header base, *freep;
-  struct heap_page *pages;
-};
-
-
-static void
-heap_init(struct pic_heap *heap)
-{
-  heap->base.s.ptr = &heap->base;
-  heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
-  heap->base.s.mark = PIC_GC_UNMARK;
-
-  heap->freep = &heap->base;
-  heap->pages = NULL;
-
-#if GC_DEBUG
-  printf("freep = %p\n", (void *)heap->freep);
-#endif
-}
-
-struct pic_heap *
-pic_heap_open()
-{
-  struct pic_heap *heap;
-
-  heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap));
-  heap_init(heap);
-  return heap;
-}
-
-void
-pic_heap_close(struct pic_heap *heap)
-{
-  struct heap_page *page;
-
-  while (heap->pages) {
-    page = heap->pages;
-    heap->pages = heap->pages->next;
-    free(page);
-  }
-}
-
-static void gc_free(pic_state *, union header *);
-
-static void
-add_heap_page(pic_state *pic)
-{
-  union header *up, *np;
-  struct heap_page *page;
-  size_t nu;
-
-#if GC_DEBUG
-  puts("adding heap page!");
-#endif
-
-  nu = (PIC_HEAP_PAGE_SIZE + sizeof(union header) - 1) / sizeof(union header) + 1;
-
-  up = (union header *)pic_calloc(pic, 1 + nu + 1, sizeof(union header));
-  up->s.size = nu + 1;
-  up->s.mark = PIC_GC_UNMARK;
-  gc_free(pic, up);
-
-  np = up + 1;
-  np->s.size = nu;
-  np->s.ptr = up->s.ptr;
-  up->s.size = 1;
-  up->s.ptr = np;
-
-  page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page));
-  page->basep = up;
-  page->endp = up + nu + 1;
-  page->next = pic->heap->pages;
-
-  pic->heap->pages = page;
-}
-
-static void *
-alloc(void *ptr, size_t size)
-{
-  if (size == 0) {
-    if (ptr) {
-      free(ptr);
-    }
-    return NULL;
-  }
-  if (ptr) {
-    return realloc(ptr, size);
-  } else {
-    return malloc(size);
-  }
-}
-
-void *
-pic_alloc(pic_state *pic, size_t size)
-{
-  void *ptr;
-
-  ptr = alloc(NULL, size);
-  if (ptr == NULL && size > 0) {
-    pic_abort(pic, "memory exhausted");
-  }
-  return ptr;
-}
-
-void *
-pic_realloc(pic_state *pic, void *ptr, size_t size)
-{
-  ptr = alloc(ptr, size);
-  if (ptr == NULL && size > 0) {
-    pic_abort(pic, "memory exhausted");
-  }
-  return ptr;
-}
-
-void *
-pic_calloc(pic_state *pic, size_t count, size_t size)
-{
-  void *ptr;
-
-  size *= count;
-  ptr = alloc(NULL, size);
-  if (ptr == NULL && size > 0) {
-    pic_abort(pic, "memory exhausted");
-  }
-  memset(ptr, 0, size);
-  return ptr;
-}
-
-void
-pic_free(pic_state *pic, void *ptr)
-{
-  UNUSED(pic);
-
-  free(ptr);
-}
-
-static void
-gc_protect(pic_state *pic, struct pic_object *obj)
-{
-  if (pic->arena_idx >= pic->arena_size) {
-    pic->arena_size = pic->arena_size * 2 + 1;
-    pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
-  }
-  pic->arena[pic->arena_idx++] = obj;
-}
-
-pic_value
-pic_gc_protect(pic_state *pic, pic_value v)
-{
-  struct pic_object *obj;
-
-  if (pic_vtype(v) != PIC_VTYPE_HEAP) {
-    return v;
-  }
-  obj = pic_obj_ptr(v);
-
-  gc_protect(pic, obj);
-
-  return v;
-}
-
-size_t
-pic_gc_arena_preserve(pic_state *pic)
-{
-  return pic->arena_idx;
-}
-
-void
-pic_gc_arena_restore(pic_state *pic, size_t state)
-{
-  pic->arena_idx = state;
-}
-
-static void *
-gc_alloc(pic_state *pic, size_t size)
-{
-  union header *freep, *p, *prevp;
-  size_t nunits;
-
-#if GC_DEBUG
-  assert(size > 0);
-#endif
-
-  nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
-
-  prevp = freep = pic->heap->freep;
-  for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
-    if (p->s.size >= nunits)
-      break;
-    if (p == freep) {
-      return NULL;
-    }
-  }
-
-#if GC_DEBUG
-  {
-    unsigned char *c;
-    size_t s, i, j;
-    if (p->s.size == nunits) {
-      c = (unsigned char *)(p + p->s.size - nunits + 1);
-      s = nunits - 1;
-    } else {
-      c = (unsigned char *)(p + p->s.size - nunits);
-      s = nunits;
-    }
-
-    for (i = 0; i < s; ++i) {
-      for (j = 0; j < sizeof(union header); ++j) {
-	assert(c[i * sizeof(union header) + j] == 0xAA);
-      }
-    }
-  }
-#endif
-
-  if (p->s.size == nunits) {
-    prevp->s.ptr = p->s.ptr;
-  }
-  else {
-    p->s.size -= nunits;
-    p += p->s.size;
-    p->s.size = nunits;
-  }
-  pic->heap->freep = prevp;
-
-  p->s.mark = PIC_GC_UNMARK;
-
-#if GC_DEBUG
-  memset(p+1, 0, sizeof(union header) * (nunits - 1));
-  p->s.ptr = (union header *)0xcafebabe;
-#endif
-
-  return (void *)(p + 1);
-}
-
-static void
-gc_free(pic_state *pic, union header *bp)
-{
-  union header *freep, *p;
-
-#if GC_DEBUG
-  assert(bp != NULL);
-  assert(bp->s.size > 1);
-#endif
-
-#if GC_DEBUG
-  memset(bp + 1, 0xAA, (bp->s.size - 1) * sizeof(union header));
-#endif
-
-  freep = pic->heap->freep;
-  for (p = freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
-    if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
-      break;
-    }
-  }
-  if (bp + bp->s.size == p->s.ptr) {
-    bp->s.size += p->s.ptr->s.size;
-    bp->s.ptr = p->s.ptr->s.ptr;
-
-#if GC_DEBUG
-    memset(p->s.ptr, 0xAA, sizeof(union header));
-#endif
-  }
-  else {
-    bp->s.ptr = p->s.ptr;
-  }
-  if (p + p->s.size == bp && p->s.size > 1) {
-    p->s.size += bp->s.size;
-    p->s.ptr = bp->s.ptr;
-
-#if GC_DEBUG
-    memset(bp, 0xAA, sizeof(union header));
-#endif
-  }
-  else {
-    p->s.ptr = bp;
-  }
-  pic->heap->freep = p;
-}
-
-static void gc_mark(pic_state *, pic_value);
-static void gc_mark_object(pic_state *pic, struct pic_object *obj);
-
-static bool
-gc_is_marked(union header *p)
-{
-  return p->s.mark == PIC_GC_MARK;
-}
-
-static void
-gc_unmark(union header *p)
-{
-  p->s.mark = PIC_GC_UNMARK;
-}
-
-static void
-gc_mark_object(pic_state *pic, struct pic_object *obj)
-{
-  union header *p;
-
-  p = ((union header *)obj) - 1;
-
-  if (gc_is_marked(p))
-    return;
-  p->s.mark = PIC_GC_MARK;
-
-  switch (obj->tt) {
-  case PIC_TT_PAIR: {
-    gc_mark(pic, ((struct pic_pair *)obj)->car);
-    gc_mark(pic, ((struct pic_pair *)obj)->cdr);
-    break;
-  }
-  case PIC_TT_ENV: {
-    struct pic_env *env = (struct pic_env *)obj;
-    int i;
-
-    for (i = 0; i < env->regc; ++i) {
-      gc_mark(pic, env->regs[i]);
-    }
-    if (env->up) {
-      gc_mark_object(pic, (struct pic_object *)env->up);
-    }
-    break;
-  }
-  case PIC_TT_PROC: {
-    struct pic_proc *proc = (struct pic_proc *)obj;
-    if (proc->env) {
-      gc_mark_object(pic, (struct pic_object *)proc->env);
-    }
-    if (proc->attr) {
-      gc_mark_object(pic, (struct pic_object *)proc->attr);
-    }
-    if (pic_proc_irep_p(proc)) {
-      gc_mark_object(pic, (struct pic_object *)proc->u.irep);
-    }
-    break;
-  }
-  case PIC_TT_PORT: {
-    break;
-  }
-  case PIC_TT_ERROR: {
-    struct pic_error *err = (struct pic_error *)obj;
-    gc_mark_object(pic,(struct pic_object *)err->msg);
-    gc_mark(pic, err->irrs);
-    gc_mark_object(pic, (struct pic_object *)err->stack);
-    break;
-  }
-  case PIC_TT_STRING: {
-    break;
-  }
-  case PIC_TT_VECTOR: {
-    size_t i;
-    for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) {
-      gc_mark(pic, ((struct pic_vector *)obj)->data[i]);
-    }
-    break;
-  }
-  case PIC_TT_BLOB: {
-    break;
-  }
-  case PIC_TT_CONT: {
-    struct pic_cont *cont = (struct pic_cont *)obj;
-    pic_value *stack;
-    pic_callinfo *ci;
-    size_t i;
-
-    /* block */
-    gc_mark_object(pic, (struct pic_object *)cont->blk);
-
-    /* stack */
-    for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) {
-      gc_mark(pic, *stack);
-    }
-
-    /* callinfo */
-    for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) {
-      if (ci->env) {
-	gc_mark_object(pic, (struct pic_object *)ci->env);
-      }
-    }
-
-    /* arena */
-    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;
-  }
-  case PIC_TT_MACRO: {
-    struct pic_macro *mac = (struct pic_macro *)obj;
-
-    if (mac->proc) {
-      gc_mark_object(pic, (struct pic_object *)mac->proc);
-    }
-    if (mac->senv) {
-      gc_mark_object(pic, (struct pic_object *)mac->senv);
-    }
-    break;
-  }
-  case PIC_TT_SENV: {
-    struct pic_senv *senv = (struct pic_senv *)obj;
-
-    if (senv->up) {
-      gc_mark_object(pic, (struct pic_object *)senv->up);
-    }
-    break;
-  }
-  case PIC_TT_LIB: {
-    struct pic_lib *lib = (struct pic_lib *)obj;
-    gc_mark(pic, lib->name);
-    gc_mark_object(pic, (struct pic_object *)lib->env);
-    break;
-  }
-  case PIC_TT_VAR: {
-    struct pic_var *var = (struct pic_var *)obj;
-    gc_mark(pic, var->stack);
-    if (var->conv) {
-      gc_mark_object(pic, (struct pic_object *)var->conv);
-    }
-    break;
-  }
-  case PIC_TT_IREP: {
-    struct pic_irep *irep = (struct pic_irep *)obj;
-    size_t i;
-
-    for (i = 0; i < irep->ilen; ++i) {
-      gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
-    }
-    for (i = 0; i < irep->plen; ++i) {
-      gc_mark(pic, irep->pool[i]);
-    }
-    break;
-  }
-  case PIC_TT_DATA: {
-    struct pic_data *data = (struct pic_data *)obj;
-    xh_iter it;
-
-    xh_begin(&it, &data->storage);
-    while (xh_next(&it)) {
-      gc_mark(pic, xh_val(it.e, pic_value));
-    }
-    break;
-  }
-  case PIC_TT_DICT: {
-    struct pic_dict *dict = (struct pic_dict *)obj;
-    xh_iter it;
-
-    xh_begin(&it, &dict->hash);
-    while (xh_next(&it)) {
-      gc_mark(pic, xh_val(it.e, pic_value));
-    }
-    break;
-  }
-  case PIC_TT_RECORD: {
-    struct pic_record *rec = (struct pic_record *)obj;
-    xh_iter it;
-
-    xh_begin(&it, &rec->hash);
-    while (xh_next(&it)) {
-      gc_mark(pic, xh_val(it.e, pic_value));
-    }
-    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:
-  case PIC_TT_INT:
-  case PIC_TT_SYMBOL:
-  case PIC_TT_CHAR:
-  case PIC_TT_EOF:
-  case PIC_TT_UNDEF:
-    pic_abort(pic, "logic flaw");
-  }
-}
-
-static void
-gc_mark(pic_state *pic, pic_value v)
-{
-  struct pic_object *obj;
-
-  if (pic_vtype(v) != PIC_VTYPE_HEAP)
-    return;
-  obj = pic_obj_ptr(v);
-
-  gc_mark_object(pic, obj);
-}
-
-static void
-gc_mark_trie(pic_state *pic, struct pic_trie *trie)
-{
-  size_t i;
-
-  for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) {
-    if (trie->table[i] != NULL) {
-      gc_mark_trie(pic, trie->table[i]);
-    }
-  }
-  if (trie->proc != NULL) {
-    gc_mark_object(pic, (struct pic_object *)trie->proc);
-  }
-}
-
-static void
-gc_mark_phase(pic_state *pic)
-{
-  pic_value *stack;
-  pic_callinfo *ci;
-  size_t i, j;
-  xh_iter it;
-
-  /* block */
-  if (pic->blk) {
-    gc_mark_object(pic, (struct pic_object *)pic->blk);
-  }
-
-  /* stack */
-  for (stack = pic->stbase; stack != pic->sp; ++stack) {
-    gc_mark(pic, *stack);
-  }
-
-  /* callinfo */
-  for (ci = pic->ci; ci != pic->cibase; --ci) {
-    if (ci->env) {
-      gc_mark_object(pic, (struct pic_object *)ci->env);
-    }
-  }
-
-  /* error object */
-  if (pic->err) {
-    gc_mark_object(pic, (struct pic_object *)pic->err);
-  }
-
-  /* arena */
-  for (j = 0; j < pic->arena_idx; ++j) {
-    gc_mark_object(pic, pic->arena[j]);
-  }
-
-  /* global variables */
-  xh_begin(&it, &pic->globals);
-  while (xh_next(&it)) {
-    gc_mark(pic, xh_val(it.e, pic_value));
-  }
-
-  /* macro objects */
-  xh_begin(&it, &pic->macros);
-  while (xh_next(&it)) {
-    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);
-    }
-  }
-
-  /* readers */
-  gc_mark_trie(pic, pic->reader->trie);
-
-  /* library table */
-  gc_mark(pic, pic->libs);
-}
-
-static void
-gc_finalize_object(pic_state *pic, struct pic_object *obj)
-{
-#if GC_DEBUG
-  printf("* finalizing object: %s", pic_type_repr(pic_type(pic_obj_value(obj))));
-  //  pic_debug(pic, pic_obj_value(obj));
-  puts("");
-#endif
-
-  switch (obj->tt) {
-  case PIC_TT_PAIR: {
-    break;
-  }
-  case PIC_TT_ENV: {
-    break;
-  }
-  case PIC_TT_PROC: {
-    break;
-  }
-  case PIC_TT_VECTOR: {
-    pic_free(pic, ((struct pic_vector *)obj)->data);
-    break;
-  }
-  case PIC_TT_BLOB: {
-    pic_free(pic, ((struct pic_blob *)obj)->data);
-    break;
-  }
-  case PIC_TT_STRING: {
-    XROPE_DECREF(((struct pic_string *)obj)->rope);
-    break;
-  }
-  case PIC_TT_PORT: {
-    break;
-  }
-  case PIC_TT_ERROR: {
-    break;
-  }
-  case PIC_TT_CONT: {
-    struct pic_cont *cont = (struct pic_cont *)obj;
-    pic_free(pic, cont->stk_ptr);
-    pic_free(pic, cont->st_ptr);
-    pic_free(pic, cont->ci_ptr);
-    pic_free(pic, cont->arena);
-    pic_free(pic, cont->try_jmps);
-    break;
-  }
-  case PIC_TT_SENV: {
-    struct pic_senv *senv = (struct pic_senv *)obj;
-    xh_destroy(&senv->map);
-    break;
-  }
-  case PIC_TT_MACRO: {
-    break;
-  }
-  case PIC_TT_LIB: {
-    struct pic_lib *lib = (struct pic_lib *)obj;
-    xh_destroy(&lib->exports);
-    break;
-  }
-  case PIC_TT_VAR: {
-    break;
-  }
-  case PIC_TT_IREP: {
-    struct pic_irep *irep = (struct pic_irep *)obj;
-    pic_free(pic, irep->code);
-    pic_free(pic, irep->irep);
-    pic_free(pic, irep->pool);
-    break;
-  }
-  case PIC_TT_DATA: {
-    struct pic_data *data = (struct pic_data *)obj;
-    data->type->dtor(pic, data->data);
-    xh_destroy(&data->storage);
-    break;
-  }
-  case PIC_TT_DICT: {
-    struct pic_dict *dict = (struct pic_dict *)obj;
-    xh_destroy(&dict->hash);
-    break;
-  }
-  case PIC_TT_RECORD: {
-    struct pic_record *rec = (struct pic_record *)obj;
-    xh_destroy(&rec->hash);
-    break;
-  }
-  case PIC_TT_BLK: {
-    break;
-  }
-  case PIC_TT_NIL:
-  case PIC_TT_BOOL:
-  case PIC_TT_FLOAT:
-  case PIC_TT_INT:
-  case PIC_TT_SYMBOL:
-  case PIC_TT_CHAR:
-  case PIC_TT_EOF:
-  case PIC_TT_UNDEF:
-    pic_abort(pic, "logic flaw");
-  }
-}
-
-static void
-gc_sweep_page(pic_state *pic, struct heap_page *page)
-{
-#if GC_DEBUG
-  static union header *NIL = (union header *)0xdeadbeef;
-#else
-  static union header *NIL = NULL;
-#endif
-  union header *bp, *p, *s = NIL, *t;
-
-#if GC_DEBUG
-  int c = 0;
-#endif
-
-  for (bp = page->basep; ; bp = bp->s.ptr) {
-    for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) {
-      if (p == page->endp) {
-	goto escape;
-      }
-      if (! gc_is_marked(p)) {
-	if (s == NIL) {
-	  s = p;
-	}
-	else {
-	  t->s.ptr = p;
-	}
-	t = p;
-	t->s.ptr = NIL; /* For dead objects we can safely reuse ptr field */
-      }
-      gc_unmark(p);
-    }
-  }
- escape:
-
-  /* free! */
-  while (s != NIL) {
-    t = s->s.ptr;
-    gc_finalize_object(pic, (struct pic_object *)(s + 1));
-    gc_free(pic, s);
-    s = t;
-
-#if GC_DEBUG
-    c++;
-#endif
-  }
-
-#if GC_DEBUG
-  printf("freed objects count: %d\n", c);
-#endif
-}
-
-static void
-gc_sweep_phase(pic_state *pic)
-{
-  struct heap_page *page = pic->heap->pages;
-
-  while (page) {
-    gc_sweep_page(pic, page);
-    page = page->next;
-  }
-}
-
-void
-pic_gc_run(pic_state *pic)
-{
-#if GC_DEBUG
-  struct heap_page *page;
-#endif
-
-#if DEBUG
-  puts("gc run!");
-#endif
-
-  gc_mark_phase(pic);
-  gc_sweep_phase(pic);
-
-#if GC_DEBUG
-  for (page = pic->heap->pages; page; page = page->next) {
-    union header *bp, *p;
-    unsigned char *c;
-
-    for (bp = page->basep; ; bp = bp->s.ptr) {
-      for (c = (unsigned char *)(bp+1); c != (unsigned char *)(bp + bp->s.size); ++c) {
-	assert(*c == 0xAA);
-      }
-      for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) {
-	if (p == page->endp) {
-	  /* if (page->next) */
-	  /*   assert(bp->s.ptr == page->next->basep); */
-	  /* else */
-	  /*   assert(bp->s.ptr == &pic->heap->base); */
-	  goto escape;
-	}
-	assert(! gc_is_marked(p));
-      }
-    }
-  escape:
-    ((void)0);
-  }
-
-  puts("not error on heap found! gc successfully finished");
-#endif
-}
-
-struct pic_object *
-pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt)
-{
-  struct pic_object *obj;
-
-#if GC_DEBUG
-  printf("*allocating: %s\n", pic_type_repr(tt));
-#endif
-
-#if GC_STRESS
-  pic_gc_run(pic);
-#endif
-
-  obj = (struct pic_object *)gc_alloc(pic, size);
-  if (obj == NULL) {
-    pic_gc_run(pic);
-    obj = (struct pic_object *)gc_alloc(pic, size);
-    if (obj == NULL) {
-      add_heap_page(pic);
-      obj = (struct pic_object *)gc_alloc(pic, size);
-      if (obj == NULL)
-	pic_abort(pic, "GC memory exhausted");
-    }
-  }
-  obj->tt = tt;
-
-  return obj;
-}
-
-struct pic_object *
-pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt)
-{
-  struct pic_object *obj;
-
-  obj = pic_obj_alloc_unsafe(pic, size, tt);
-
-  gc_protect(pic, obj);
-  return obj;
-}

src/init.c

@@ -1,125 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/read.h"
-#include "picrin/lib.h"
-#include "picrin/macro.h"
-#include "picrin/error.h"
-
-static pic_value
-pic_features(pic_state *pic)
-{
-  pic_value features = pic_nil_value();
-
-  pic_get_args(pic, "");
-
-  pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features);
-  pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features);
-  pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features);
-
-  return features;
-}
-
-static pic_value
-pic_libraries(pic_state *pic)
-{
-  pic_value libs = pic_nil_value(), lib;
-
-  pic_get_args(pic, "");
-
-  pic_for_each (lib, pic->libs) {
-    libs = pic_cons(pic, pic_car(pic, lib), libs);
-  }
-
-  return libs;
-}
-
-void pic_init_bool(pic_state *);
-void pic_init_pair(pic_state *);
-void pic_init_port(pic_state *);
-void pic_init_number(pic_state *);
-void pic_init_time(pic_state *);
-void pic_init_system(pic_state *);
-void pic_init_file(pic_state *);
-void pic_init_proc(pic_state *);
-void pic_init_symbol(pic_state *);
-void pic_init_vector(pic_state *);
-void pic_init_blob(pic_state *);
-void pic_init_cont(pic_state *);
-void pic_init_char(pic_state *);
-void pic_init_error(pic_state *);
-void pic_init_str(pic_state *);
-void pic_init_macro(pic_state *);
-void pic_init_var(pic_state *);
-void pic_init_load(pic_state *);
-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 *);
-
-#define DONE pic_gc_arena_restore(pic, ai);
-
-void
-pic_init_core(pic_state *pic)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-
-  pic_init_reader(pic);
-
-  pic_deflibrary (pic, "(picrin base core)") {
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
-  }
-
-  pic_deflibrary (pic, "(picrin library)") {
-    pic_defun(pic, "libraries", pic_libraries);
-  }
-
-  pic_deflibrary (pic, "(scheme base)") {
-    pic_defun(pic, "features", pic_features);
-
-    pic_init_bool(pic); DONE;
-    pic_init_pair(pic); DONE;
-    pic_init_port(pic); DONE;
-    pic_init_number(pic); DONE;
-    pic_init_time(pic); DONE;
-    pic_init_system(pic); DONE;
-    pic_init_file(pic); DONE;
-    pic_init_proc(pic); DONE;
-    pic_init_symbol(pic); DONE;
-    pic_init_vector(pic); DONE;
-    pic_init_blob(pic); DONE;
-    pic_init_cont(pic); DONE;
-    pic_init_char(pic); DONE;
-    pic_init_error(pic); DONE;
-    pic_init_str(pic); DONE;
-    pic_init_macro(pic); DONE;
-    pic_init_var(pic); DONE;
-    pic_init_load(pic); DONE;
-    pic_init_write(pic); DONE;
-    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_init_contrib(pic); DONE;
-
-    pic_load_piclib(pic); DONE;
-  }
-}

src/lib.c

@@ -1,273 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#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)
-{
-  struct pic_lib *lib;
-  struct pic_senv *senv;
-
-  if ((lib = pic_find_library(pic, name)) != NULL) {
-
-#if DEBUG
-    printf("* reopen library: ");
-    pic_debug(pic, name);
-    puts("");
-#endif
-
-    return lib;
-  }
-
-  senv = pic_null_syntactic_environment(pic);
-
-  lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
-  lib->env = senv;
-  lib->name = name;
-  xh_init_int(&lib->exports, sizeof(pic_sym));
-
-  /* register! */
-  pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
-
-  return lib;
-}
-
-void
-pic_in_library(pic_state *pic, pic_value spec)
-{
-  struct pic_lib *lib;
-
-  lib = pic_find_library(pic, spec);
-  if (! lib) {
-    pic_errorf(pic, "library not found: ~a", spec);
-  }
-  pic->lib = lib;
-}
-
-struct pic_lib *
-pic_find_library(pic_state *pic, pic_value spec)
-{
-  pic_value v;
-
-  v = pic_assoc(pic, spec, pic->libs, NULL);
-  if (pic_false_p(v)) {
-    return NULL;
-  }
-  return pic_lib_ptr(pic_cdr(pic, v));
-}
-
-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, pic_sym(xh_val(it.e, pic_value))));
-#endif
-
-    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)
-{
-  export(pic, pic_sym_value(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]);
-  }
-
-  return pic_none_value();
-}
-
-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();
-}
-
-static pic_value
-pic_lib_in_library(pic_state *pic)
-{
-  pic_value spec;
-
-  pic_get_args(pic, "o", &spec);
-
-  pic_in_library(pic, spec);
-
-  return pic_none_value();
-}
-
-void
-pic_init_lib(pic_state *pic)
-{
-  void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);
-
-  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);
-  pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library);
-}

src/load.c

@@ -1,87 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/pair.h"
-
-pic_value
-pic_load_cstr(pic_state *pic, const char *src)
-{
-  size_t ai;
-  pic_value v, exprs;
-  struct pic_proc *proc;
-
-  exprs = pic_parse_cstr(pic, src);
-  if (pic_undef_p(exprs)) {
-    pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
-  }
-
-  pic_for_each (v, exprs) {
-    ai = pic_gc_arena_preserve(pic);
-
-    proc = pic_compile(pic, v, pic->lib);
-    if (proc == NULL) {
-      pic_error(pic, "load: compilation failure");
-    }
-
-    pic_apply(pic, proc, pic_nil_value());
-
-    pic_gc_arena_restore(pic, ai);
-  }
-
-  return pic_none_value();
-}
-
-pic_value
-pic_load(pic_state *pic, const char *fn)
-{
-  FILE *file;
-  size_t ai;
-  pic_value v, exprs;
-  struct pic_proc *proc;
-
-  file = fopen(fn, "r");
-  if (file == NULL) {
-    pic_errorf(pic, "load: could not read file \"%s\"", fn);
-  }
-
-  exprs = pic_parse_file(pic, file);
-  if (pic_undef_p(exprs)) {
-    pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
-  }
-
-  pic_for_each (v, exprs) {
-    ai = pic_gc_arena_preserve(pic);
-
-    proc = pic_compile(pic, v, pic->lib);
-    if (proc == NULL) {
-      pic_error(pic, "load: compilation failure");
-    }
-
-    pic_apply(pic, proc, pic_nil_value());
-
-    pic_gc_arena_restore(pic, ai);
-  }
-
-  return pic_none_value();
-}
-
-static pic_value
-pic_load_load(pic_state *pic)
-{
-  pic_value envid;
-  char *fn;
-
-  pic_get_args(pic, "z|o", &fn, &envid);
-
-  return pic_load(pic, fn);
-}
-
-void
-pic_init_load(pic_state *pic)
-{
-  pic_deflibrary (pic, "(scheme load)") {
-    pic_defun(pic, "load", pic_load_load);
-  }
-}

src/macro.c

@@ -1,494 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/proc.h"
-#include "picrin/macro.h"
-#include "picrin/lib.h"
-#include "picrin/error.h"
-#include "picrin/dict.h"
-#include "picrin/cont.h"
-
-pic_sym
-pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
-{
-  pic_sym rename;
-
-  rename = pic_gensym(pic, sym);
-  pic_put_rename(pic, senv, sym, rename);
-  return rename;
-}
-
-void
-pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename)
-{
-  UNUSED(pic);
-
-  xh_put_int(&senv->map, sym, &rename);
-}
-
-bool
-pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename)
-{
-  xh_entry *e;
-
-  UNUSED(pic);
-
-  if ((e = xh_get_int(&senv->map, sym)) == NULL) {
-    return false;
-  }
-  if (rename != NULL) {
-    *rename = xh_val(e, pic_sym);
-  }
-  return true;
-}
-
-static void
-define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv)
-{
-  struct pic_macro *mac;
-
-  mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO);
-  mac->senv = senv;
-  mac->proc = proc;
-
-  xh_put_int(&pic->macros, rename, &mac);
-}
-
-static struct pic_macro *
-find_macro(pic_state *pic, pic_sym rename)
-{
-  xh_entry *e;
-
-  if ((e = xh_get_int(&pic->macros, rename)) == NULL) {
-    return NULL;
-  }
-  return xh_val(e, struct pic_macro *);
-}
-
-static pic_sym
-make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv)
-{
-  pic_sym rename;
-
-  while (true) {
-    if (pic_find_rename(pic, senv, sym, &rename)) {
-      return rename;
-    }
-    if (! senv->up)
-      break;
-    senv = senv->up;
-  }
-  if (! pic_interned_p(pic, sym)) {
-    return sym;
-  }
-  else {
-    return pic_gensym(pic, sym);
-  }
-}
-
-static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
-
-static pic_value
-macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv)
-{
-  return pic_sym_value(make_identifier(pic, sym, senv));
-}
-
-static pic_value
-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_list(pic_state *pic, pic_value obj, struct pic_senv *senv)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value x, head, tail;
-
-  if (pic_pair_p(obj)) {
-    head = macroexpand(pic, pic_car(pic, obj), senv);
-    tail = macroexpand_list(pic, pic_cdr(pic, obj), senv);
-    x = pic_cons(pic, head, tail);
-  } else {
-    x = macroexpand(pic, obj, senv);
-  }
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, x);
-  return x;
-}
-
-static pic_value
-macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  pic_value formal, body;
-  struct pic_senv *in;
-  pic_value a;
-
-  if (pic_length(pic, expr) < 2) {
-    pic_error(pic, "syntax error");
-  }
-
-  in = pic_senv_new(pic, senv);
-
-  for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
-    pic_value v = pic_car(pic, a);
-
-    if (! pic_sym_p(v)) {
-      pic_error(pic, "syntax error");
-    }
-    pic_add_rename(pic, in, pic_sym(v));
-  }
-  if (pic_sym_p(a)) {
-    pic_add_rename(pic, in, pic_sym(a));
-  }
-  else if (! pic_nil_p(a)) {
-    pic_error(pic, "syntax error");
-  }
-
-  formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
-  body = macroexpand_list(pic, pic_cddr(pic, expr), in);
-
-  return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
-}
-
-static pic_value
-macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  pic_sym sym, rename;
-  pic_value var, val;
-
-  if (pic_length(pic, expr) != 3) {
-    pic_error(pic, "syntax error");
-  }
-
-  var = pic_cadr(pic, expr);
-  if (! pic_sym_p(var)) {
-    pic_error(pic, "binding to non-symbol object");
-  }
-  sym = pic_sym(var);
-  if (! pic_find_rename(pic, senv, sym, &rename)) {
-    rename = pic_add_rename(pic, senv, sym);
-  }
-  val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv);
-
-  return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val);
-}
-
-static pic_value
-macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  pic_value var, val;
-  pic_sym sym, rename;
-
-  if (pic_length(pic, expr) != 3) {
-    pic_error(pic, "syntax error");
-  }
-
-  var = pic_cadr(pic, expr);
-  if (! pic_sym_p(var)) {
-    pic_error(pic, "binding to non-symbol object");
-  }
-  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, pic->lib);
-  } pic_catch {
-    pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
-  }
-
-  if (! pic_proc_p(val)) {
-    pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
-  }
-
-  define_macro(pic, rename, pic_proc_ptr(val), senv);
-
-  return pic_none_value();
-}
-
-static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
-{
-  pic_value v, args;
-
-#if DEBUG
-  puts("before expand-1:");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  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));
-  }
-
-#if DEBUG
-  puts("after expand-1:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  return v;
-}
-
-static pic_value
-macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
-  switch (pic_type(expr)) {
-  case PIC_TT_SYMBOL: {
-    return macroexpand_symbol(pic, pic_sym(expr), senv);
-  }
-  case PIC_TT_PAIR: {
-    pic_value car;
-    struct pic_macro *mac;
-
-    if (! pic_list_p(expr)) {
-      pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
-    }
-
-    car = macroexpand(pic, pic_car(pic, expr), senv);
-    if (pic_sym_p(car)) {
-      pic_sym tag = pic_sym(car);
-
-      if (tag == pic->rDEFINE_SYNTAX) {
-        return macroexpand_defsyntax(pic, expr, senv);
-      }
-      else if (tag == pic->rLAMBDA) {
-        return macroexpand_lambda(pic, expr, senv);
-      }
-      else if (tag == pic->rDEFINE) {
-        return macroexpand_define(pic, expr, senv);
-      }
-      else if (tag == pic->rQUOTE) {
-        return macroexpand_quote(pic, expr);
-      }
-
-      if ((mac = find_macro(pic, tag)) != NULL) {
-        return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv);
-      }
-    }
-
-    return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
-  }
-  default:
-    return expr;
-  }
-}
-
-static pic_value
-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);
-  pic_gc_protect(pic, v);
-  return v;
-}
-
-pic_value
-pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
-{
-  struct pic_lib *prev;
-  pic_value v;
-
-#if DEBUG
-  puts("before expand:");
-  pic_debug(pic, expr);
-  puts("");
-#endif
-
-  /* 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:");
-  pic_debug(pic, v);
-  puts("");
-#endif
-
-  return v;
-}
-
-struct pic_senv *
-pic_senv_new(pic_state *pic, struct pic_senv *up)
-{
-  struct pic_senv *senv;
-
-  senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
-  senv->up = up;
-  xh_init_int(&senv->map, sizeof(pic_sym));
-
-  return senv;
-}
-
-struct pic_senv *
-pic_null_syntactic_environment(pic_state *pic)
-{
-  struct pic_senv *senv;
-
-  senv = pic_senv_new(pic, NULL);
-
-  pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
-  pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
-  pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);
-  pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY);
-
-  return senv;
-}
-
-void
-pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym)
-{
-  pic_put_rename(pic, senv, sym, rsym);
-
-  if (pic->lib && pic->lib->env == senv) {
-    pic_export(pic, sym);
-  }
-}
-
-void
-pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func)
-{
-  pic_put_rename(pic, pic->lib->env, name, id);
-
-  /* symbol registration */
-  define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL);
-
-  /* auto export! */
-  pic_export(pic, name);
-}
-
-bool
-pic_identifier_p(pic_state *pic, pic_value obj)
-{
-  return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj));
-}
-
-static pic_value
-pic_macro_gensym(pic_state *pic)
-{
-  static const char skel[] = ".g";
-  pic_sym uniq;
-
-  pic_get_args(pic, "");
-
-  uniq = pic_gensym(pic, pic_intern_cstr(pic, skel));
-  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)
-{
-  pic_value expr;
-
-  pic_get_args(pic, "o", &expr);
-
-  return pic_macroexpand(pic, expr, pic->lib);
-}
-
-static pic_value
-pic_macro_macroexpand_1(pic_state *pic)
-{
-  struct pic_senv *senv = pic->lib->env;
-  struct pic_macro *mac;
-  pic_value expr;
-  pic_sym sym;
-
-  pic_get_args(pic, "o", &expr);
-
-  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());
-    }
-  }
-  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
-pic_macro_identifier_p(pic_state *pic)
-{
-  pic_value obj;
-
-  pic_get_args(pic, "o", &obj);
-
-  return pic_bool_value(pic_identifier_p(pic, obj));
-}
-
-static pic_value
-pic_macro_make_identifier(pic_state *pic)
-{
-  pic_value obj;
-  pic_sym sym;
-
-  pic_get_args(pic, "mo", &sym, &obj);
-
-  pic_assert_type(pic, obj, senv);
-
-  return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj)));
-}
-
-void
-pic_init_macro(pic_state *pic)
-{
-  pic_deflibrary (pic, "(picrin base macro)") {
-    pic_defun(pic, "identifier?", pic_macro_identifier_p);
-    pic_defun(pic, "make-identifier", pic_macro_make_identifier);
-  }
-
-  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);
-  }
-}

src/main.c

@@ -0,0 +1,79 @@
+/**
+ * See Copyright Notice in picrin.h
+ */
+
+#define PIC_ARENA_SIZE (8 * 1024)
+#define PIC_HEAP_PAGE_SIZE (2 * 1024 * 1024)
+#define PIC_SYM_POOL_SIZE (2 * 1024)
+
+#include "picrin.h"
+#include "picrin/pair.h"
+#include "picrin/error.h"
+
+void pic_init_contrib(pic_state *);
+void pic_load_piclib(pic_state *);
+
+static pic_value
+pic_features(pic_state *pic)
+{
+  pic_get_args(pic, "");
+
+  return pic->features;
+}
+
+static pic_value
+pic_libraries(pic_state *pic)
+{
+  pic_value libs = pic_nil_value(), lib;
+
+  pic_get_args(pic, "");
+
+  pic_for_each (lib, pic->libs) {
+    libs = pic_cons(pic, pic_car(pic, lib), libs);
+  }
+
+  return libs;
+}
+
+void
+pic_init_picrin(pic_state *pic)
+{
+  pic_add_feature(pic, "r7rs");
+
+  pic_deflibrary (pic, "(picrin library)") {
+    pic_defun(pic, "libraries", pic_libraries);
+  }
+
+  pic_deflibrary (pic, "(scheme base)") {
+    pic_defun(pic, "features", pic_features);
+
+    pic_init_contrib(pic);
+    pic_load_piclib(pic);
+  }
+}
+
+int
+main(int argc, char *argv[], char **envp)
+{
+  pic_state *pic;
+  struct pic_lib *PICRIN_MAIN;
+  int status = 0;
+
+  pic = pic_open(argc, argv, envp);
+
+  pic_init_picrin(pic);
+
+  PICRIN_MAIN = pic_find_library(pic, pic_read_cstr(pic, "(picrin main)"));
+
+  pic_try {
+    pic_funcall(pic, PICRIN_MAIN, "main", pic_nil_value());
+  }
+  pic_catch {
+    pic_print_backtrace(pic);
+    status = 1;
+  }
+
+  pic_close(pic);
+
+  return status;
+}

src/number.c

@@ -1,944 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <math.h>
-#include <limits.h>
-#include <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/string.h"
-#include "picrin/cont.h"
-
-static int
-gcd(int a, int b)
-{
-  if (a > b)
-    return gcd(b, a);
-  if (a < 0)
-    return gcd(-a, b);
-  if (a > 0)
-    return gcd(b % a, a);
-  return b;
-}
-
-static double
-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)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_float_p(v) || pic_int_p(v));
-}
-
-static pic_value
-pic_number_integer_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_int_p(v)) {
-    return pic_true_value();
-  }
-  if (pic_float_p(v)) {
-    double f = pic_float(v);
-
-    if (isinf(f)) {
-      return pic_false_value();
-    }
-
-    if (f == round(f)) {
-      return pic_true_value();
-    }
-  }
-  return pic_false_value();
-}
-
-static pic_value
-pic_number_exact_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_int_p(v));
-}
-
-static pic_value
-pic_number_inexact_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_float_p(v));
-}
-
-static pic_value
-pic_number_finite_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_int_p(v))
-    return pic_true_value();
-  if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v))))
-    return pic_true_value();
-  else
-    return pic_false_value();
-}
-
-static pic_value
-pic_number_infinite_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_float_p(v) && isinf(pic_float(v)))
-    return pic_true_value();
-  else
-    return pic_false_value();
-}
-
-static pic_value
-pic_number_nan_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_float_p(v) && isnan(pic_float(v)))
-    return pic_true_value();
-  else
-    return pic_false_value();
-}
-
-#define DEFINE_ARITH_CMP(op, name)			\
-  static pic_value					\
-  pic_number_##name(pic_state *pic)			\
-  {							\
-    size_t argc;					\
-    pic_value *argv;					\
-    size_t i;						\
-    double f,g;						\
-    							\
-    pic_get_args(pic, "ff*", &f, &g, &argc, &argv);	\
-    							\
-    if (! (f op g))					\
-      return pic_false_value();				\
-    							\
-    for (i = 0; i < argc; ++i) {			\
-      f = g;                                            \
-      if (pic_float_p(argv[i]))				\
-	g = pic_float(argv[i]);				\
-      else if (pic_int_p(argv[i]))			\
-	g = pic_int(argv[i]);				\
-      else						\
-	pic_error(pic, #op ": number required");	\
-      							\
-      if (! (f op g))					\
-	return pic_false_value();			\
-    }							\
-    							\
-    return pic_true_value();				\
-  }
-
-DEFINE_ARITH_CMP(==, eq)
-DEFINE_ARITH_CMP(<, lt)
-DEFINE_ARITH_CMP(>, gt)
-DEFINE_ARITH_CMP(<=, le)
-DEFINE_ARITH_CMP(>=, ge)
-
-static pic_value
-pic_number_zero_p(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_bool_value(f == 0);
-}
-
-static pic_value
-pic_number_positive_p(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_bool_value(f > 0);
-}
-
-static pic_value
-pic_number_negative_p(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_bool_value(f < 0);
-}
-
-static pic_value
-pic_number_odd_p(pic_state *pic)
-{
-  int i;
-
-  pic_get_args(pic, "i", &i);
-
-  return pic_bool_value(i % 2 != 0);
-}
-
-static pic_value
-pic_number_even_p(pic_state *pic)
-{
-  int i;
-
-  pic_get_args(pic, "i", &i);
-
-  return pic_bool_value(i % 2 == 0);
-}
-
-static pic_value
-pic_number_max(pic_state *pic)
-{
-  size_t argc;
-  pic_value *argv;
-  size_t i;
-  double f;
-  bool e = true;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  f = -INFINITY;
-  for (i = 0; i < argc; ++i) {
-    if (pic_int_p(argv[i])) {
-      f = fmax(f, pic_int(argv[i]));
-    }
-    else if (pic_float_p(argv[i])) {
-      e = false;
-      f = fmax(f, pic_float(argv[i]));
-    }
-    else {
-      pic_error(pic, "max: number required");
-    }
-  }
-
-  return e ? pic_int_value(f) : pic_float_value(f);
-}
-
-static pic_value
-pic_number_min(pic_state *pic)
-{
-  size_t argc;
-  pic_value *argv;
-  size_t i;
-  double f;
-  bool e = true;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  f = INFINITY;
-  for (i = 0; i < argc; ++i) {
-    if (pic_int_p(argv[i])) {
-      f = fmin(f, pic_int(argv[i]));
-    }
-    else if (pic_float_p(argv[i])) {
-      e = false;
-      f = fmin(f, pic_float(argv[i]));
-    }
-    else {
-      pic_error(pic, "min: number required");
-    }
-  }
-
-  return e ? pic_int_value(f) : pic_float_value(f);
-}
-
-#define DEFINE_ARITH_OP(op, name, unit)                         \
-  static pic_value                                              \
-  pic_number_##name(pic_state *pic)                             \
-  {                                                             \
-    size_t argc;                                                \
-    pic_value *argv;                                            \
-    size_t i;                                                   \
-    double f;                                                   \
-    bool e = true;                                              \
-                                                                \
-    pic_get_args(pic, "*", &argc, &argv);                       \
-                                                                \
-    f = unit;                                                   \
-    for (i = 0; i < argc; ++i) {                                \
-      if (pic_int_p(argv[i])) {                                 \
-        f op##= pic_int(argv[i]);                               \
-      }                                                         \
-      else if (pic_float_p(argv[i])) {                          \
-        e = false;                                              \
-        f op##= pic_float(argv[i]);                             \
-      }                                                         \
-      else {                                                    \
-        pic_error(pic, #op ": number required");                \
-      }                                                         \
-    }                                                           \
-                                                                \
-    return e ? pic_int_value((int)f) : pic_float_value(f);      \
-  }
-
-DEFINE_ARITH_OP(+, add, 0)
-DEFINE_ARITH_OP(*, mul, 1)
-
-#define DEFINE_ARITH_INV_OP(op, name, unit, exact)                      \
-  static pic_value                                                      \
-  pic_number_##name(pic_state *pic)                                     \
-  {                                                                     \
-   size_t argc;                                                         \
-   pic_value *argv;                                                     \
-   size_t i;                                                            \
-   double f;                                                            \
-   bool e;                                                              \
-                                                                        \
-   pic_get_args(pic, "F*", &f, &e, &argc, &argv);                       \
-                                                                        \
-   e = e && exact;                                                      \
-                                                                        \
-   if (argc == 0) {                                                     \
-     f = unit op f;                                                     \
-   }                                                                    \
-   for (i = 0; i < argc; ++i) {                                         \
-     if (pic_int_p(argv[i])) {                                          \
-       f op##= pic_int(argv[i]);                                        \
-     }                                                                  \
-     else if (pic_float_p(argv[i])) {                                   \
-       e = false;                                                       \
-       f op##= pic_float(argv[i]);                                      \
-     }                                                                  \
-     else {                                                             \
-       pic_error(pic, #op ": number required");                         \
-     }                                                                  \
-   }                                                                    \
-                                                                        \
-   return e ? pic_int_value((int)f) : pic_float_value(f);               \
-  }
-
-DEFINE_ARITH_INV_OP(-, sub, 0, true)
-DEFINE_ARITH_INV_OP(/, div, 1, false)
-
-static pic_value
-pic_number_abs(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value(fabs(f));
-  }
-  else {
-    return pic_float_value(fabs(f));
-  }
-}
-
-static pic_value
-pic_number_floor_quotient(pic_state *pic)
-{
-  int i,j;
-  bool e1, e2;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  if (e1 && e2) {
-    return pic_int_value((int)floor((double)i/j));
-  }
-  else {
-    return pic_float_value(floor((double)i/j));
-  }
-}
-
-static pic_value
-pic_number_floor_remainder(pic_state *pic)
-{
-  int i,j,q;
-  bool e1, e2;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  q = (int)floor((double)i/j);
-  if (e1 && e2) {
-    return pic_int_value(i - j * q);
-  }
-  else {
-    return pic_float_value(i - j * q);
-  }
-}
-
-static pic_value
-pic_number_floor2(pic_state *pic)
-{
-  int i, j;
-  bool e1, e2;
-  double q, r;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  q = floor((double)i/j);
-  r = i - j * q;
-
-  if (e1 && e2) {
-    return pic_values2(pic, pic_int_value(q), pic_int_value(r));
-  }
-  else {
-    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
-  }
-}
-
-static pic_value
-pic_number_trunc_quotient(pic_state *pic)
-{
-  int i,j;
-  bool e1, e2;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  if (e1 && e2) {
-    return pic_int_value((int)trunc((double)i/j));
-  }
-  else {
-    return pic_float_value(trunc((double)i/j));
-  }
-}
-
-static pic_value
-pic_number_trunc_remainder(pic_state *pic)
-{
-  int i,j,q;
-  bool e1, e2;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  q = (int)trunc((double)i/j);
-  if (e1 && e2) {
-    return pic_int_value(i - j * q);
-  }
-  else {
-    return pic_float_value(i - j * q);
-  }
-}
-
-static pic_value
-pic_number_trunc2(pic_state *pic)
-{
-  int i, j;
-  bool e1, e2;
-  double q, r;
-
-  pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
-  q = trunc((double)i/j);
-  r = i - j * q;
-
-  if (e1 && e2) {
-    return pic_values2(pic, pic_int_value(q), pic_int_value(r));
-  }
-  else {
-    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
-  }
-}
-
-static pic_value
-pic_number_gcd(pic_state *pic)
-{
-  size_t argc;
-  pic_value *args;
-  int r;
-  bool e = true;
-
-  pic_get_args(pic, "*", &argc, &args);
-
-  r = 0;
-  while (argc-- > 0) {
-    if (pic_int_p(args[argc])) {
-      r = gcd(r, pic_int(args[argc]));
-    }
-    else if (pic_float_p(args[argc])) {
-      e = false;
-      r = gcd(r, pic_float(args[argc]));
-    }
-    else {
-      pic_error(pic, "gcd: number required");
-    }
-  }
-  return e ? pic_int_value(r) : pic_float_value(r);
-}
-
-static pic_value
-pic_number_lcm(pic_state *pic)
-{
-  size_t argc;
-  pic_value *args;
-  double r;
-  bool e = true;
-
-  pic_get_args(pic, "*", &argc, &args);
-
-  r = 1;
-  while (argc-- > 0) {
-    if (pic_int_p(args[argc])) {
-      r = lcm(r, pic_int(args[argc]));
-    }
-    else if (pic_float_p(args[argc])) {
-      e = false;
-      r = lcm(r, pic_float(args[argc]));
-    }
-    else {
-      pic_error(pic, "lcm: number required");
-    }
-  }
-  return e && pic_valid_int(r) ? pic_int_value(r) : pic_float_value(r);
-}
-
-static pic_value
-pic_number_floor(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(floor(f));
-  }
-}
-
-static pic_value
-pic_number_ceil(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(ceil(f));
-  }
-}
-
-static pic_value
-pic_number_trunc(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(trunc(f));
-  }
-}
-
-static pic_value
-pic_number_round(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    return pic_int_value((int)f);
-  }
-  else {
-    return pic_float_value(round(f));
-  }
-}
-
-static pic_value
-pic_number_exp(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  return pic_float_value(exp(f));
-}
-
-static pic_value
-pic_number_log(pic_state *pic)
-{
-  double f,g;
-  int argc;
-
-  argc = pic_get_args(pic, "f|f", &f, &g);
-  if (argc == 1) {
-    return pic_float_value(log(f));
-  }
-  else {
-    return pic_float_value(log(f) / log(g));
-  }
-}
-
-static pic_value
-pic_number_sin(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = sin(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_cos(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = cos(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_tan(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = tan(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_acos(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = acos(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_asin(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-  f = asin(f);
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_atan(pic_state *pic)
-{
-  double f,g;
-  int argc;
-
-  argc = pic_get_args(pic, "f|f", &f, &g);
-  if (argc == 1) {
-    f = atan(f);
-    return pic_float_value(f);
-  }
-  else {
-    return pic_float_value(atan2(f,g));
-  }
-}
-
-static pic_value
-pic_number_exact_integer_sqrt(pic_state *pic)
-{
-  int k, n, m;
-
-  pic_get_args(pic, "i", &k);
-
-  n = sqrt(k);
-  m = k - n * n;
-
-  return pic_values2(pic, pic_int_value(n), pic_int_value(m));
-}
-
-static pic_value
-pic_number_square(pic_state *pic)
-{
-  double f;
-  bool e;
-
-  pic_get_args(pic, "F", &f, &e);
-
-  if (e) {
-    long long i = (long long)f;
-
-    if (i * i <= INT_MAX) {
-      return pic_int_value(i * i);
-    }
-  }
-  return pic_float_value(f * f);
-}
-
-static pic_value
-pic_number_sqrt(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_float_value(sqrt(f));
-}
-
-static pic_value
-pic_number_expt(pic_state *pic)
-{
-  double f, g, h;
-  bool e1, e2;
-
-  pic_get_args(pic, "FF", &f, &e1, &g, &e2);
-
-  h = pow(f, g);
-  if (e1 && e2) {
-    if (h <= INT_MAX) {
-      return pic_int_value((int)h);
-    }
-  }
-  return pic_float_value(h);
-}
-
-static pic_value
-pic_number_inexact(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_float_value(f);
-}
-
-static pic_value
-pic_number_exact(pic_state *pic)
-{
-  double f;
-
-  pic_get_args(pic, "f", &f);
-
-  return pic_int_value((int)round(f));
-}
-
-static pic_value
-pic_number_number_to_string(pic_state *pic)
-{
-  double f;
-  bool e;
-  int radix = 10;
-
-  pic_get_args(pic, "F|i", &f, &e, &radix);
-
-  if (radix < 2 || radix > 36) {
-    pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix);
-  }
-
-  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));
-  }
-  else {
-    char buf[snprintf(NULL, 0, "%a", f) + 1];
-
-    snprintf(buf, sizeof buf, "%a", f);
-
-    return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
-  }
-}
-
-static pic_value
-pic_number_string_to_number(pic_state *pic)
-{
-  const char *str;
-  int radix = 10;
-  long num;
-  char *eptr;
-  double flo;
-
-  pic_get_args(pic, "z|i", &str, &radix);
-
-  num = strtol(str, &eptr, radix);
-  if (*eptr == '\0') {
-    return pic_valid_int(num)
-      ? pic_int_value(num)
-      : pic_float_value(num);
-  }
-
-  flo = strtod(str, &eptr);
-  if (*eptr == '\0') {
-    return pic_float_value(flo);
-  }
-
-  pic_errorf(pic, "invalid string given: %s", str);
-}
-
-void
-pic_init_number(pic_state *pic)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-
-  pic_defun(pic, "number?", pic_number_real_p);
-  pic_defun(pic, "complex?", pic_number_real_p);
-  pic_defun(pic, "real?", pic_number_real_p);
-  pic_defun(pic, "rational?", pic_number_real_p);
-  pic_defun(pic, "integer?", pic_number_integer_p);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "exact?", pic_number_exact_p);
-  pic_defun(pic, "inexact?", pic_number_inexact_p);
-  pic_defun(pic, "exact-integer?", pic_number_exact_p);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "=", pic_number_eq);
-  pic_defun(pic, "<", pic_number_lt);
-  pic_defun(pic, ">", pic_number_gt);
-  pic_defun(pic, "<=", pic_number_le);
-  pic_defun(pic, ">=", pic_number_ge);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "zero?", pic_number_zero_p);
-  pic_defun(pic, "positive?", pic_number_positive_p);
-  pic_defun(pic, "negative?", pic_number_negative_p);
-  pic_defun(pic, "odd?", pic_number_odd_p);
-  pic_defun(pic, "even?", pic_number_even_p);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "min", pic_number_min);
-  pic_defun(pic, "max", pic_number_max);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "+", pic_number_add);
-  pic_defun(pic, "-", pic_number_sub);
-  pic_defun(pic, "*", pic_number_mul);
-  pic_defun(pic, "/", pic_number_div);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "abs", pic_number_abs);
-  pic_defun(pic, "floor-quotient", pic_number_floor_quotient);
-  pic_defun(pic, "floor-remainder", pic_number_floor_remainder);
-  pic_defun(pic, "floor/", pic_number_floor2);
-  pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient);
-  pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
-  pic_defun(pic, "truncate/", pic_number_trunc2);
-  pic_defun(pic, "modulo", pic_number_floor_remainder);
-  pic_defun(pic, "quotient", pic_number_trunc_quotient);
-  pic_defun(pic, "remainder", pic_number_trunc_remainder);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "gcd", pic_number_gcd);
-  pic_defun(pic, "lcm", pic_number_lcm);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "floor", pic_number_floor);
-  pic_defun(pic, "ceiling", pic_number_ceil);
-  pic_defun(pic, "truncate", pic_number_trunc);
-  pic_defun(pic, "round", pic_number_round);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "exact-integer-sqrt", pic_number_exact_integer_sqrt);
-  pic_defun(pic, "square", pic_number_square);
-  pic_defun(pic, "expt", pic_number_expt);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "inexact", pic_number_inexact);
-  pic_defun(pic, "exact", pic_number_exact);
-  pic_gc_arena_restore(pic, ai);
-
-  pic_defun(pic, "number->string", pic_number_number_to_string);
-  pic_defun(pic, "string->number", pic_number_string_to_number);
-  pic_gc_arena_restore(pic, ai);
-
-  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);
-
-    pic_defun(pic, "exp", pic_number_exp);
-    pic_defun(pic, "log", pic_number_log);
-    pic_defun(pic, "sin", pic_number_sin);
-    pic_defun(pic, "cos", pic_number_cos);
-    pic_defun(pic, "tan", pic_number_tan);
-    pic_defun(pic, "acos", pic_number_acos);
-    pic_defun(pic, "asin", pic_number_asin);
-    pic_defun(pic, "atan", pic_number_atan);
-
-    pic_defun(pic, "sqrt", pic_number_sqrt);
-  }
-}

src/pair.c

@@ -1,767 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <stdarg.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-
-pic_value
-pic_cons(pic_state *pic, pic_value car, pic_value cdr)
-{
-  struct pic_pair *pair;
-
-  pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR);
-  pair->car = car;
-  pair->cdr = cdr;
-
-  return pic_obj_value(pair);
-}
-
-pic_value
-pic_car(pic_state *pic, pic_value obj)
-{
-  struct pic_pair *pair;
-
-  if (! pic_pair_p(obj)) {
-    pic_errorf(pic, "pair required, but got ~s", obj);
-  }
-  pair = pic_pair_ptr(obj);
-
-  return pair->car;
-}
-
-pic_value
-pic_cdr(pic_state *pic, pic_value obj)
-{
-  struct pic_pair *pair;
-
-  if (! pic_pair_p(obj)) {
-    pic_errorf(pic, "pair required, but got ~s", obj);
-  }
-  pair = pic_pair_ptr(obj);
-
-  return pair->cdr;
-}
-
-void
-pic_set_car(pic_state *pic, pic_value obj, pic_value val)
-{
-  struct pic_pair *pair;
-
-  if (! pic_pair_p(obj)) {
-    pic_error(pic, "pair required");
-  }
-  pair = pic_pair_ptr(obj);
-
-  pair->car = val;
-}
-
-void
-pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
-{
-  struct pic_pair *pair;
-
-  if (! pic_pair_p(obj)) {
-    pic_error(pic, "pair required");
-  }
-  pair = pic_pair_ptr(obj);
-
-  pair->cdr = val;
-}
-
-bool
-pic_list_p(pic_value obj)
-{
-  pic_value local, rapid;
-  int i;
-
-  /* Floyd's cycle-finding algorithm. */
-
-  local = rapid = obj;
-  while (true) {
-
-    /* advance rapid fast-forward; runs 2x faster than local */
-    for (i = 0; i < 2; ++i) {
-      if (pic_pair_p(rapid)) {
-        rapid = pic_pair_ptr(rapid)->cdr;
-      }
-      else {
-        return pic_nil_p(rapid);
-      }
-    }
-
-    /* advance local */
-    local = pic_pair_ptr(local)->cdr;
-
-    if (pic_eq_p(local, rapid)) {
-      return false;
-    }
-  }
-}
-
-pic_value
-pic_list1(pic_state *pic, pic_value obj1)
-{
-  return pic_cons(pic, obj1, pic_nil_value());
-}
-
-pic_value
-pic_list2(pic_state *pic, pic_value obj1, pic_value obj2)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value val;
-
-  val = pic_cons(pic, obj1, pic_list1(pic, obj2));
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
-  return val;
-}
-
-pic_value
-pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value val;
-
-  val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3));
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
-  return val;
-}
-
-pic_value
-pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value val;
-
-  val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4));
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
-  return val;
-}
-
-pic_value
-pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value val;
-
-  val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5));
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
-  return val;
-}
-
-pic_value
-pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value val;
-
-  val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6));
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
-  return val;
-}
-
-pic_value
-pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value val;
-
-  val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7));
-
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
-  return val;
-}
-
-pic_value
-pic_list_by_array(pic_state *pic, size_t c, pic_value *vs)
-{
-  pic_value v;
-
-  v = pic_nil_value();
-  while (c--) {
-    v = pic_cons(pic, vs[c], v);
-  }
-  return v;
-}
-
-pic_value
-pic_make_list(pic_state *pic, int k, pic_value fill)
-{
-  pic_value list;
-  int i;
-
-  list = pic_nil_value();
-  for (i = 0; i < k; ++i) {
-    list = pic_cons(pic, fill, list);
-  }
-
-  return list;
-}
-
-int
-pic_length(pic_state *pic, pic_value obj)
-{
-  int c = 0;
-
-  if (! pic_list_p(obj)) {
-    pic_errorf(pic, "length: expected list, but got ~s", obj);
-  }
-
-  while (! pic_nil_p(obj)) {
-    obj = pic_cdr(pic, obj);
-    ++c;
-  }
-
-  return c;
-}
-
-pic_value
-pic_reverse(pic_state *pic, pic_value list)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value v, acc;
-
-  acc = pic_nil_value();
-  pic_for_each(v, list) {
-    acc = pic_cons(pic, v, acc);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, acc);
-  }
-  return acc;
-}
-
-pic_value
-pic_append(pic_state *pic, pic_value xs, pic_value ys)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-  pic_value x;
-
-  xs = pic_reverse(pic, xs);
-  pic_for_each (x, xs) {
-    ys = pic_cons(pic, x, ys);
-
-    pic_gc_arena_restore(pic, ai);
-    pic_gc_protect(pic, xs);
-    pic_gc_protect(pic, ys);
-  }
-  return ys;
-}
-
-pic_value
-pic_memq(pic_state *pic, pic_value key, pic_value list)
-{
- enter:
-
-  if (pic_nil_p(list))
-    return pic_false_value();
-
-  if (pic_eq_p(key, pic_car(pic, list)))
-    return list;
-
-  list = pic_cdr(pic, list);
-  goto enter;
-}
-
-pic_value
-pic_memv(pic_state *pic, pic_value key, pic_value list)
-{
- enter:
-
-  if (pic_nil_p(list))
-    return pic_false_value();
-
-  if (pic_eqv_p(key, pic_car(pic, list)))
-    return list;
-
-  list = pic_cdr(pic, list);
-  goto enter;
-}
-
-pic_value
-pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar)
-{
- enter:
-
-  if (pic_nil_p(list))
-    return pic_false_value();
-
-  if (compar == NULL) {
-    if (pic_equal_p(pic, key, pic_car(pic, list)))
-      return list;
-  } else {
-    if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list))))
-      return list;
-  }
-
-  list = pic_cdr(pic, list);
-  goto enter;
-}
-
-pic_value
-pic_assq(pic_state *pic, pic_value key, pic_value assoc)
-{
-  pic_value cell;
-
- enter:
-
-  if (pic_nil_p(assoc))
-    return pic_false_value();
-
-  cell = pic_car(pic, assoc);
-  if (pic_eq_p(key, pic_car(pic, cell)))
-    return cell;
-
-  assoc = pic_cdr(pic, assoc);
-  goto enter;
-}
-
-pic_value
-pic_assv(pic_state *pic, pic_value key, pic_value assoc)
-{
-  pic_value cell;
-
- enter:
-
-  if (pic_nil_p(assoc))
-    return pic_false_value();
-
-  cell = pic_car(pic, assoc);
-  if (pic_eqv_p(key, pic_car(pic, cell)))
-    return cell;
-
-  assoc = pic_cdr(pic, assoc);
-  goto enter;
-}
-
-pic_value
-pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar)
-{
-  pic_value cell;
-
- enter:
-
-  if (pic_nil_p(assoc))
-    return pic_false_value();
-
-  cell = pic_car(pic, assoc);
-  if (compar == NULL) {
-    if (pic_equal_p(pic, key, pic_car(pic, cell)))
-      return cell;
-  } else {
-    if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell))))
-      return cell;
-  }
-
-  assoc = pic_cdr(pic, assoc);
-  goto enter;
-}
-
-pic_value
-pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc)
-{
-  return pic_cons(pic, pic_cons(pic, key, val), assoc);
-}
-
-pic_value
-pic_caar(pic_state *pic, pic_value v)
-{
-  return pic_car(pic, pic_car(pic, v));
-}
-
-pic_value
-pic_cadr(pic_state *pic, pic_value v)
-{
-  return pic_car(pic, pic_cdr(pic, v));
-}
-
-pic_value
-pic_cdar(pic_state *pic, pic_value v)
-{
-  return pic_cdr(pic, pic_car(pic, v));
-}
-
-pic_value
-pic_cddr(pic_state *pic, pic_value v)
-{
-  return pic_cdr(pic, pic_cdr(pic, v));
-}
-
-pic_value
-pic_list_tail(pic_state *pic, pic_value list, int i)
-{
-  while (i-- > 0) {
-    list = pic_cdr(pic, list);
-  }
-  return list;
-}
-
-pic_value
-pic_list_ref(pic_state *pic, pic_value list, int i)
-{
-  return pic_car(pic, pic_list_tail(pic, list, i));
-}
-
-void
-pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj)
-{
-  pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj;
-}
-
-pic_value
-pic_list_copy(pic_state *pic, pic_value obj)
-{
-  if (pic_pair_p(obj)) {
-    return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj)));
-  }
-  else {
-    return obj;
-  }
-}
-
-static pic_value
-pic_pair_pair_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_pair_p(v));
-}
-
-static pic_value
-pic_pair_cons(pic_state *pic)
-{
-  pic_value v,w;
-
-  pic_get_args(pic, "oo", &v, &w);
-
-  return pic_cons(pic, v, w);
-}
-
-static pic_value
-pic_pair_car(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_car(pic, v);
-}
-
-static pic_value
-pic_pair_cdr(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_cdr(pic, v);
-}
-
-static pic_value
-pic_pair_caar(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_caar(pic, v);
-}
-
-static pic_value
-pic_pair_cadr(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_cadr(pic, v);
-}
-
-static pic_value
-pic_pair_cdar(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_cdar(pic, v);
-}
-
-static pic_value
-pic_pair_cddr(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_cddr(pic, v);
-}
-
-static pic_value
-pic_pair_set_car(pic_state *pic)
-{
-  pic_value v,w;
-
-  pic_get_args(pic, "oo", &v, &w);
-
-  if (! pic_pair_p(v))
-    pic_error(pic, "pair expected");
-
-  pic_pair_ptr(v)->car = w;
-  return pic_none_value();
-}
-
-static pic_value
-pic_pair_set_cdr(pic_state *pic)
-{
-  pic_value v,w;
-
-  pic_get_args(pic, "oo", &v, &w);
-
-  if (! pic_pair_p(v))
-    pic_error(pic, "pair expected");
-
-  pic_pair_ptr(v)->cdr = w;
-  return pic_none_value();
-}
-
-static pic_value
-pic_pair_null_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_nil_p(v));
-}
-
-static pic_value
-pic_pair_list_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_list_p(v));
-}
-
-static pic_value
-pic_pair_make_list(pic_state *pic)
-{
-  int i;
-  pic_value fill = pic_none_value();
-
-  pic_get_args(pic, "i|o", &i, &fill);
-
-  return pic_make_list(pic, i, fill);
-}
-
-static pic_value
-pic_pair_list(pic_state *pic)
-{
-  size_t argc;
-  pic_value *argv;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  return pic_list_by_array(pic, argc, argv);
-}
-
-static pic_value
-pic_pair_length(pic_state *pic)
-{
-  pic_value list;
-
-  pic_get_args(pic, "o", &list);
-
-  return pic_int_value(pic_length(pic, list));
-}
-
-static pic_value
-pic_pair_append(pic_state *pic)
-{
-  size_t argc;
-  pic_value *args, list;
-
-  pic_get_args(pic, "*", &argc, &args);
-
-  if (argc == 0) {
-    return pic_nil_value();
-  }
-
-  list = args[--argc];
-
-  while (argc-- > 0) {
-    list = pic_append(pic, args[argc], list);
-  }
-  return list;
-}
-
-static pic_value
-pic_pair_reverse(pic_state *pic)
-{
-  pic_value list;
-
-  pic_get_args(pic, "o", &list);
-
-  return pic_reverse(pic, list);
-}
-
-static pic_value
-pic_pair_list_tail(pic_state *pic)
-{
-  pic_value list;
-  int i;
-
-  pic_get_args(pic, "oi", &list, &i);
-
-  return pic_list_tail(pic, list, i);
-}
-
-static pic_value
-pic_pair_list_ref(pic_state *pic)
-{
-  pic_value list;
-  int i;
-
-  pic_get_args(pic, "oi", &list, &i);
-
-  return pic_list_ref(pic, list, i);
-}
-
-static pic_value
-pic_pair_list_set(pic_state *pic)
-{
-  pic_value list, obj;
-  int i;
-
-  pic_get_args(pic, "oio", &list, &i, &obj);
-
-  pic_list_set(pic, list, i, obj);
-
-  return pic_none_value();
-}
-
-static pic_value
-pic_pair_list_copy(pic_state *pic)
-{
-  pic_value obj;
-
-  pic_get_args(pic, "o", &obj);
-
-  return pic_list_copy(pic, obj);
-}
-
-static pic_value
-pic_pair_memq(pic_state *pic)
-{
-  pic_value key, list;
-
-  pic_get_args(pic, "oo", &key, &list);
-
-  return pic_memq(pic, key, list);
-}
-
-static pic_value
-pic_pair_memv(pic_state *pic)
-{
-  pic_value key, list;
-
-  pic_get_args(pic, "oo", &key, &list);
-
-  return pic_memv(pic, key, list);
-}
-
-static pic_value
-pic_pair_member(pic_state *pic)
-{
-  struct pic_proc *proc = NULL;
-  pic_value key, list;
-
-  pic_get_args(pic, "oo|l", &key, &list, &proc);
-
-  return pic_member(pic, key, list, proc);
-}
-
-static pic_value
-pic_pair_assq(pic_state *pic)
-{
-  pic_value key, list;
-
-  pic_get_args(pic, "oo", &key, &list);
-
-  return pic_assq(pic, key, list);
-}
-
-static pic_value
-pic_pair_assv(pic_state *pic)
-{
-  pic_value key, list;
-
-  pic_get_args(pic, "oo", &key, &list);
-
-  return pic_assv(pic, key, list);
-}
-
-static pic_value
-pic_pair_assoc(pic_state *pic)
-{
-  struct pic_proc *proc = NULL;
-  pic_value key, list;
-
-  pic_get_args(pic, "oo|l", &key, &list, &proc);
-
-  return pic_assoc(pic, key, list, proc);
-}
-
-void
-pic_init_pair(pic_state *pic)
-{
-  pic_deflibrary (pic, "(picrin base list)") {
-    pic_defun(pic, "pair?", pic_pair_pair_p);
-    pic_defun(pic, "cons", pic_pair_cons);
-    pic_defun(pic, "car", pic_pair_car);
-    pic_defun(pic, "cdr", pic_pair_cdr);
-    pic_defun(pic, "set-car!", pic_pair_set_car);
-    pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
-    pic_defun(pic, "null?", pic_pair_null_p);
-  }
-
-  pic_deflibrary (pic, "(picrin list)") {
-    pic_defun(pic, "caar", pic_pair_caar);
-    pic_defun(pic, "cadr", pic_pair_cadr);
-    pic_defun(pic, "cdar", pic_pair_cdar);
-    pic_defun(pic, "cddr", pic_pair_cddr);
-    pic_defun(pic, "list?", pic_pair_list_p);
-    pic_defun(pic, "make-list", pic_pair_make_list);
-    pic_defun(pic, "list", pic_pair_list);
-    pic_defun(pic, "length", pic_pair_length);
-    pic_defun(pic, "append", pic_pair_append);
-    pic_defun(pic, "reverse", pic_pair_reverse);
-    pic_defun(pic, "list-tail", pic_pair_list_tail);
-    pic_defun(pic, "list-ref", pic_pair_list_ref);
-    pic_defun(pic, "list-set!", pic_pair_list_set);
-    pic_defun(pic, "list-copy", pic_pair_list_copy);
-    pic_defun(pic, "memq", pic_pair_memq);
-    pic_defun(pic, "memv", pic_pair_memv);
-    pic_defun(pic, "member", pic_pair_member);
-    pic_defun(pic, "assq", pic_pair_assq);
-    pic_defun(pic, "assv", pic_pair_assv);
-    pic_defun(pic, "assoc", pic_pair_assoc);
-  }
-}

src/port.c

@@ -1,749 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <stdlib.h>
-#include <string.h>
-#include <limits.h>
-
-#include "picrin.h"
-#include "picrin/proc.h"
-#include "picrin/port.h"
-#include "picrin/string.h"
-#include "picrin/blob.h"
-#include "picrin/var.h"
-
-pic_value
-pic_eof_object()
-{
-  pic_value v;
-
-  pic_init_value(v, PIC_VTYPE_EOF);
-
-  return v;
-}
-
-struct pic_port *
-pic_stdin(pic_state *pic)
-{
-  struct pic_proc *proc;
-
-  proc = pic_proc_ptr(pic_ref(pic, "current-input-port"));
-
-  return pic_port_ptr(pic_apply(pic, proc, pic_nil_value()));
-}
-
-struct pic_port *
-pic_stdout(pic_state *pic)
-{
-  struct pic_proc *proc;
-
-  proc = pic_proc_ptr(pic_ref(pic, "current-output-port"));
-
-  return pic_port_ptr(pic_apply(pic, proc, pic_nil_value()));
-}
-
-static struct pic_port *
-port_new_stdport(pic_state *pic, xFILE *file, short dir)
-{
-  struct pic_port *port;
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
-  port->file = file;
-  port->flags = dir | PIC_PORT_TEXT;
-  port->status = PIC_PORT_OPEN;
-  return port;
-}
-
-struct pic_port *
-pic_open_input_string(pic_state *pic, const char *str)
-{
-  struct pic_port *port;
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
-  port->file = xmopen();
-  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
-  port->status = PIC_PORT_OPEN;
-
-  xfputs(str, port->file);
-  xfflush(port->file);
-  xrewind(port->file);
-
-  return port;
-}
-
-struct pic_port *
-pic_open_output_string(pic_state *pic)
-{
-  struct pic_port *port;
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
-  port->file = xmopen();
-  port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
-  port->status = PIC_PORT_OPEN;
-
-  return port;
-}
-
-struct pic_string *
-pic_get_output_string(pic_state *pic, struct pic_port *port)
-{
-  long size;
-  char *buf;
-
-  /* get endpos */
-  xfflush(port->file);
-  size = xftell(port->file);
-  xrewind(port->file);
-
-  /* copy to buf */
-  buf = (char *)pic_alloc(pic, size + 1);
-  buf[size] = 0;
-  xfread(buf, size, 1, port->file);
-
-  return pic_str_new(pic, buf, size);
-}
-
-void
-pic_close_port(pic_state *pic, struct pic_port *port)
-{
-  if (xfclose(port->file) == EOF) {
-    pic_error(pic, "close-port: failure");
-  }
-  port->status = PIC_PORT_CLOSE;
-}
-
-static pic_value
-pic_port_input_port_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) {
-    return pic_true_value();
-  }
-  else {
-    return pic_false_value();
-  }
-}
-
-static pic_value
-pic_port_output_port_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) {
-    return pic_true_value();
-  }
-  else {
-    return pic_false_value();
-  }
-}
-
-static pic_value
-pic_port_textual_port_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) {
-    return pic_true_value();
-  }
-  else {
-    return pic_false_value();
-  }
-}
-
-static pic_value
-pic_port_binary_port_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) {
-    return pic_true_value();
-  }
-  else {
-    return pic_false_value();
-  }
-}
-
-static pic_value
-pic_port_port_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  return pic_bool_value(pic_port_p(v));
-}
-
-static pic_value
-pic_port_input_port_open_p(pic_state *pic)
-{
-  pic_value v;
-  struct pic_port *port;
-
-  pic_get_args(pic, "o", &v);
-
-  if (! pic_port_p(v))
-    return pic_false_value();
-  port = pic_port_ptr(v);
-  if ((port->flags & PIC_PORT_IN) == 0)
-    return pic_false_value();
-
-  return pic_bool_value(port->status == PIC_PORT_OPEN);
-}
-
-static pic_value
-pic_port_output_port_open_p(pic_state *pic)
-{
-  pic_value v;
-  struct pic_port *port;
-
-  pic_get_args(pic, "o", &v);
-
-  if (! pic_port_p(v))
-    return pic_false_value();
-  port = pic_port_ptr(v);
-  if ((port->flags & PIC_PORT_OUT) == 0)
-    return pic_false_value();
-
-  return pic_bool_value(port->status == PIC_PORT_OPEN);
-}
-
-static pic_value
-pic_port_eof_object_p(pic_state *pic)
-{
-  pic_value v;
-
-  pic_get_args(pic, "o", &v);
-
-  if (pic_vtype(v) == PIC_VTYPE_EOF) {
-    return pic_true_value();
-  }
-  else {
-    return pic_false_value();
-  }
-}
-
-static pic_value
-pic_port_eof_object(pic_state *pic)
-{
-  pic_get_args(pic, "");
-
-  return pic_eof_object();
-}
-
-static pic_value
-pic_port_close_port(pic_state *pic)
-{
-  struct pic_port *port;
-
-  pic_get_args(pic, "p", &port);
-
-  pic_close_port(pic, port);
-
-  return pic_none_value();
-}
-
-#define assert_port_profile(port, flgs, stat, caller) do {              \
-    if ((port->flags & (flgs)) != (flgs)) {                             \
-      switch (flgs) {                                                   \
-      case PIC_PORT_IN:                                                 \
-        pic_error(pic, caller ": expected output port");                \
-      case PIC_PORT_OUT:                                                \
-        pic_error(pic, caller ": expected input port");                 \
-      case PIC_PORT_IN | PIC_PORT_TEXT:                                 \
-        pic_error(pic, caller ": expected input/textual port");         \
-      case PIC_PORT_IN | PIC_PORT_BINARY:                               \
-        pic_error(pic, caller ": expected input/binary port");          \
-      case PIC_PORT_OUT | PIC_PORT_TEXT:                                \
-        pic_error(pic, caller ": expected output/textual port");        \
-      case PIC_PORT_OUT | PIC_PORT_BINARY:                              \
-        pic_error(pic, caller ": expected output/binary port");         \
-      }                                                                 \
-    }                                                                   \
-    if (port->status != stat) {                                         \
-      switch (stat) {                                                   \
-      case PIC_PORT_OPEN:                                               \
-        pic_error(pic, caller ": expected open port");                  \
-      case PIC_PORT_CLOSE:                                              \
-        pic_error(pic, caller ": expected close port");                 \
-      }                                                                 \
-    }                                                                   \
-  } while (0)
-
-static pic_value
-pic_port_open_input_string(pic_state *pic)
-{
-  struct pic_port *port;
-  char *str;
-
-  pic_get_args(pic, "z", &str);
-
-  port = pic_open_input_string(pic, str);
-
-  return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_open_output_string(pic_state *pic)
-{
-  struct pic_port *port;
-
-  pic_get_args(pic, "");
-
-  port = pic_open_output_string(pic);
-
-  return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_get_output_string(pic_state *pic)
-{
-  struct pic_port *port = pic_stdout(pic);
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string");
-
-  return pic_obj_value(pic_get_output_string(pic, port));
-}
-
-static pic_value
-pic_port_open_input_blob(pic_state *pic)
-{
-  struct pic_port *port;
-  struct pic_blob *blob;
-
-  pic_get_args(pic, "b", &blob);
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
-  port->file = xmopen();
-  port->flags = PIC_PORT_IN | PIC_PORT_BINARY;
-  port->status = PIC_PORT_OPEN;
-
-  xfwrite(blob->data, 1, blob->len, port->file);
-  xfflush(port->file);
-  xrewind(port->file);
-
-  return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_open_output_bytevector(pic_state *pic)
-{
-  struct pic_port *port;
-
-  pic_get_args(pic, "");
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
-  port->file = xmopen();
-  port->flags = PIC_PORT_OUT | PIC_PORT_BINARY;
-  port->status = PIC_PORT_OPEN;
-
-  return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_get_output_bytevector(pic_state *pic)
-{
-  struct pic_port *port = pic_stdout(pic);
-  pic_blob *blob;
-  long endpos;
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector");
-
-  /* get endpos */
-  xfflush(port->file);
-  endpos = xftell(port->file);
-  xrewind(port->file);
-
-  /* copy to buf */
-  blob = pic_blob_new(pic, endpos);
-  xfread(blob->data, 1, endpos, port->file);
-
-  return pic_obj_value(blob);
-}
-
-static pic_value
-pic_port_read_char(pic_state *pic)
-{
-  int c;
-  struct pic_port *port = pic_stdin(pic);
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char");
-
-  if ((c = xfgetc(port->file)) == EOF) {
-    return pic_eof_object();
-  }
-  else {
-    return pic_char_value((char)c);
-  }
-}
-
-static pic_value
-pic_port_peek_char(pic_state *pic)
-{
-  int c;
-  struct pic_port *port = pic_stdin(pic);
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char");
-
-  if ((c = xfgetc(port->file)) == EOF) {
-    return pic_eof_object();
-  }
-  else {
-    xungetc(c, port->file);
-    return pic_char_value((char)c);
-  }
-}
-
-static pic_value
-pic_port_read_line(pic_state *pic)
-{
-  int c;
-  struct pic_port *port = pic_stdin(pic), *buf;
-  struct pic_string *str;
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line");
-
-  buf = pic_open_output_string(pic);
-  while ((c = xfgetc(port->file)) != EOF && c != '\n') {
-    xfputc(c, buf->file);
-  }
-
-  str = pic_get_output_string(pic, buf);
-  if (pic_strlen(str) == 0 && c == EOF) {
-    return pic_eof_object();
-  }
-  else {
-    return pic_obj_value(str);
-  }
-}
-
-static pic_value
-pic_port_char_ready_p(pic_state *pic)
-{
-  struct pic_port *port = pic_stdin(pic);
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?");
-
-  pic_get_args(pic, "|p", &port);
-
-  return pic_true_value();      /* FIXME: always returns #t */
-}
-
-static pic_value
-pic_port_read_string(pic_state *pic){
-  struct pic_port *port = pic_stdin(pic), *buf;
-  pic_str *str;
-  int k, i;
-  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) {
-    if((c = xfgetc(port->file)) == EOF){
-      break;
-    }
-    xfputc(c, buf->file);
-  }
-
-  str = pic_get_output_string(pic, buf);
-  if (pic_strlen(str) == 0 && c == EOF) {
-    return pic_eof_object();
-  }
-  else {
-    return pic_obj_value(str);
-  }
-
-}
-
-static pic_value
-pic_port_read_byte(pic_state *pic){
-  struct pic_port *port = pic_stdin(pic);
-  int c;
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8");
-  if ((c = xfgetc(port->file)) == EOF) {
-    return pic_eof_object();
-  }
-
-  return pic_int_value(c);
-}
-
-static pic_value
-pic_port_peek_byte(pic_state *pic)
-{
-  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");
-
-  c = xfgetc(port->file);
-  if (c == EOF) {
-    return pic_eof_object();
-  }
-  else {
-    xungetc(c, port->file);
-    return pic_int_value(c);
-  }
-}
-
-static pic_value
-pic_port_byte_ready_p(pic_state *pic)
-{
-  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, "u8-ready?");
-
-  return pic_true_value();      /* FIXME: always returns #t */
-}
-
-
-static pic_value
-pic_port_read_blob(pic_state *pic)
-{
-  struct pic_port *port = pic_stdin(pic);
-  pic_blob *blob;
-  int k, i;
-
-  pic_get_args(pic, "i|p", &k,  &port);
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector");
-
-  blob = pic_blob_new(pic, k);
-
-  i = xfread(blob->data, sizeof(char), k, port->file);
-  if ( i == 0 ) {
-    return pic_eof_object();
-  }
-  else {
-    pic_realloc(pic, blob->data, i);
-    blob->len = i;
-    return pic_obj_value(blob);
-  }
-}
-
-static pic_value
-pic_port_read_blob_ip(pic_state *pic)
-{
-  struct pic_port *port;
-  struct pic_blob *bv;
-  int i, n, start, end, len;
-  char *buf;
-
-  n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end);
-  switch (n) {
-  case 1:
-    port = pic_stdin(pic);
-  case 2:
-    start = 0;
-  case 3:
-    end = bv->len;
-  }
-
-  assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!");
-  len = end - start;
-
-  buf = pic_calloc(pic, len, sizeof(char));
-  i = xfread(buf, sizeof(char), len, port->file);
-  memcpy(bv->data + start, buf, i);
-  pic_free(pic, buf);
-
-  if ( i == 0) {
-    return pic_eof_object();
-  }
-  else {
-    return pic_int_value(i);
-  }
-}
-
-static pic_value
-pic_port_newline(pic_state *pic)
-{
-  struct pic_port *port = pic_stdout(pic);
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline");
-
-  xfputs("\n", port->file);
-  return pic_none_value();
-}
-
-static pic_value
-pic_port_write_char(pic_state *pic)
-{
-  char c;
-  struct pic_port *port = pic_stdout(pic);
-
-  pic_get_args(pic, "c|p", &c, &port);
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char");
-
-  xfputc(c, port->file);
-  return pic_none_value();
-}
-
-static pic_value
-pic_port_write_string(pic_state *pic)
-{
-  char *str;
-  struct pic_port *port;
-  int start, end, n, i;
-
-  n = pic_get_args(pic, "z|pii", &str, &port, &start, &end);
-  switch (n) {
-  case 1:
-    port = pic_stdout(pic);
-  case 2:
-    start = 0;
-  case 3:
-    end = INT_MAX;
-  }
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string");
-
-  for (i = start; i < end && str[i] != '\0'; ++i) {
-    xfputc(str[i], port->file);
-  }
-  return pic_none_value();
-}
-
-static pic_value
-pic_port_write_byte(pic_state *pic)
-{
-  int i;
-  struct pic_port *port = pic_stdout(pic);
-
-  pic_get_args(pic, "i|p", &i, &port);
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8");
-
-  xfputc(i, port->file);
-  return pic_none_value();
-}
-
-static pic_value
-pic_port_write_blob(pic_state *pic)
-{
-  struct pic_blob *blob;
-  struct pic_port *port;
-  int start, end, n, i;
-
-  n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end);
-  switch (n) {
-  case 1:
-    port = pic_stdout(pic);
-  case 2:
-    start = 0;
-  case 3:
-    end = blob->len;
-  }
-
-  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector");
-
-  for (i = start; i < end; ++i) {
-    xfputc(blob->data[i], port->file);
-  }
-  return pic_none_value();
-}
-
-static pic_value
-pic_port_flush(pic_state *pic)
-{
-  struct pic_port *port = pic_stdout(pic);
-
-  pic_get_args(pic, "|p", &port);
-
-  assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port");
-
-  xfflush(port->file);
-  return pic_none_value();
-}
-
-void
-pic_init_port(pic_state *pic)
-{
-  struct pic_port *STDIN, *STDOUT, *STDERR;
-
-  STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN);
-  STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT);
-  STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT);
-
-  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));
-  }
-
-  pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL)));
-  pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL)));
-  pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL)));
-
-  pic_defun(pic, "input-port?", pic_port_input_port_p);
-  pic_defun(pic, "output-port?", pic_port_output_port_p);
-  pic_defun(pic, "textual-port?", pic_port_textual_port_p);
-  pic_defun(pic, "binary-port?", pic_port_binary_port_p);
-  pic_defun(pic, "port?", pic_port_port_p);
-  pic_defun(pic, "input-port-open?", pic_port_input_port_open_p);
-  pic_defun(pic, "output-port-open?", pic_port_output_port_open_p);
-  pic_defun(pic, "close-port", pic_port_close_port);
-  pic_defun(pic, "close-input-port", pic_port_close_port);
-  pic_defun(pic, "close-output-port", pic_port_close_port);
-
-  /* string I/O */
-  pic_defun(pic, "open-input-string", pic_port_open_input_string);
-  pic_defun(pic, "open-output-string", pic_port_open_output_string);
-  pic_defun(pic, "get-output-string", pic_port_get_output_string);
-  pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob);
-  pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
-  pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
-
-  /* input */
-  pic_defun(pic, "read-char", pic_port_read_char);
-  pic_defun(pic, "peek-char", pic_port_peek_char);
-  pic_defun(pic, "read-line", pic_port_read_line);
-  pic_defun(pic, "eof-object?", pic_port_eof_object_p);
-  pic_defun(pic, "eof-object", pic_port_eof_object);
-  pic_defun(pic, "char-ready?", pic_port_char_ready_p);
-  pic_defun(pic, "read-string", pic_port_read_string);
-  pic_defun(pic, "read-u8", pic_port_read_byte);
-  pic_defun(pic, "peek-u8", pic_port_peek_byte);
-  pic_defun(pic, "u8-ready?", pic_port_byte_ready_p);
-  pic_defun(pic, "read-bytevector", pic_port_read_blob);
-  pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip);
-
-  /* output */
-  pic_defun(pic, "newline", pic_port_newline);
-  pic_defun(pic, "write-char", pic_port_write_char);
-  pic_defun(pic, "write-string", pic_port_write_string);
-  pic_defun(pic, "write-u8", pic_port_write_byte);
-  pic_defun(pic, "write-bytevector", pic_port_write_blob);
-  pic_defun(pic, "flush-output-port", pic_port_flush);
-}