Merge branch 'master' of https://github.com/wasabiz/picrin

.gitignore

@@ -1,7 +1,6 @@
 build/*
-src/lex.yy.c
-src/lex.yy.h
 src/load_piclib.c
+src/init_contrib.c
 .dir-locals.el
 GPATH
 GRTAGS

.travis.yml

@@ -7,4 +7,4 @@ before_script:
 script:
   - perl --version
   - cmake .. && make test
-  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test
+  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test > /dev/null

CMakeLists.txt

@@ -40,16 +40,13 @@ include(tools/CMakeLists.txt)
 add_custom_target(run bin/picrin DEPENDS repl)
 
 # $ make test
-add_custom_target(test DEPENDS no-act test-r7rs)
-
-# $ make no-act
-add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl)
+add_custom_target(test DEPENDS test-r7rs)
 
 # $ make test-r7rs
 add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl)
 
 # $ make tak
-add_custom_target(tak bin/picrin etc/tak.scm DEPENDS repl)
+add_custom_target(tak bin/picrin ${PROJECT_SOURCE_DIR}/etc/tak.scm DEPENDS repl)
 
 # $ make lines
 add_custom_target(lines find . -name "*.[chyl]" | xargs wc -l WORKING_DIRECTORY ${PROJECT_SOURCE_DIR})

contrib/10.partcont/CMakeLists.txt

@@ -0,0 +1,2 @@
+file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/10.partcont/piclib/*.scm)
+list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES})

contrib/10.pretty-print/CMakeLists.txt

@@ -0,0 +1 @@
+list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/10.pretty-print/pretty-print.scm)

contrib/10.pretty-print/pretty-print.scm

@@ -0,0 +1,312 @@
+(define-library (picrin pretty-print)
+  (import (scheme base)
+          (scheme write))
+
+  ; (reverse-string-append l) = (apply string-append (reverse l))
+
+  (define (reverse-string-append l)
+
+    (define (rev-string-append l i)
+      (if (pair? l)
+          (let* ((str (car l))
+                 (len (string-length str))
+                 (result (rev-string-append (cdr l) (+ i len))))
+            (let loop ((j 0) (k (- (- (string-length result) i) len)))
+              (if (< j len)
+                  (begin
+                    (string-set! result k (string-ref str j))
+                    (loop (+ j 1) (+ k 1)))
+                  result)))
+          (make-string i)))
+
+    (rev-string-append l 0))
+
+  ;; We define a pretty printer for Scheme S-expressions (sexp). While
+  ;; Petite Scheme supports that by its own, mzscheme does not. If you
+  ;; get a sexp (like from proof-to-expr) prefix it with a call to spp and
+  ;; the output is nicely formated to fit into pp-width many columns:
+  ;;
+  ;;  (spp (proof-to-expr (current-proof)))
+  ;;
+
+  (define pp-width 80)
+
+  ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
+  ;; Copyright (c) 1991, Marc Feeley
+  ;; Author: Marc Feeley (feeley@iro.umontreal.ca)
+  ;; Distribution restrictions: none
+  ;;
+  ;; Modified for Minlog by Stefan Schimanski <schimans@math.lmu.de>
+  ;; Taken from slib 2d6, genwrite.scm and pp.scm
+
+  (define genwrite:newline-str (make-string 1 #\newline))
+
+  (define (generic-write obj display? width output)
+
+    (define (read-macro? l)
+      (define (length1? l) (and (pair? l) (null? (cdr l))))
+      (let ((head (car l)) (tail (cdr l)))
+        (case head
+          ((quote quasiquote unquote unquote-splicing) (length1? tail))
+          (else                                        #f))))
+
+    (define (read-macro-body l)
+      (cadr l))
+
+    (define (read-macro-prefix l)
+      (let ((head (car l)) (tail (cdr l)))
+        (case head
+          ((quote)            "'")
+          ((quasiquote)       "`")
+          ((unquote)          ",")
+          ((unquote-splicing) ",@"))))
+
+    (define (out str col)
+      (and col (output str) (+ col (string-length str))))
+
+    (define (wr obj col)
+
+      (define (wr-lst l col)
+        (if (pair? l)
+            (let loop ((l (cdr l))
+                       (col (and col (wr (car l) (out "(" col)))))
+              (cond ((not col) col)
+                    ((pair? l)
+                     (loop (cdr l) (wr (car l) (out " " col))))
+                    ((null? l) (out ")" col))
+                    (else      (out ")" (wr l (out " . " col))))))
+            (out "()" col)))
+
+      (define (wr-expr expr col)
+        (if (read-macro? expr)
+            (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
+            (wr-lst expr col)))
+
+      (cond ((pair? obj)        (wr-expr obj col))
+            ((null? obj)        (wr-lst obj col))
+            ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
+            ((boolean? obj)     (out (if obj "#t" "#f") col))
+            ((number? obj)      (out (number->string obj) col))
+            ((symbol? obj)      (out (symbol->string obj) col))
+            ((procedure? obj)   (out "#[procedure]" col))
+            ((string? obj)      (if display?
+                                    (out obj col)
+                                    (let loop ((i 0) (j 0) (col (out "\"" col)))
+                                      (if (and col (< j (string-length obj)))
+                                          (let ((c (string-ref obj j)))
+                                            (if (or (char=? c #\\)
+                                                    (char=? c #\"))
+                                                (loop j
+                                                      (+ j 1)
+                                                      (out "\\"
+                                                           (out (substring obj i j)
+                                                                col)))
+                                                (loop i (+ j 1) col)))
+                                          (out "\""
+                                               (out (substring obj i j) col))))))
+            ((char? obj)        (if display?
+                                    (out (make-string 1 obj) col)
+                                    (out (case obj
+                                           ((#\space)   "space")
+                                           ((#\newline) "newline")
+                                           (else        (make-string 1 obj)))
+                                         (out "#\\" col))))
+            ((input-port? obj)  (out "#[input-port]" col))
+            ((output-port? obj) (out "#[output-port]" col))
+            ((eof-object? obj)  (out "#[eof-object]" col))
+            (else               (out "#[unknown]" col))))
+
+    (define (pp obj col)
+
+      (define (spaces n col)
+        (if (> n 0)
+            (if (> n 7)
+                (spaces (- n 8) (out "        " col))
+                (out (substring "        " 0 n) col))
+            col))
+
+      (define (indent to col)
+        (and col
+             (if (< to col)
+                 (and (out genwrite:newline-str col) (spaces to 0))
+                 (spaces (- to col) col))))
+
+      (define pp-list #f)
+      (define pp-expr #f)
+      (define pp-call #f)
+      (define pp-down #f)
+      (define pp-general #f)
+      (define pp-width #f)
+      (define pp-expr-list #f)
+
+      (define indent-general #f)
+      (define max-expr-width #f)
+      (define max-call-head-width #f)
+      (define style #f)
+
+      (define pr
+        (lambda (obj col extra pp-pair)
+          (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+              (let ((result '())
+                    (left (min (+ (- (- width col) extra) 1) max-expr-width)))
+                (generic-write obj display? #f
+                               (lambda (str)
+                                 (set! result (cons str result))
+                                 (set! left (- left (string-length str)))
+                                 (> left 0)))
+                (if (> left 0)        ; all can be printed on one line
+                    (out (reverse-string-append result) col)
+                    (if (pair? obj)
+                        (pp-pair obj col extra)
+                        (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+              (wr obj col))))
+
+      (set! pp-expr
+        (lambda (expr col extra)
+          (if (read-macro? expr)
+              (pr (read-macro-body expr)
+                  (out (read-macro-prefix expr) col)
+                  extra
+                  pp-expr)
+              (let ((head (car expr)))
+                (if (symbol? head)
+                    (let ((proc (style head)))
+                      (if proc
+                          (proc expr col extra)
+                          (if (> (string-length (symbol->string head))
+                                 max-call-head-width)
+                              (pp-general expr col extra #f #f #f pp-expr)
+                              (pp-call expr col extra pp-expr))))
+                    (pp-list expr col extra pp-expr))))))
+
+                                        ; (head item1
+                                        ;       item2
+                                        ;       item3)
+      (set! pp-call
+        (lambda (expr col extra pp-item)
+          (let ((col* (wr (car expr) (out "(" col))))
+            (and col
+                 (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))))
+
+                                        ; (item1
+                                        ;  item2
+                                        ;  item3)
+      (set! pp-list
+        (lambda (l col extra pp-item)
+          (let ((col (out "(" col)))
+            (pp-down l col col extra pp-item))))
+
+      (set! pp-down
+        (lambda (l col1 col2 extra pp-item)
+          (let loop ((l l) (col col1))
+            (and col
+                 (cond ((pair? l)
+                        (let ((rest (cdr l)))
+                          (let ((extra (if (null? rest) (+ extra 1) 0)))
+                            (loop rest
+                                  (pr (car l) (indent col2 col) extra pp-item)))))
+                       ((null? l)
+                        (out ")" col))
+                       (else
+                        (out ")"
+                             (pr l
+                                 (indent col2 (out "." (indent col2 col)))
+                                 (+ extra 1)
+                                 pp-item))))))))
+
+      (set! pp-general
+        (lambda (expr col extra named? pp-1 pp-2 pp-3)
+
+          (define (tail3 rest col1 col2)
+            (pp-down rest col2 col1 extra pp-3))
+
+          (define (tail2 rest col1 col2 col3)
+            (if (and pp-2 (pair? rest))
+                (let* ((val1 (car rest))
+                       (rest (cdr rest))
+                       (extra (if (null? rest) (+ extra 1) 0)))
+                  (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+                (tail3 rest col1 col2)))
+
+          (define (tail1 rest col1 col2 col3)
+            (if (and pp-1 (pair? rest))
+                (let* ((val1 (car rest))
+                       (rest (cdr rest))
+                       (extra (if (null? rest) (+ extra 1) 0)))
+                  (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+                (tail2 rest col1 col2 col3)))
+
+          (let* ((head (car expr))
+                 (rest (cdr expr))
+                 (col* (wr head (out "(" col))))
+            (if (and named? (pair? rest))
+                (let* ((name (car rest))
+                       (rest (cdr rest))
+                       (col** (wr name (out " " col*))))
+                  (tail1 rest (+ col indent-general) col** (+ col** 1)))
+                (tail1 rest (+ col indent-general) col* (+ col* 1))))))
+
+      (set! pp-expr-list
+        (lambda (l col extra)
+          (pp-list l col extra pp-expr)))
+
+      (define (pp-LAMBDA expr col extra)
+        (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+      (define (pp-IF expr col extra)
+        (pp-general expr col extra #f pp-expr #f pp-expr))
+
+      (define (pp-COND expr col extra)
+        (pp-call expr col extra pp-expr-list))
+
+      (define (pp-CASE expr col extra)
+        (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+      (define (pp-AND expr col extra)
+        (pp-call expr col extra pp-expr))
+
+      (define (pp-LET expr col extra)
+        (let* ((rest (cdr expr))
+               (named? (and (pair? rest) (symbol? (car rest)))))
+          (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+      (define (pp-BEGIN expr col extra)
+        (pp-general expr col extra #f #f #f pp-expr))
+
+      (define (pp-DO expr col extra)
+        (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+
+                                        ; define formatting style (change these to suit your style)
+
+      (set! indent-general 2)
+
+      (set! max-call-head-width 5)
+
+      (set! max-expr-width 50)
+
+      (set! style
+        (lambda (head)
+          (case head
+            ((lambda let* letrec define) pp-LAMBDA)
+            ((if set!)                   pp-IF)
+            ((cond)                      pp-COND)
+            ((case)                      pp-CASE)
+            ((and or)                    pp-AND)
+            ((let)                       pp-LET)
+            ((begin)                     pp-BEGIN)
+            ((do)                        pp-DO)
+            (else                        #f))))
+
+      (pr obj col 0 pp-expr))
+
+    (if width
+        (out genwrite:newline-str (pp obj 0))
+        (wr obj 0)))
+
+  (define (pretty-print obj . opt)
+    (let ((port (if (pair? opt) (car opt) (current-output-port))))
+      (generic-write obj #f pp-width
+                     (lambda (s) (display s port) #t))
+      (display "")))
+
+  (export pretty-print))

contrib/10.regexp/CMakeLists.txt

@@ -5,9 +5,9 @@ if (REGEX_FOUND)
   add_definitions(${REGEX_DEFINITIONS})
   include_directories(${REGEX_INCLUDE_DIR})
 
-  file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/regexp/src/*.c)
+  file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.regexp/src/*.c)
 
-  list(APPEND PICRIN_CONTRIB_INITS "void pic_init_regexp(pic_state *)\; pic_init_regexp(pic)\;")
+  list(APPEND PICRIN_CONTRIB_INITS regexp)
   list(APPEND PICRIN_CONTRIB_LIBRARIES ${REGEX_LIBRARIES})
   list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_REGEX_SOURCES})
 endif()

contrib/20.for/CMakeLists.txt

@@ -0,0 +1,2 @@
+file(GLOB FOR_FILES ${PROJECT_SOURCE_DIR}/contrib/20.for/piclib/*.scm)
+list(APPEND PICLIB_CONTRIB_LIBS ${FOR_FILES})

contrib/20.for/piclib/for.scm

@@ -0,0 +1,20 @@
+(define-library (picrin control list)
+  (import (scheme base)
+          (picrin control))
+
+  (define-syntax for
+    (syntax-rules ()
+      ((_ expr)
+       (reset (lambda () expr)))))
+
+  (define (in m)
+    (shift (lambda (k)
+             (apply append (map k m)))))
+
+  (define (yield x)
+    (list x))
+
+  (define (null . x)
+    '())
+
+  (export for in yield null))

contrib/CMakeLists.txt

@@ -1,6 +1,5 @@
 file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt)
+list(SORT CONTRIBS)
 foreach(contrib ${CONTRIBS})
   include(${contrib})
 endforeach()
-
-add_definitions("-DPIC_CONTRIB_INITS=${PICRIN_CONTRIB_INITS}")

contrib/partcont/CMakeLists.txt

@@ -1,2 +0,0 @@
-file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/partcont/piclib/*.scm)
-list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES})

docs/lang.rst

@@ -17,6 +17,8 @@ At the REPL start-up time, some usuful built-in libraries listed below will be a
 - ``(scheme cxr)``
 - ``(scheme lazy)``
 - ``(scheme time)``
+- ``(scheme case-lambda)``
+- ``(scheme read)``
 
 Compliance with R7RS
 ---------------------
@@ -38,7 +40,7 @@ section                                          status     comments
 4.1.4 Procedures                                 yes
 4.1.5 Conditionals                               yes        In picrin ``(if #f #f)`` returns ``#f``
 4.1.6 Assignments                                yes
-4.1.7 Inclusion                                  incomplete ``include-ci``. TODO: Once ``read`` is implemented rewrite ``include`` macro with it.
+4.1.7 Inclusion                                  incomplete ``include-ci``
 4.2.1 Conditionals                               incomplete TODO: ``cond-expand``
 4.2.2 Binding constructs                         yes
 4.2.3 Sequencing                                 yes
@@ -56,12 +58,12 @@ section                                          status     comments
 5.3.1 Top level definitions                      yes
 5.3.2 Internal definitions                       yes        TODO: interreferential definitions
 5.3.3 Multiple-value definitions                 yes
-5.4 Syntax definitions                           yes        TODO: internal macro definition is not supported.
+5.4 Syntax definitions                           yes
 5.5 Recored-type definitions                     yes
 5.6.1 Library Syntax                             incomplete In picrin, libraries can be reopend and can be nested.
 5.6.2 Library example                            N/A
 5.7 The REPL                                     yes
-6.1 Equivalence predicates                       yes        TODO: equal? must terminate if circular structure is given
+6.1 Equivalence predicates                       yes
 6.2.1 Numerical types                            yes        picrin has only two types of internal representation of numbers: fixnum and double float. It still comforms the R7RS spec.
 6.2.2 Exactness                                  yes
 6.2.3 Implementation restrictions                yes

docs/libs.rst

@@ -20,12 +20,24 @@ SRFI libraries
 
 - (srfi 1)
 
-  List manipulation library.
+  List library.
+
+- (srfi 8)
+
+  ``receive`` macro.
 
 - (srfi 26)
 
   Cut/cute macros.
 
+- (srfi 43)
+
+  Vector library.
+
+- (srfi 60)
+
+  Bitwise operations.
+
 - (srfi 95)
 
   Sorting and Marging.
@@ -37,14 +49,21 @@ Utility functions and syntaces for macro definition.
 
 - define-macro
 - gensym
-- macroexpand expr
+- macroexpand
+- macroexpand-1
 
 Old-fashioned macro.
 
-- make-syntactic-closure
 - identifier?
 - identifier=?
 
+- make-syntactic-closure
+- close-syntax
+- capture-syntactic-environment
+
+- sc-macro-transformer
+- rsc-macro-transformer
+
 Syntactic closures.
 
 - er-macro-transformer
@@ -79,6 +98,115 @@ Delimited control operators.
 - **(reset h)**
 - **(shift k)**
 
+(picrin control list)
+---------------------
+
+Monadic list operators.
+
+The triple of for/in/yield enables you to write a list operation in a very easy and simple code. One of the best examples is list composition::
+
+  (for (let ((a (in '(1 2 3)))
+             (b (in '(2 3 4))))
+         (yield (+ a b))))
+
+  ;=> (5 6 7 6 7 8 7 8 9)
+
+All monadic operations are done in *for* macro. In this example, *in* operators choose an element from the given lists, a and b are bound here, then *yielding* the sum of them. Because a and b are values moving around in the list elements, the expression (+ a b) can become every possible result. *yield* operator is a operator that gathers the possibilities into a list, so *for* macro returns a list of 3 * 3 results in total. Since expression inside *for* macro is a normal expression, you can write everything that you can write elsewhere. The code below has perfectly the same effect to above one::
+
+  (for (yield (+ (in '(1 2 3))
+                 (in '(4 5 6)))))
+
+The second best exmaple is filtering. In the next case, we show that you can do something depending on the condition of chosen elements::
+
+  (for (let ((x (in (iota 10))))
+         (if (even? x)
+             (yield x)
+             (null))))
+
+  ;=> (0 2 4 6 8)
+
+This expression is equivalent to ``(filter even? (iota 10))`` but it is more procedual and non-magical.
+
+- **(for expr)**
+
+  [Macro] Executes expr in a list monad context.
+
+- **(in list)**
+
+  Choose a value from list. *in* function must only appear in *for* macro. The delimited continuation from the position of *in* function to the outside *for* macro is executed for each element in list. If list contains no values, that is ``(in '())``, the continuation is discarded.
+
+- **(yield value)**
+
+  Yields value from the monad context. The result of *for* will be a list of yielded values.
+
+- **(null . value)**
+
+  Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class.
+
+
+(picrin array)
+--------------
+
+Resizable random-access list.
+
+Technically, picrin's array is implemented as a ring-buffer, effective double-ended queue data structure (deque) that can operate pushing and poping from both of front and back in constant time. In addition to the deque interface, array provides standard sequence interface similar to functions specified by R7RS.
+
+- **(make-array [capacity])**
+
+  Returns a newly allocated array object. If capacity is given, internal data chunk of the array object will be initialized by capacity size.
+
+- **(array . objs)**
+
+  Returns an array initialized with objs.
+
+- **(array? . obj)**
+
+  Returns #t if obj is an array.
+
+- **(array-length ary)**
+
+  Returns the length of ary.
+
+- **(array-ref ary i)**
+
+  Like ``list-ref``, return the object pointed by the index i.
+
+- **(array-set! ary i obj)**
+
+  Like ``list-set!``, substitutes the object pointed by the index i with given obj.
+
+- **(array-push! ary obj)**
+
+  Adds obj to the end of ary.
+
+- **(array-pop! ary)**
+
+  Removes the last element of ary, and returns it.
+
+- **(array-unshift! ary obj)**
+
+  Adds obj to the front of ary.
+
+- **(array-shift! ary)**
+
+  Removes the first element of ary, and returns it.
+
+- **(array-map proc ary)**
+
+  Performs mapping operation on ary.
+
+- **(array-for-each proc ary)**
+
+  Performs mapping operation on ary, but discards the result.
+
+- **(array->list ary)**
+
+  Converts ary into list.
+
+- **(list->array list)**
+
+  Converts list into array.
+
 
 (picrin dictionary)
 -------------------
@@ -87,9 +215,9 @@ Symbol to Object table. Internally it is implemented on hash-table.
 
 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.
 
-- **(dictionary)**
+- **(dictionary . plist)**
 
-  Returns a newly allocated empty dictionary. In the future, it is planned to extend this function to take optional arguments for initial key/values.
+  Returns a newly allocated empty dictionary. The dictionary is initialized with the content of plist.
 
 - **(dictionary? obj)**
 
@@ -111,6 +239,31 @@ Note that dictionary is not a weak map; if you are going to make a highly memory
 
   Returns the number of registered elements in dict.
 
+- **(dicitonary-map proc dict)**
+
+  Perform mapping action onto dictionary object. ``proc`` is called by a sequence ``(proc key val)``.
+
+- **(dictionary-for-each proc dict)**
+
+  Similar to ``dictionary-map``, but discards the result.
+
+- **(dictionary->plist dict)**
+- **(plist->dictionary plist)**
+- **(dictionary->alist dict)**
+- **(alist->dictionary alist)**
+
+  Conversion between dictionary and alist/plist.
+
+
+(picrin pretty-print)
+---------------------
+
+Pretty-printer.
+
+- **(pretty-print obj)**
+
+  Prints obj with human-readable indention to current-output-port.
+
 
 (picrin user)
 -------------

etc/mkinit.pl

@@ -0,0 +1,32 @@
+#!/usr/bin/perl
+
+use strict;
+
+print <<EOL;
+/**
+ *                                !!NOTICE!!
+ * This file was automatically generated by mkinit.pl, and includes all of
+ * the prelude files required by Picrin. PLEASE DO NOT EDIT THIS FILE, changes
+ * will be overwritten the next time the script runs.
+ */
+
+#include "picrin.h"
+
+void
+pic_init_contrib(pic_state *pic)
+{
+EOL
+
+foreach my $lib (@ARGV) {
+    print "  void pic_init_$lib(pic_state *);\n";
+}
+
+print;
+
+foreach my $lib (@ARGV) {
+    print "  pic_init_$lib(pic);\n";
+}
+
+print <<EOL;
+}
+EOL

extlib/xrope

@@ -1 +1 @@
-Subproject commit 3bc8a992e249ef6aea6d05dedf3e158446e1339b
+Subproject commit 32d99fae069c1ec7bf0fc31345bfc27cae84b47a

include/picrin.h

@@ -80,12 +80,16 @@ typedef struct {
 
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
-  pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
+  pic_sym sDEFINE_SYNTAX;
   pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
   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;
+  pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
+
   xhash syms;                   /* name to symbol */
   xhash sym_names;              /* symbol to name */
   int sym_cnt;
@@ -127,6 +131,13 @@ 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 *);
@@ -135,11 +146,12 @@ 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);
 void pic_defmacro(pic_state *, const char *, struct pic_proc *);
-void pic_defvar(pic_state *, const char *, pic_value);
 
 bool pic_equal_p(pic_state *, pic_value, pic_value);
 

include/picrin/box.h

@@ -1,28 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_BOX_H__
-#define PICRIN_BOX_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-struct pic_box {
-  PIC_OBJECT_HEADER
-  pic_value value;
-};
-
-#define pic_box_p(v) (pic_type(v) == PIC_TT_BOX)
-#define pic_box_ptr(v) ((struct pic_box *)pic_ptr(v))
-
-pic_value pic_box(pic_state *, pic_value);
-pic_value pic_unbox(pic_state *, pic_value);
-void pic_set_box(pic_state *, pic_value, pic_value);
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/dict.h

@@ -17,6 +17,14 @@ struct pic_dict {
 #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

include/picrin/error.h

@@ -32,7 +32,8 @@ struct pic_jmpbuf {
 void pic_push_try(pic_state *);
 void pic_pop_try(pic_state *);
 
-noreturn void pic_throw(pic_state *, struct pic_error *);
+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

include/picrin/lib.h

@@ -12,7 +12,7 @@ extern "C" {
 struct pic_lib {
   PIC_OBJECT_HEADER
   pic_value name;
-  struct pic_senv *senv;
+  struct pic_senv *env;
   xhash exports;
 };
 

include/picrin/macro.h

@@ -11,7 +11,7 @@ extern "C" {
 
 struct pic_senv {
   PIC_OBJECT_HEADER
-  xhash renames;
+  xhash map;
   struct pic_senv *up;
 };
 
@@ -21,15 +21,6 @@ struct pic_macro {
   struct pic_senv *senv;
 };
 
-struct pic_sc {
-  PIC_OBJECT_HEADER
-  pic_value expr;
-  struct pic_senv *senv;
-};
-
-#define pic_sc_p(v) (pic_type(v) == PIC_TT_SC)
-#define pic_sc_ptr(v) ((struct pic_sc *)pic_ptr(v))
-
 #define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
 #define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v))
 
@@ -38,11 +29,16 @@ struct pic_sc {
 
 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);
+void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym);
 
 #if defined(__cplusplus)
 }

include/picrin/pair.h

@@ -21,6 +21,8 @@ struct pic_pair {
 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);
@@ -47,8 +49,13 @@ 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_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);
+
 pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
 
 pic_value pic_caar(pic_state *, pic_value);

include/picrin/proc.h

@@ -31,6 +31,7 @@ struct pic_proc {
     struct pic_irep *irep;
   } u;
   struct pic_env *env;
+  struct pic_dict *attr;
 };
 
 #define PIC_PROC_KIND_FUNC 1
@@ -50,13 +51,9 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en
 
 pic_sym pic_proc_name(struct pic_proc *);
 
-/* closed variables accessor */
-void pic_proc_cv_init(pic_state *, struct pic_proc *, size_t);
-int pic_proc_cv_size(pic_state *, struct pic_proc *);
-pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t);
-void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value);
-
-struct pic_proc *pic_papply(pic_state *, struct pic_proc *, pic_value);
+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)
 }

include/picrin/value.h

@@ -111,12 +111,10 @@ enum pic_tt {
   PIC_TT_CONT,
   PIC_TT_SENV,
   PIC_TT_MACRO,
-  PIC_TT_SC,
   PIC_TT_LIB,
   PIC_TT_VAR,
   PIC_TT_IREP,
   PIC_TT_DATA,
-  PIC_TT_BOX,
   PIC_TT_DICT
 };
 
@@ -256,8 +254,6 @@ pic_type_repr(enum pic_tt tt)
     return "cont";
   case PIC_TT_PROC:
     return "proc";
-  case PIC_TT_SC:
-    return "sc";
   case PIC_TT_SENV:
     return "senv";
   case PIC_TT_MACRO:
@@ -270,8 +266,6 @@ pic_type_repr(enum pic_tt tt)
     return "irep";
   case PIC_TT_DATA:
     return "data";
-  case PIC_TT_BOX:
-    return "box";
   case PIC_TT_DICT:
     return "dict";
   }

include/picrin/var.h

@@ -11,21 +11,18 @@ extern "C" {
 
 struct pic_var {
   PIC_OBJECT_HEADER
-  pic_value value;
-  struct pic_proc *conv;
+  pic_value stack;
 };
 
 #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 *);
+struct pic_var *pic_var_new(pic_state *, pic_value);
 
-struct pic_proc *pic_wrap_var(pic_state *, struct pic_var *);
-struct pic_var *pic_unwrap_var(pic_state *, struct pic_proc *);
-
-pic_value pic_var_ref(pic_state *, struct pic_var *);
-void pic_var_set(pic_state *, struct pic_var *, pic_value);
-void pic_var_set_force(pic_state *, struct pic_var *, pic_value);
+pic_value pic_var_ref(pic_state *, const char *);
+void pic_var_set(pic_state *, const char *, pic_value);
+void pic_var_push(pic_state *, const char *, pic_value);
+void pic_var_pop(pic_state *, const char *);
 
 #if defined(__cplusplus)
 }

piclib/CMakeLists.txt

@@ -1,6 +1,18 @@
 list(APPEND PICLIB_SCHEME_LIBS
-  ${PROJECT_SOURCE_DIR}/piclib/built-in.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm # the only dependency prelude requires
+  ${PROJECT_SOURCE_DIR}/piclib/prelude.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/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/srfi/1.scm
+  ${PROJECT_SOURCE_DIR}/piclib/srfi/8.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
   )

piclib/picrin/array.scm

@@ -0,0 +1,103 @@
+(define-library (picrin array)
+  (import (scheme base))
+
+  (define-record-type array-type
+    (create-array data size head tail)
+    array?
+    (data array-data set-array-data!)
+    (size array-size set-array-size!)
+    (head array-head set-array-head!)
+    (tail array-tail set-array-tail!))
+
+  (define (translate ary i)
+    (floor-remainder i (array-size ary)))
+
+  (define (array-length ary)
+    (let ((size (- (array-tail ary) (array-head ary))))
+     (translate ary size)))
+
+  (define (array-rotate! ary)
+    (when (< (array-tail ary) (array-head ary))
+      (let ((xs (vector-copy (array-data ary) 0 (array-head ary)))
+            (ys (vector-copy (array-data ary) (array-head ary))))
+        (set-array-data! ary (vector-append ys xs))
+        (set-array-tail! ary (array-length ary))
+        (set-array-head! ary 0))))
+
+  (define (array-reserve! ary size)
+    (set! size (+ size 1))              ; capa == size - 1
+    (when (< (array-size ary) size)
+      (array-rotate! ary)
+      (set-array-data! ary (vector-append
+                            (array-data ary)
+                            (make-vector (- size (array-size ary)))))
+      (set-array-size! ary size)))
+
+  (define (make-array . rest)
+    (if (null? rest)
+        (make-array 0)
+        (let ((capacity (car rest))
+              (ary (create-array (vector) 0 0 0)))
+          (array-reserve! ary capacity)
+          ary)))
+
+  (define (array-ref ary i)
+    (let ((data (array-data ary)))
+      (vector-ref data (translate ary (+ (array-head ary) i)))))
+
+  (define (array-set! ary i obj)
+    (let ((data (array-data ary)))
+      (vector-set! data (translate ary (+ (array-head ary) i)) obj)))
+
+  (define (array-push! ary obj)
+    (array-reserve! ary (+ (array-length ary) 1))
+    (array-set! ary (array-length ary) obj)
+    (set-array-tail! ary (translate ary (+ (array-tail ary) 1))))
+
+  (define (array-pop! ary)
+    (set-array-tail! ary (translate ary (- (array-tail ary) 1)))
+    (array-ref ary (array-length ary)))
+
+  (define (array-shift! ary)
+    (set-array-head! ary (translate ary (+ (array-head ary) 1)))
+    (array-ref ary -1))
+
+  (define (array-unshift! ary obj)
+    (array-reserve! ary (+ (array-length ary) 1))
+    (array-set! ary -1 obj)
+    (set-array-head! ary (translate ary (- (array-head ary) 1))))
+
+  (define (array->list ary)
+    (do ((i 0 (+ i 1))
+         (x '() (cons (array-ref ary i) x)))
+        ((= i (array-length ary))
+         (reverse x))))
+
+  (define (list->array list)
+    (let ((ary (make-array)))
+      (for-each (lambda (x) (array-push! ary x)) list)
+      ary))
+
+  (define (array . objs)
+    (list->array objs))
+
+  (define (array-map proc ary)
+    (list->array (map proc (array->list ary))))
+
+  (define (array-for-each proc ary)
+    (for-each proc (array->list ary)))
+
+  (export make-array
+          array
+          array?
+          array-length
+          array-ref
+          array-set!
+          array-push!
+          array-pop!
+          array-shift!
+          array-unshift!
+          array-map
+          array-for-each
+          array->list
+          list->array))

piclib/picrin/dictionary.scm

@@ -0,0 +1,48 @@
+(define-library (picrin dictionary)
+  (import (scheme 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
+          dictionary->plist
+          plist->dictionary
+          dictionary->alist
+          alist->dictionary))

piclib/picrin/macro.scm

@@ -0,0 +1,148 @@
+;;; Hygienic Macros
+
+(define-library (picrin macro)
+  (import (scheme base)
+          (picrin dictionary))
+
+  ;; assumes no derived expressions are provided yet
+
+  (define (list->vector list)
+    (define vector (make-vector (length list)))
+    (define (go list i)
+      (if (null? list)
+          vector
+          (begin
+            (vector-set! vector i (car list))
+            (go (cdr list) (+ i 1)))))
+    (go list 0))
+
+  (define (vector->list vector)
+    (define (go i)
+      (if (= i (vector-length vector))
+          '()
+          (cons (vector-ref vector i)
+                (go (+ i 1)))))
+    (go 0))
+
+  (define (walk proc expr)
+    "walk on symbols"
+    (if (null? expr)
+        '()
+        (if (pair? expr)
+            (cons (walk proc (car expr))
+                  (walk proc (cdr expr)))
+            (if (vector? expr)
+                (list->vector (walk proc (vector->list expr)))
+                (if (symbol? expr)
+                    (proc expr)
+                    expr)))))
+
+  (define (memoize f)
+    "memoize on a symbol"
+    (define cache (make-dictionary))
+    (lambda (sym)
+      (if (dictionary-has? cache sym)
+          (dictionary-ref cache sym)
+          (begin
+            (define val (f sym))
+            (dictionary-set! cache sym val)
+            val))))
+
+  (define (make-syntactic-closure env free form)
+
+    (define resolve
+      (memoize
+       (lambda (sym)
+         (make-identifier sym env))))
+
+    (walk
+     (lambda (sym)
+       (if (memq sym free)
+           sym
+           (resolve sym)))
+     form))
+
+  (define (close-syntax form env)
+    (make-syntactic-closure env '() form))
+
+  (define-syntax capture-syntactic-environment
+    (lambda (form use-env mac-env)
+      (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
+
+  (define (sc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure mac-env '() (f expr use-env))))
+
+  (define (rsc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure use-env '() (f expr mac-env))))
+
+  (define (er-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define rename
+        (memoize
+         (lambda (sym)
+           (make-identifier sym mac-env))))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? use-env x use-env y))))
+
+      (f expr rename compare)))
+
+  (define (ir-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define icache* (make-dictionary))
+
+      (define inject
+        (memoize
+         (lambda (sym)
+           (define id (make-identifier sym use-env))
+           (dictionary-set! icache* id sym)
+           id)))
+
+      (define rename
+        (memoize
+         (lambda (sym)
+           (make-identifier sym mac-env))))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? mac-env x mac-env y))))
+
+      (walk (lambda (sym)
+              (if (dictionary-has? icache* sym)
+                  (dictionary-ref icache* sym)
+                  (rename sym)))
+            (f (walk inject expr) inject compare))))
+
+  (define-syntax define-macro
+    (er-macro-transformer
+     (lambda (expr r c)
+       (define formal (car (cdr expr)))
+       (define body   (cdr (cdr expr)))
+       (if (symbol? formal)
+           (list (r 'define-syntax) formal
+                 (list (r 'lambda) (list (r 'form) '_ '_)
+                       (list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))
+           (list (r 'define-macro) (car formal)
+                 (cons (r 'lambda)
+                       (cons (cdr formal)
+                             body)))))))
+
+  (export make-syntactic-closure
+          close-syntax
+          capture-syntactic-environment
+          sc-macro-transformer
+          rsc-macro-transformer
+          er-macro-transformer
+          ir-macro-transformer
+          define-macro))

piclib/picrin/test.scm

@@ -0,0 +1,103 @@
+(define-library (picrin test)
+  (import (scheme base)
+          (scheme write)
+          (scheme read)
+          (scheme process-context))
+  (define test-counter 0)
+  (define counter 0)
+  (define failure-counter 0)
+
+  (define fails '())
+
+  (define (print-statistics)
+    (newline)
+    (display "Test Result: ")
+    (write (- counter failure-counter))
+    (display " / ")
+    (write counter)
+    (display " (")
+    (write (* (/ (- counter failure-counter) counter) 100))
+    (display "%)")
+    (display " [PASS/TOTAL]")
+    (display "")
+    (newline)
+    (for-each
+     (lambda (fail)
+       (display fail))
+     fails))
+
+  (define (test-begin . o)
+    (set! test-counter (+ test-counter 1)))
+
+  (define (test-end . o)
+    (set! test-counter (- test-counter 1))
+    (if (= test-counter 0)
+        (print-statistics)))
+
+  (define-syntax test
+    (syntax-rules ()
+      ((test expected expr)
+       (let ((res expr))
+         (display "case ")
+         (write counter)
+         (cond
+          ((equal? res expected)
+           (display " PASS: ")
+           (write 'expr)
+           (display " equals ")
+           (write expected)
+           (display "")
+           (newline)
+           )
+          ((not (equal? res expected))
+           (set! failure-counter (+ failure-counter 1))
+           (let ((out (open-output-string)))
+             (display " FAIL: " out)
+             (write 'expr out)
+             (newline out)
+             (display "   expected " out)
+             (write expected out)
+             (display " but got " out)
+             (write res out)
+             (display "" out)
+             (newline out)
+             (let ((str (get-output-string out)))
+               (set! fails (cons str fails))
+               (display str)))))
+         (set! counter (+ counter 1))))))
+
+  (define-syntax test-values
+    (syntax-rules ()
+      ((_ expect expr)
+       (test-values #f expect expr))
+      ((_ name expect expr)
+       (test name (call-with-values (lambda () expect) (lambda results results))
+             (call-with-values (lambda () expr) (lambda results results))))))
+
+
+  (define (test-failure-count)
+    (length fails))
+
+  (define (test-exit)
+    (exit (zero? (test-failure-count))))
+
+  (define-syntax test-syntax-error
+    (syntax-rules ()
+      ((_) (syntax-error "invalid use of test-syntax-error"))))
+
+  (define-syntax test-numeric-syntax
+    (syntax-rules ()
+      ((test-numeric-syntax str expect strs ...)
+       (let* ((z (read (open-input-string str)))
+              (out (open-output-string))
+              (z-str (begin (write z out) (get-output-string out))))
+         (test expect (values z))
+         (test #t (and (member z-str '(str strs ...)) #t))))))
+
+  ;; (define (test-read-error str)
+  ;;   (test-assert
+  ;;       (guard (exn (else #t))
+  ;;         (read (open-input-string str))
+  ;;         #f)))
+  (export test test-begin test-end test-values test-exit test-syntax-error test-numeric-syntax)
+  )

piclib/prelude.scm

@@ -1,68 +1,35 @@
-;;; Appendix A. Standard Libraries CxR
-(define-library (scheme cxr)
-  (import (scheme base))
-
-  (define (caaar p) (car (caar p)))
-  (define (caadr p) (car (cadr p)))
-  (define (cadar p) (car (cdar p)))
-  (define (caddr p) (car (cddr p)))
-  (define (cdaar p) (cdr (caar p)))
-  (define (cdadr p) (cdr (cadr p)))
-  (define (cddar p) (cdr (cdar p)))
-  (define (cdddr p) (cdr (cddr p)))
-  (define (caaaar p) (caar (caar p)))
-  (define (caaadr p) (caar (cadr p)))
-  (define (caadar p) (caar (cdar p)))
-  (define (caaddr p) (caar (cddr p)))
-  (define (cadaar p) (cadr (caar p)))
-  (define (cadadr p) (cadr (cadr p)))
-  (define (caddar p) (cadr (cdar p)))
-  (define (cadddr p) (cadr (cddr p)))
-  (define (cdaaar p) (cdar (caar p)))
-  (define (cdaadr p) (cdar (cadr p)))
-  (define (cdadar p) (cdar (cdar p)))
-  (define (cdaddr p) (cdar (cddr p)))
-  (define (cddaar p) (cddr (caar p)))
-  (define (cddadr p) (cddr (cadr p)))
-  (define (cdddar p) (cddr (cdar p)))
-  (define (cddddr p) (cddr (cddr p)))
-
-  (export caaar caadr cadar caddr
-          cdaar cdadr cddar cdddr
-          caaaar caaadr caadar caaddr
-          cadaar cadadr caddar cadddr
-          cdaaar cdaadr cdadar cdaddr
-          cddaar cddadr cdddar cddddr))
-
-;;; hygienic macros
-(define-library (picrin macro)
-  (import (scheme base))
-
-  (define (sc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure mac-env '() (f expr use-env))))
-
-  (define (rsc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure use-env '() (f expr mac-env))))
-
-  (export sc-macro-transformer
-          rsc-macro-transformer))
-
 ;;; core syntaces
 (define-library (picrin core-syntax)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro))
 
+  (define-syntax syntax-error
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (apply error (cdr expr)))))
+
+  (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 else)
+  (define-auxiliary-syntax =>)
+  (define-auxiliary-syntax _)
+  (define-auxiliary-syntax ...)
+  (define-auxiliary-syntax unquote)
+  (define-auxiliary-syntax unquote-splicing)
+
   (define-syntax let
     (er-macro-transformer
      (lambda (expr r compare)
        (if (symbol? (cadr expr))
            (begin
-             (define name (cadr expr))
-             (define bindings (caddr expr))
-             (define body (cdddr expr))
+             (define name     (car (cdr expr)))
+             (define bindings (car (cdr (cdr expr))))
+             (define body     (cdr (cdr (cdr expr))))
              (list (r 'let) '()
                    (list (r 'define) name
                          (cons (r 'lambda) (cons (map car bindings) body)))
@@ -79,23 +46,20 @@
        (let ((clauses (cdr expr)))
          (if (null? clauses)
              #f
-             (if (compare (r 'else) (caar clauses))
-                 (cons (r 'begin) (cdar clauses))
-                 (if (if (>= (length (car clauses)) 2)
-                         (compare (r '=>) (cadar clauses))
+             (begin
+               (define clause (car clauses))
+               (if (compare (r 'else) (car clause))
+                   (cons (r 'begin) (cdr clause))
+                   (if (if (>= (length clause) 2)
+                           (compare (r '=>) (list-ref clause 1))
                            #f)
-                     (list (r 'let) (list (list 'x (caar clauses)))
-                           (list (r 'if) 'x
-                                 (list (caddar clauses) 'x)
+                       (list (r 'let) (list (list (r 'x) (car clause)))
+                             (list (r 'if) (r 'x)
+                                   (list (list-ref clause 2) (r 'x))
                                    (cons (r 'cond) (cdr clauses))))
-                     (list (r 'if) (caar clauses)
-                           (cons (r 'begin) (cdar clauses))
-                           (cons (r 'cond) (cdr clauses))))))))))
-
-  (define (single? list)
-    (if (pair? list)
-        (null? (cdr list))
-        #f))
+                       (list (r 'if) (car clause)
+                             (cons (r 'begin) (cdr clause))
+                             (cons (r 'cond) (cdr clauses)))))))))))
 
   (define-syntax and
     (er-macro-transformer
@@ -104,7 +68,7 @@
          (cond
           ((null? exprs)
            #t)
-          ((single? exprs)
+          ((= (length exprs) 1)
            (car exprs))
           (else
            (list (r 'let) (list (list (r 'it) (car exprs)))
@@ -119,7 +83,7 @@
          (cond
           ((null? exprs)
            #t)
-          ((single? exprs)
+          ((= (length exprs) 1)
            (car exprs))
           (else
            (list (r 'let) (list (list (r 'it) (car exprs)))
@@ -127,30 +91,47 @@
                        (r 'it)
                        (cons (r 'or) (cdr exprs))))))))))
 
-  (define (quasiquote? form compare?)
-    (and (pair? form) (compare? (car form) 'quasiquote)))
+  (define (list->vector list)
+    (let ((vector (make-vector (length list))))
+      (let loop ((list list) (i 0))
+        (if (null? list)
+            vector
+            (begin
+              (vector-set! vector i (car list))
+              (loop (cdr list) (+ i 1)))))))
 
-  (define (unquote? form compare?)
-    (and (pair? form) (compare? (car form) 'unquote)))
-
-  (define (unquote-splicing? form compare?)
-    (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
+  (define (vector->list vector)
+    (let ((length (vector-length vector)))
+      (let loop ((list '()) (i 0))
+        (if (= i length)
+            (reverse list)
+            (loop (cons (vector-ref vector i) list) (+ i 1))))))
 
   (define-syntax quasiquote
     (ir-macro-transformer
      (lambda (form inject compare)
 
+       (define (quasiquote? form)
+         (and (pair? form) (compare (car form) 'quasiquote)))
+
+       (define (unquote? form)
+         (and (pair? form) (compare (car form) 'unquote)))
+
+       (define (unquote-splicing? form)
+         (and (pair? form) (pair? (car form))
+              (compare (car (car form)) 'unquote-splicing)))
+
        (define (qq depth expr)
          (cond
           ;; unquote
-          ((unquote? expr compare)
+          ((unquote? expr)
            (if (= depth 1)
                (car (cdr expr))
                (list 'list
                      (list 'quote (inject 'unquote))
                      (qq (- depth 1) (car (cdr expr))))))
           ;; unquote-splicing
-          ((unquote-splicing? expr compare)
+          ((unquote-splicing? expr)
            (if (= depth 1)
                (list 'append
                      (car (cdr (car expr)))
@@ -161,7 +142,7 @@
                            (qq (- depth 1) (car (cdr (car expr)))))
                      (qq depth (cdr expr)))))
           ;; quasiquote
-          ((quasiquote? expr compare)
+          ((quasiquote? expr)
            (list 'list
                  (list 'quote (inject 'quasiquote))
                  (qq (+ depth 1) (car (cdr expr)))))
@@ -170,6 +151,9 @@
            (list 'cons
                  (qq depth (car expr))
                  (qq depth (cdr expr))))
+          ;; vector
+          ((vector? expr)
+           (list 'list->vector (qq depth (vector->list expr))))
           ;; simple datum
           (else
            (list 'quote expr))))
@@ -221,9 +205,9 @@
   (define-syntax do
     (er-macro-transformer
      (lambda (form r compare)
-       (let ((bindings (cadr form))
-             (finish (caddr form))
-             (body (cdddr form)))
+       (let ((bindings (car (cdr form)))
+             (finish   (car (cdr (cdr form))))
+             (body     (cdr (cdr (cdr form)))))
          `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
                                         (list (car x) (cadr x)))
                                       bindings)
@@ -263,50 +247,57 @@
             ,(let loop ((clauses clauses))
                (if (null? clauses)
                    #f
-                   `(,(r 'if) ,(if (compare (r 'else) (caar clauses))
+                   (begin
+                     (define clause (car clauses))
+                     `(,(r 'if) ,(if (compare (r 'else) (car clause))
                                      '#t
                                      `(,(r 'or)
-                                     ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
-                                            (caar clauses))))
-                     ,(if (compare (r '=>) (cadar clauses))
-                          `(,(caddar clauses) ,(r 'key))
-                          `(,(r 'begin) ,@(cdar clauses)))
-                        ,(loop (cdr clauses))))))))))
+                                       ,@(map (lambda (x)
+                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
+                                              (car clause))))
+                       ,(if (compare (r '=>) (list-ref clause 1))
+                            `(,(list-ref clause 2) ,(r 'key))
+                            `(,(r 'begin) ,@(cdr clause)))
+                       ,(loop (cdr clauses)))))))))))
 
-  (define-syntax syntax-error
+  (define-syntax letrec-syntax
     (er-macro-transformer
-     (lambda (expr rename compare)
-       (apply error (cdr expr)))))
+     (lambda (form r c)
+       (let ((formal (car (cdr form)))
+             (body   (cdr (cdr form))))
+         `(let ()
+            ,@(map (lambda (x)
+                     `(,(r 'define-syntax) ,(car x) ,(cadr x)))
+                   formal)
+            ,@body)))))
 
-  (define-syntax define-auxiliary-syntax
+  (define-syntax let-syntax
     (er-macro-transformer
-     (lambda (expr r c)
-       `(,(r 'define-syntax) ,(cadr expr)
-           (,(r 'sc-macro-transformer)
-                (,(r 'lambda) (expr env)
-                  (,(r 'error) "invalid use of auxiliary syntax")))))))
-
-  (define-auxiliary-syntax else)
-  (define-auxiliary-syntax =>)
-  (define-auxiliary-syntax _)
-  (define-auxiliary-syntax ...)
-  (define-auxiliary-syntax unquote)
-  (define-auxiliary-syntax unquote-splicing)
+     (lambda (form r c)
+       `(,(r 'letrec-syntax) ,@(cdr form)))))
 
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or
           cond case else =>
           do when unless
+          let-syntax letrec-syntax
           _ ... syntax-error))
 
+(import (picrin core-syntax))
+
+(export let let* letrec letrec*
+        quasiquote unquote unquote-splicing
+        and or
+        cond case else =>
+        do when unless
+        let-syntax letrec-syntax
+        _ ... syntax-error)
 
 ;;; multiple value
-(define-library (picrin multiple-value)
+(define-library (picrin values)
   (import (scheme base)
-          (scheme cxr)
-          (picrin macro)
-          (picrin core-syntax))
+          (picrin macro))
 
   (define-syntax let*-values
     (er-macro-transformer
@@ -324,24 +315,56 @@
      (lambda (form r c)
        `(,(r 'let*-values) ,@(cdr form)))))
 
+  (define (vector-map proc vect)
+    (do ((i 0 (+ i 1))
+         (u (make-vector (vector-length vect))))
+        ((= i (vector-length vect))
+         u)
+      (vector-set! u i (proc (vector-ref vect i)))))
+
+  (define (walk proc expr)
+    (cond
+     ((null? expr)
+      '())
+     ((pair? expr)
+      (cons (proc (car expr))
+            (walk proc (cdr expr))))
+     ((vector? expr)
+      (vector-map proc expr))
+     (else
+      (proc expr))))
+
+  (define (flatten expr)
+    (let ((list '()))
+      (walk
+       (lambda (x)
+         (set! list (cons x list)))
+       expr)
+      (reverse list)))
+
+  (define uniq
+    (let ((counter 0))
+      (lambda (x)
+        (let ((sym (string->symbol (string-append "var$" (number->string counter)))))
+          (set! counter (+ counter 1))
+          sym))))
+
   (define-syntax define-values
-    (er-macro-transformer
-     (lambda (form r c)
-       (let ((formals (cadr form)))
-         `(,(r 'begin)
-            ,@(do ((vars formals (cdr vars))
-                   (defs '()))
-                  ((null? vars)
-                   defs)
-                (set! defs (cons `(,(r 'define) ,(car vars) #f) defs)))
-            (,(r 'call-with-values)
-                (,(r 'lambda) () ,@(cddr form))
-              (,(r 'lambda) (,@(map r formals))
-                ,@(do ((vars formals (cdr vars))
-                       (assn '()))
-                      ((null? vars)
-                       assn)
-                    (set! assn (cons `(,(r 'set!) ,(car vars) ,(r (car vars))) assn))))))))))
+    (ir-macro-transformer
+     (lambda (form inject compare)
+       (let* ((formal  (cadr form))
+              (formal* (walk uniq formal))
+              (exprs   (cddr form)))
+         `(begin
+            ,@(map
+               (lambda (var) `(define ,var #f))
+               (flatten formal))
+            (call-with-values (lambda () ,@exprs)
+              (lambda ,formal*
+                ,@(map
+                   (lambda (var val) `(set! ,var ,val))
+                   (flatten formal)
+                   (flatten formal*)))))))))
 
   (export let-values
           let*-values
@@ -350,42 +373,75 @@
 ;;; parameter
 (define-library (picrin parameter)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro)
-          (picrin core-syntax))
+          (picrin var)
+          (picrin attribute)
+          (picrin dictionary))
 
-  ;; reopen (pircin parameter)
-  ;; see src/var.c
+  (define (single? x)
+    (and (list? x) (= (length x) 1)))
+
+  (define (double? x)
+    (and (list? x) (= (length x) 2)))
+
+  (define (%make-parameter init conv)
+    (let ((var (make-var (conv init))))
+      (define (parameter . args)
+        (cond
+         ((null? args)
+          (var-ref var))
+         ((single? args)
+          (var-set! var (conv (car args))))
+         ((double? args)
+          (var-set! var ((cadr args) (car args))))
+         (else
+          (error "invalid arguments for parameter"))))
+
+      (dictionary-set! (attribute parameter) '@@var var)
+
+      parameter))
+
+  (define (make-parameter init . conv)
+    (let ((conv
+           (if (null? conv)
+               (lambda (x) x)
+               (car conv))))
+      (%make-parameter init conv)))
+
+  (define-syntax with
+    (ir-macro-transformer
+     (lambda (form inject compare)
+       (let ((before (car (cdr form)))
+             (after  (car (cdr (cdr form))))
+             (body   (cdr (cdr (cdr form)))))
+         `(begin
+            (,before)
+            (let ((result (begin ,@body)))
+              (,after)
+              result))))))
+
+  (define (var-of parameter)
+    (dictionary-ref (attribute parameter) '@@var))
 
   (define-syntax parameterize
-    (er-macro-transformer
-     (lambda (form r compare)
-       (let ((bindings (cadr form))
-             (body (cddr form)))
-         (let ((vars (map car bindings))
-               (gensym (lambda (var)
-                         (string->symbol
-                          (string-append
-                           "parameterize-"
-                           (symbol->string var))))))
-           `(,(r 'let) (,@(map (lambda (var)
-                                 `(,(r (gensym var)) (,var)))
-                            vars))
-              ,@bindings
-              (,(r 'let) ((,(r 'result) (begin ,@body)))
-                ,@(map (lambda (var)
-                         `(,(r 'parameter-set!) ,var ,(r (gensym var))))
-                       vars)
-                ,(r 'result))))))))
+    (ir-macro-transformer
+     (lambda (form inject compare)
+       (let ((formal (car (cdr form)))
+             (body   (cdr (cdr form))))
+         (let ((vars (map car formal))
+               (vals (map cadr formal)))
+           `(with
+             (lambda () ,@(map (lambda (var val) `(var-push! (var-of ,var) ,val)) vars vals))
+             (lambda () ,@(map (lambda (var) `(var-pop! (var-of ,var))) vars))
+             ,@body))))))
 
-  (export parameterize))
+  (export make-parameter
+          parameterize))
 
 ;;; Record Type
 (define-library (picrin record)
   (import (scheme base)
-	  (scheme cxr)
-	  (picrin macro)
-          (picrin core-syntax))
+          (picrin macro))
 
   (define record-marker (list 'record-marker))
 
@@ -490,9 +546,9 @@
   (define-syntax define-record-field
     (ir-macro-transformer
      (lambda (form inject compare?)
-       (let ((type (cadr form))
-	     (field-tag (caddr form))
-	     (acc-mod (cdddr form)))
+       (let ((type      (car (cdr form)))
+	     (field-tag (car (cdr (cdr form))))
+	     (acc-mod   (cdr (cdr (cdr form)))))
 	 (if (= 1 (length acc-mod))
 	     `(define ,(car acc-mod)
 		(record-accessor ,type ',field-tag))
@@ -506,9 +562,9 @@
     (ir-macro-transformer
      (lambda (form inject compare?)
        (let ((type (cadr form))
-	     (constructor (caddr form))
-	     (predicate (cadddr form))
-	     (field-tag (cddddr form)))
+	     (constructor (car (cdr (cdr form))))
+	     (predicate   (car (cdr (cdr (cdr form)))))
+	     (field-tag   (cdr (cdr (cdr (cdr form))))))
 	 `(begin
 	    (define ,type
 	      (make-record-type ',type ',(cdr constructor)))
@@ -521,21 +577,13 @@
 		 `(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x)))
 	       field-tag))))))
 
-  (export define-record-type vector?))
+  (export define-record-type))
 
 (import (picrin macro)
-        (picrin core-syntax)
-        (picrin multiple-value)
+        (picrin values)
         (picrin parameter)
         (picrin record))
 
-(export let let* letrec letrec*
-        quasiquote unquote unquote-splicing
-        and or
-        cond case else =>
-        do when unless
-        _ ... syntax-error)
-
 (export let-values
         let*-values
         define-values)
@@ -543,8 +591,7 @@
 (export make-parameter
         parameterize)
 
-(export vector?                         ; override definition
-        define-record-type)
+(export define-record-type)
 
 (define (every pred list)
   (if (null? list)
@@ -588,34 +635,6 @@
 
 ;;; 6.4 Pairs and lists
 
-(define (memq obj list)
-  (if (null? list)
-      #f
-      (if (eq? obj (car list))
-	  list
-	  (memq obj (cdr list)))))
-
-(define (memv obj list)
-  (if (null? list)
-      #f
-      (if (eqv? obj (car list))
-	  list
-	  (memq obj (cdr list)))))
-
-(define (assq obj list)
-  (if (null? list)
-      #f
-      (if (eq? obj (caar list))
-	  (car list)
-	  (assq obj (cdr list)))))
-
-(define (assv obj list)
-  (if (null? list)
-      #f
-      (if (eqv? obj (caar list))
-	  (car list)
-	  (assq obj (cdr list)))))
-
 (define (member obj list . opts)
   (let ((compare (if (null? opts) equal? (car opts))))
     (if (null? list)
@@ -632,8 +651,7 @@
 	    (car list)
 	    (assoc obj (cdr list) compare)))))
 
-(export memq memv member
-        assq assv assoc)
+(export member assoc)
 
 ;;; 6.5. Symbols
 
@@ -719,14 +737,20 @@
   (apply vector list))
 
 (define (vector-copy! to at from . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
+  (let* ((start (if (pair? opts) (car opts) 0))
          (end (if (>= (length opts) 2)
                   (cadr opts)
-		 (vector-length from))))
+                  (vector-length from)))
+         (vs #f))
+    (if (eq? from to)
+        (begin
+          (set! vs (make-vector (- end start)))
+          (vector-copy! vs 0 from start end)
+          (vector-copy! to at vs))
         (do ((i at (+ i 1))
              (j start (+ j 1)))
             ((= j end))
-      (vector-set! to i (vector-ref from j)))))
+          (vector-set! to i (vector-ref from j))))))
 
 (define (vector-copy v . opts)
   (let ((start (if (pair? opts) (car opts) 0))
@@ -778,14 +802,20 @@
 	(bytevector-u8-set! v i (car l))))))
 
 (define (bytevector-copy! to at from . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
+  (let* ((start (if (pair? opts) (car opts) 0))
          (end (if (>= (length opts) 2)
 		 (cadr opts)
-		 (bytevector-length from))))
+		 (bytevector-length from)))
+         (vs #f))
+    (if (eq? from to)
+        (begin
+          (set! vs (make-bytevector (- end start)))
+          (bytevector-copy! vs 0 from start end)
+          (bytevector-copy! to at vs))
         (do ((i at (+ i 1))
              (j start (+ j 1)))
             ((= j end))
-      (bytevector-u8-set! to i (bytevector-u8-ref from j)))))
+          (bytevector-u8-set! to i (bytevector-u8-ref from j))))))
 
 (define (bytevector-copy v . opts)
   (let ((start (if (pair? opts) (car opts) 0))
@@ -880,6 +910,16 @@
 
 ;;; 6.13. Input and output
 
+(import (picrin port))
+
+(define current-input-port (make-parameter standard-input-port))
+(define current-output-port (make-parameter standard-output-port))
+(define current-error-port (make-parameter standard-error-port))
+
+(export current-input-port
+        current-output-port
+        current-error-port)
+
 (define (call-with-port port proc)
   (dynamic-wind
       (lambda () #f)
@@ -888,52 +928,31 @@
 
 (export call-with-port)
 
-;;; Appendix A. Standard Libraries Lazy
-(define-library (scheme lazy)
-  (import (scheme base)
-	  (picrin macro))
+;;; include syntax
 
-  (define-record-type promise
-    (make-promise% done obj)
-    promise?
-    (done promise-done? promise-done!)
-    (obj promise-value promise-value!))
+(import (scheme read)
+        (scheme file))
 
-  (define-syntax delay-force
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(make-promise% #f (lambda () ,expr))))))
+(define (read-many 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)))))))
 
-  (define-syntax delay
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(delay-force (make-promise% #t ,expr))))))
+(define-syntax include
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (let ((filenames (cdr form)))
+       (let ((exprs (apply append (map read-many filenames))))
+         `(,(rename 'begin) ,@exprs))))))
 
-  (define (promise-update! new old)
-    (promise-done! old (promise-done? new))
-    (promise-value! old (promise-value new)))
-
-  (define (force promise)
-    (if (promise-done? promise)
-	(promise-value promise)
-	(let ((promise* ((promise-value promise))))
-	  (unless (promise-done? promise)
-		  (promise-update! promise* promise))
-	  (force promise))))
-
-  (define (make-promise obj)
-    (if (promise? obj)
-	obj
-	(make-promise% #f obj)))
-
-  (export delay-force delay force make-promise promise?))
+(export include)
 
 ;;; syntax-rules
 (define-library (picrin syntax-rules)
   (import (scheme base)
-	  (scheme cxr)
           (picrin macro))
 
   ;;; utility functions
@@ -1063,7 +1082,7 @@
 			 (let-values (((match1 vars1) (compile-match-base (car pattern))))
 			   (loop (cdr pattern)
 				 (cons `(,_if (,_pair? ,accessor)
-					      (,_let ((expr (,_car,accessor)))
+					      (,_let ((expr (,_car ,accessor)))
 						     ,match1)
 					      (exit #f))
 				       matches)
@@ -1125,7 +1144,7 @@
        (define (compile-expand ellipsis reserved template)
 	 (letrec ((compile-expand-base
 		   (lambda (template ellipsis-valid)
-		     (cond ((member template reserved compare)
+		     (cond ((member template reserved eq?)
 			    (values (var->sym template) (list template)))
 			   ((symbol? template)
 			    (values `(rename ',template) '()))
@@ -1207,9 +1226,9 @@
 	       ((compare (car clauses) 'mismatch)
 		`(,_syntax-error "invalid rule"))
 	       (else
-		(let ((vars (car (car clauses)))
-		      (match (cadr (car clauses)))
-		      (expand (caddr (car clauses))))
+		(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
@@ -1240,9 +1259,9 @@
 
        (let ((form (normalize-form form)))
 	 (if form
-	     (let ((ellipsis (cadr form))
-		   (literals (caddr form))
-		   (rules (cdddr 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
@@ -1255,3 +1274,4 @@
 
 (import (picrin syntax-rules))
 (export syntax-rules)
+

piclib/scheme/case-lambda.scm

@@ -0,0 +1,29 @@
+(define-library (scheme case-lambda)
+  (import (scheme base))
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda (params body0 ...) ...)
+       (lambda args
+         (let ((len (length args)))
+           (letrec-syntax
+               ((cl (syntax-rules ::: ()
+                      ((cl)
+                       (error "no matching clause"))
+                      ((cl ((p :::) . body) . rest)
+                       (if (= len (length '(p :::)))
+                           (apply (lambda (p :::)
+                                    . body)
+                                  args)
+                           (cl . rest)))
+                      ((cl ((p ::: . tail) . body)
+                           . rest)
+                       (if (>= len (length '(p :::)))
+                           (apply
+                            (lambda (p ::: . tail)
+                              . body)
+                            args)
+                           (cl . rest))))))
+             (cl (params body0 ...) ...)))))))
+
+  (export case-lambda))

piclib/scheme/cxr.scm

@@ -0,0 +1,36 @@
+;;; Appendix A. Standard Libraries CxR
+
+(define-library (scheme cxr)
+  (import (scheme base))
+
+  (define (caaar p) (car (caar p)))
+  (define (caadr p) (car (cadr p)))
+  (define (cadar p) (car (cdar p)))
+  (define (caddr p) (car (cddr p)))
+  (define (cdaar p) (cdr (caar p)))
+  (define (cdadr p) (cdr (cadr p)))
+  (define (cddar p) (cdr (cdar p)))
+  (define (cdddr p) (cdr (cddr p)))
+  (define (caaaar p) (caar (caar p)))
+  (define (caaadr p) (caar (cadr p)))
+  (define (caadar p) (caar (cdar p)))
+  (define (caaddr p) (caar (cddr p)))
+  (define (cadaar p) (cadr (caar p)))
+  (define (cadadr p) (cadr (cadr p)))
+  (define (caddar p) (cadr (cdar p)))
+  (define (cadddr p) (cadr (cddr p)))
+  (define (cdaaar p) (cdar (caar p)))
+  (define (cdaadr p) (cdar (cadr p)))
+  (define (cdadar p) (cdar (cdar p)))
+  (define (cdaddr p) (cdar (cddr p)))
+  (define (cddaar p) (cddr (caar p)))
+  (define (cddadr p) (cddr (cadr p)))
+  (define (cdddar p) (cddr (cdar p)))
+  (define (cddddr p) (cddr (cddr p)))
+
+  (export caaar caadr cadar caddr
+          cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr
+          cadaar cadadr caddar cadddr
+          cdaaar cdaadr cdadar cdaddr
+          cddaar cddadr cdddar cddddr))

piclib/scheme/file.scm

@@ -0,0 +1,11 @@
+(define-library (scheme file)
+  (import (scheme base))
+
+  (define (call-with-input-file filename callback)
+    (call-with-port (open-input-file filename) callback))
+
+  (define (call-with-output-file filename callback)
+    (call-with-port (open-output-file filename) callback))
+
+  (export call-with-input-file
+          call-with-output-file))

piclib/scheme/lazy.scm

@@ -0,0 +1,42 @@
+;;; Appendix A. Standard Libraries Lazy
+
+(define-library (scheme lazy)
+  (import (scheme base)
+	  (picrin macro))
+
+  (define-record-type promise
+    (make-promise% done obj)
+    promise?
+    (done promise-done? promise-done!)
+    (obj promise-value promise-value!))
+
+  (define-syntax delay-force
+    (ir-macro-transformer
+     (lambda (form rename compare?)
+       (let ((expr (cadr form)))
+	 `(make-promise% #f (lambda () ,expr))))))
+
+  (define-syntax delay
+    (ir-macro-transformer
+     (lambda (form rename compare?)
+       (let ((expr (cadr form)))
+	 `(delay-force (make-promise% #t ,expr))))))
+
+  (define (promise-update! new old)
+    (promise-done! old (promise-done? new))
+    (promise-value! old (promise-value new)))
+
+  (define (force promise)
+    (if (promise-done? promise)
+	(promise-value promise)
+	(let ((promise* ((promise-value promise))))
+	  (unless (promise-done? promise)
+		  (promise-update! promise* promise))
+	  (force promise))))
+
+  (define (make-promise obj)
+    (if (promise? obj)
+	obj
+	(make-promise% #t obj)))
+
+  (export delay-force delay force make-promise promise?))

piclib/srfi/1.scm

@@ -550,23 +550,23 @@
 
   (define (delete-duplicates list . =)
     (let ((= (if (null? =) equal? (car =))))
-      (let rec ((list list))
+      (let rec ((list list) (cont values))
         (if (null? list)
-	    list
+            (cont '())
             (let* ((x (car list))
                    (rest (cdr list))
-		   (deleted (rec (delete x list =))))
-	      (if (eq? rest deleted) list (cons x deleted)))))))
+                   (deleted (delete x rest =)))
+              (rec deleted (lambda (y) (cont (cons x y)))))))))
 
   (define (delete-duplicates! list . =)
     (let ((= (if (null? =) equal? (car =))))
-      (let rec ((list list))
+      (let rec ((list list) (cont values))
         (if (null? list)
-	    list
+            (cont '())
             (let* ((x (car list))
                    (rest (cdr list))
-		   (deleted (rec (delete! x list =))))
-	      (if (eq? rest deleted) list (cons x deleted)))))))
+                   (deleted (delete! x list =)))
+              (rec deleted (lambda (y) (cont (cons x y)))))))))
 
   (export delete delete-duplicates
           delete! delete-duplicates!)

piclib/srfi/111.scm

@@ -0,0 +1,8 @@
+(define-library (srfi 111)
+  (import (scheme base))
+
+  (define-record-type box-type (box value) box?
+                      (value unbox set-box!))
+
+  (export box box?
+          unbox set-box!))

piclib/srfi/43.scm

@@ -50,7 +50,7 @@
 
                                         ; for the symmetry, this should be rather 'vector=?' than 'vector='.
   (define (vector= elt=? . vects)
-    (letrec ((2vector=
+    (letrec ((vector2=
               (lambda (v1 v2)
                 (let ((ln1 (vector-length v1)))
                   (and (= ln1 (vector-length v2))
@@ -67,7 +67,7 @@
                       (others (cdr others)))
                   (if (eq? vect1 vect2)
                       (rec1 vect1 others)
-                      (and (2vector= vect1 vect2)
+                      (and (vector2= vect1 vect2)
                            (rec1 vect2 others)))))))))
 
   

piclib/srfi/95.scm

@@ -14,9 +14,6 @@
   (define (identity x)
     x)
 
-  (define (quotient a b)
-    (exact (floor (/ a b))))
-
   (define (merge ls1 ls2 less? . opt-key)
     (let ((key (if (null? opt-key) identity (car opt-key))))
       (let rec ((arg1 ls1) (arg2 ls2))

src/CMakeLists.txt

@@ -1,8 +1,9 @@
+find_package(Perl REQUIRED)
+
 # xfile
 set(XFILE_SOURCES extlib/xfile/xfile.c)
 
 # piclib
-find_package(Perl REQUIRED)
 set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c)
 add_custom_command(
   OUTPUT ${PICLIB_SOURCE}
@@ -11,9 +12,18 @@ add_custom_command(
   WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
   )
 
+# contrib
+set(CONTRIB_INIT ${PROJECT_SOURCE_DIR}/src/init_contrib.c)
+add_custom_command(
+  OUTPUT ${CONTRIB_INIT}
+  COMMAND ${PERL_EXECUTABLE} etc/mkinit.pl ${PICRIN_CONTRIB_INITS} > ${CONTRIB_INIT}
+  DEPENDS ${PICRIN_CONTRIB_SOURCES}
+  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})
+add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
 target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
 
 # install

src/bool.c

@@ -6,27 +6,119 @@
 
 #include "picrin.h"
 #include "picrin/pair.h"
+#include "picrin/vector.h"
+#include "picrin/blob.h"
+#include "picrin/string.h"
 
-bool
-pic_equal_p(pic_state *pic, pic_value x, pic_value y)
+static bool
+str_equal_p(struct pic_string *str1, struct pic_string *str2)
 {
-  enum pic_tt type;
+  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(ht, pic_obj_ptr(x)) != NULL) {
+        return true;            /* `x' was seen already.  */
+      } else {
+        xh_put(ht, pic_obj_ptr(x), NULL);
+      }
+    }
+  }
+
+  c = 0;
+
+ LOOP:
 
   if (pic_eqv_p(x, y))
     return true;
 
-  type = pic_type(x);
-  if (type != pic_type(y))
+  if (pic_type(x) != pic_type(y))
     return false;
-  switch (type) {
-  case PIC_TT_PAIR:
-    return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y))
-      && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y));
+
+  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)
 {

src/box.c

@@ -1,30 +0,0 @@
-#include "picrin.h"
-#include "picrin/box.h"
-
-pic_value
-pic_box(pic_state *pic, pic_value value)
-{
-  struct pic_box *box;
-
-  box = (struct pic_box *)pic_obj_alloc(pic, sizeof(struct pic_box), PIC_TT_BOX);
-  box->value = value;
-  return pic_obj_value(box);
-}
-
-pic_value
-pic_unbox(pic_state *pic, pic_value box)
-{
-  if (! pic_box_p(box)) {
-    pic_errorf(pic, "expected box, but got ~s", box);
-  }
-  return pic_box_ptr(box)->value;
-}
-
-void
-pic_set_box(pic_state *pic, pic_value box, pic_value value)
-{
-  if (! pic_box_p(box)) {
-    pic_errorf(pic, "expected box, but got ~s", box);
-  }
-  pic_box_ptr(box)->value = value;
-}

src/codegen.c

@@ -51,7 +51,7 @@ static void pop_scope(analyze_state *);
 #define register_renamed_symbol(pic, state, slot, lib, id) do {         \
     pic_sym sym, gsym;                                                  \
     sym = pic_intern_cstr(pic, id);                                     \
-    if (! pic_find_rename(pic, lib->senv, sym, &gsym)) {                \
+    if (! pic_find_rename(pic, lib->env, sym, &gsym)) {                \
       pic_error(pic, "internal error! native VM procedure not found");  \
     }                                                                   \
     state->slot = gsym;                                                 \
@@ -366,7 +366,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
       : pic_false_value();
 
     /* To know what kind of local variables are defined, analyze body at first. */
-    body = analyze(state, pic_cons(pic, pic_sym_value(pic->sBEGIN), body_exprs), true);
+    body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true);
 
     locals = pic_nil_value();
     for (i = scope->locals.size; i > 0; --i) {
@@ -420,14 +420,11 @@ analyze_define(analyze_state *state, pic_value obj)
   pic_value var, val;
   pic_sym sym;
 
-  if (pic_length(pic, obj) < 2) {
+  if (pic_length(pic, obj) != 3) {
     pic_error(pic, "syntax error");
   }
 
   var = pic_list_ref(pic, obj, 1);
-  if (pic_pair_p(var)) {
-    var = pic_list_ref(pic, var, 0);
-  }
   if (! pic_sym_p(var)) {
     pic_error(pic, "syntax error");
   } else {
@@ -435,11 +432,13 @@ analyze_define(analyze_state *state, pic_value obj)
   }
   var = analyze_declare(state, sym);
 
-  if (pic_pair_p(pic_list_ref(pic, obj, 1))) {
+  if (pic_pair_p(pic_list_ref(pic, obj, 2))
+      && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0))
+      && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) {
     pic_value formals, body_exprs;
 
-    formals = pic_list_tail(pic, pic_list_ref(pic, obj, 1), 1);
-    body_exprs = pic_list_tail(pic, obj, 2);
+    formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1);
+    body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2);
 
     val = analyze_procedure(state, pic_sym_value(sym), formals, body_exprs);
   } else {
@@ -535,7 +534,7 @@ analyze_quote(analyze_state *state, pic_value obj)
   if (pic_length(pic, obj) != 2) {
     pic_error(pic, "syntax error");
   }
-  return obj;
+  return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1));
 }
 
 #define ARGC_ASSERT_GE(n) do {				\
@@ -690,6 +689,12 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos)
 	}						\
       } while (0)
 
+#define ARGC_ASSERT_WITH_FALLBACK(n) do {               \
+	if (pic_length(pic, obj) != (n) + 1) {		\
+          goto fallback;                                \
+	}						\
+      } while (0)
+
 #define CONSTRUCT_OP1(op)                                               \
       pic_list2(pic,                                                    \
                 pic_symbol_value(op),                                   \
@@ -721,22 +726,22 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
     if (pic_sym_p(proc)) {
       pic_sym sym = pic_sym(proc);
 
-      if (sym == pic->sDEFINE) {
+      if (sym == pic->rDEFINE) {
         return analyze_define(state, obj);
       }
-      else if (sym == pic->sLAMBDA) {
+      else if (sym == pic->rLAMBDA) {
         return analyze_lambda(state, obj);
       }
-      else if (sym == pic->sIF) {
+      else if (sym == pic->rIF) {
         return analyze_if(state, obj, tailpos);
       }
-      else if (sym == pic->sBEGIN) {
+      else if (sym == pic->rBEGIN) {
         return analyze_begin(state, obj, tailpos);
       }
-      else if (sym == pic->sSETBANG) {
+      else if (sym == pic->rSETBANG) {
         return analyze_set(state, obj);
       }
-      else if (sym == pic->sQUOTE) {
+      else if (sym == pic->rQUOTE) {
         return analyze_quote(state, obj);
       }
       else if (sym == state->rCONS) {
@@ -768,23 +773,23 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
         return analyze_div(state, obj);
       }
       else if (sym == state->rEQ) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sEQ);
       }
       else if (sym == state->rLT) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sLT);
       }
       else if (sym == state->rLE) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sLE);
       }
       else if (sym == state->rGT) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sGT);
       }
       else if (sym == state->rGE) {
-	ARGC_ASSERT(2);
+	ARGC_ASSERT_WITH_FALLBACK(2);
         return CONSTRUCT_OP2(pic->sGE);
       }
       else if (sym == state->rNOT) {
@@ -798,6 +803,8 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
         return analyze_call_with_values(state, obj, tailpos);
       }
     }
+  fallback:
+
     return analyze_call(state, obj, tailpos);
   }
   case PIC_TT_BOOL:
@@ -819,12 +826,10 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
   case PIC_TT_ERROR:
   case PIC_TT_SENV:
   case PIC_TT_MACRO:
-  case PIC_TT_SC:
   case PIC_TT_LIB:
   case PIC_TT_VAR:
   case PIC_TT_IREP:
   case PIC_TT_DATA:
-  case PIC_TT_BOX:
   case PIC_TT_DICT:
     pic_errorf(pic, "invalid expression given: ~s", obj);
   }

src/cont.c

@@ -221,7 +221,7 @@ cont_call(pic_state *pic)
   proc = pic_get_proc(pic);
   pic_get_args(pic, "*", &argc, &argv);
 
-  cont = (struct pic_cont *)pic_ptr(pic_proc_cv_ref(pic, proc, 0));
+  cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont"));
   cont->results = pic_list_by_array(pic, argc, argv);
 
   /* execute guard handlers */
@@ -245,8 +245,7 @@ pic_callcc(pic_state *pic, struct pic_proc *proc)
     c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
 
     /* save the continuation object in proc */
-    pic_proc_cv_init(pic, c, 1);
-    pic_proc_cv_set(pic, c, 0, pic_obj_value(cont));
+    pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
 
     return pic_apply1(pic, proc, pic_obj_value(c));
   }
@@ -267,8 +266,7 @@ pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
     c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
 
     /* save the continuation object in proc */
-    pic_proc_cv_init(pic, c, 1);
-    pic_proc_cv_set(pic, c, 0, pic_obj_value(cont));
+    pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
 
     return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
   }

src/dict.c

@@ -5,6 +5,63 @@
 #include "picrin.h"
 #include "picrin/dict.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)
 {
@@ -12,9 +69,7 @@ pic_dict_dict(pic_state *pic)
 
   pic_get_args(pic, "");
 
-  dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
-
-  xh_init_int(&dict->hash, sizeof(pic_value));
+  dict = pic_dict_new(pic);
 
   return pic_obj_value(dict);
 }
@@ -34,15 +89,10 @@ pic_dict_dict_ref(pic_state *pic)
 {
   struct pic_dict *dict;
   pic_sym key;
-  xh_entry *e;
 
   pic_get_args(pic, "dm", &dict, &key);
 
-  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);
+  return pic_dict_ref(pic, dict , key);
 }
 
 static pic_value
@@ -54,11 +104,22 @@ pic_dict_dict_set(pic_state *pic)
 
   pic_get_args(pic, "dmo", &dict, &key, &val);
 
-  xh_put_int(&dict->hash, key, &val);
+  pic_dict_set(pic, dict, key, val);
 
   return pic_none_value();
 }
 
+static pic_value
+pic_dict_dict_has_p(pic_state *pic)
+{
+  struct pic_dict *dict;
+  pic_sym key;
+
+  pic_get_args(pic, "dm", &dict, &key);
+
+  return pic_bool_value(pic_dict_has(pic, dict, key));
+}
+
 static pic_value
 pic_dict_dict_del(pic_state *pic)
 {
@@ -67,11 +128,7 @@ pic_dict_dict_del(pic_state *pic)
 
   pic_get_args(pic, "dm", &dict, &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);
+  pic_dict_del(pic, dict, key);
 
   return pic_none_value();
 }
@@ -83,18 +140,37 @@ pic_dict_dict_size(pic_state *pic)
 
   pic_get_args(pic, "d", &dict);
 
-  return pic_int_value(dict->hash.count);
+  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 ("(picrin dictionary)") {
-    pic_defun(pic, "dictionary", pic_dict_dict);
+    pic_defun(pic, "make-dictionary", pic_dict_dict);
     pic_defun(pic, "dictionary?", pic_dict_dict_p);
+    pic_defun(pic, "dictionary-has?", pic_dict_dict_has_p);
     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

@@ -17,7 +17,6 @@ pic_abort(pic_state *pic, const char *msg)
   UNUSED(pic);
 
   fprintf(stderr, "abort: %s\n", msg);
-  fflush(stderr);
   abort();
 }
 
@@ -88,7 +87,7 @@ error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
 }
 
 noreturn void
-pic_throw(pic_state *pic, struct pic_error *e)
+pic_throw_error(pic_state *pic, struct pic_error *e)
 {
   pic->err = e;
   if (! pic->jmp) {
@@ -98,6 +97,16 @@ pic_throw(pic_state *pic, struct pic_error *e)
   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)
 {
@@ -110,13 +119,17 @@ void
 pic_errorf(pic_state *pic, const char *fmt, ...)
 {
   va_list ap;
-  pic_value err_line;
+  pic_value err_line, irrs;
+  const char *msg;
 
   va_start(ap, fmt);
   err_line = pic_vformat(pic, fmt, ap);
   va_end(ap);
 
-  pic_throw(pic, error_new(pic, PIC_ERROR_OTHER, pic_str_ptr(pic_car(pic, err_line)), pic_cdr(pic, err_line)));
+  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
@@ -147,19 +160,19 @@ pic_error_raise(pic_state *pic)
 
   pic_get_args(pic, "o", &v);
 
-  pic_throw(pic, error_new(pic, PIC_ERROR_RAISED, pic_str_new_cstr(pic, "object is raised"), pic_list1(pic, v)));
+  pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v));
 }
 
 noreturn static pic_value
 pic_error_error(pic_state *pic)
 {
-  pic_str *str;
+  const char *str;
   size_t argc;
   pic_value *argv;
 
-  pic_get_args(pic, "s*", &str, &argc, &argv);
+  pic_get_args(pic, "z*", &str, &argc, &argv);
 
-  pic_throw(pic, error_new(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv)));
+  pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv));
 }
 
 static pic_value

src/gc.c

@@ -19,7 +19,6 @@
 #include "picrin/lib.h"
 #include "picrin/var.h"
 #include "picrin/data.h"
-#include "picrin/box.h"
 #include "picrin/dict.h"
 
 #if GC_DEBUG
@@ -381,6 +380,9 @@ gc_mark_object(pic_state *pic, struct pic_object *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);
     }
@@ -458,24 +460,15 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
-  case PIC_TT_SC: {
-    struct pic_sc *sc = (struct pic_sc *)obj;
-    gc_mark(pic, sc->expr);
-    gc_mark_object(pic, (struct pic_object *)sc->senv);
-    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->senv);
+    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->value);
-    if (var->conv) {
-      gc_mark_object(pic, (struct pic_object *)var->conv);
-    }
+    gc_mark(pic, var->stack);
     break;
   }
   case PIC_TT_IREP: {
@@ -500,11 +493,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
-  case PIC_TT_BOX: {
-    struct pic_box *box = (struct pic_box *)obj;
-    gc_mark(pic, box->value);
-    break;
-  }
   case PIC_TT_DICT: {
     struct pic_dict *dict = (struct pic_dict *)obj;
     xh_iter it;
@@ -635,15 +623,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   }
   case PIC_TT_SENV: {
     struct pic_senv *senv = (struct pic_senv *)obj;
-    xh_destroy(&senv->renames);
+    xh_destroy(&senv->map);
     break;
   }
   case PIC_TT_MACRO: {
     break;
   }
-  case PIC_TT_SC: {
-    break;
-  }
   case PIC_TT_LIB: {
     struct pic_lib *lib = (struct pic_lib *)obj;
     xh_destroy(&lib->exports);
@@ -665,9 +650,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     xh_destroy(&data->storage);
     break;
   }
-  case PIC_TT_BOX: {
-    break;
-  }
   case PIC_TT_DICT: {
     struct pic_dict *dict = (struct pic_dict *)obj;
     xh_destroy(&dict->hash);

src/init.c

@@ -31,15 +31,10 @@ 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_contrib(pic_state *);
 
 void pic_load_piclib(pic_state *);
 
-void
-pic_init_contrib(pic_state *pic)
-{
-  PIC_CONTRIB_INITS
-}
-
 #define push_sym(pic, name, list)                                       \
   pic_push(pic, pic_symbol_value(pic_intern_cstr(pic, name)), list)
 
@@ -67,14 +62,14 @@ pic_init_core(pic_state *pic)
   pic_deflibrary ("(scheme base)") {
 
     /* load core syntaces */
-    pic->lib->senv = pic_null_syntactic_environment(pic);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN);
-    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX);
+    pic->lib->env = pic_null_syntactic_environment(pic);
+    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_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;

src/lib.c

@@ -27,7 +27,7 @@ pic_make_library(pic_state *pic, pic_value name)
   senv = pic_null_syntactic_environment(pic);
 
   lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
-  lib->senv = senv;
+  lib->env = senv;
   lib->name = name;
   xh_init_int(&lib->exports, sizeof(pic_sym));
 
@@ -78,7 +78,7 @@ pic_import(pic_state *pic, pic_value spec)
     printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym)));
 #endif
 
-    pic_put_rename(pic, pic->lib->senv, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
+    pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
   }
 }
 
@@ -87,7 +87,7 @@ pic_export(pic_state *pic, pic_sym sym)
 {
   pic_sym rename;
 
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
   }
 
@@ -103,7 +103,7 @@ pic_export_as(pic_state *pic, pic_sym sym, pic_sym as)
 {
   pic_sym rename;
 
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
   }
 

src/number.c

@@ -50,6 +50,10 @@ pic_number_integer_p(pic_state *pic)
   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();
     }
@@ -133,6 +137,7 @@ pic_number_nan_p(pic_state *pic)
       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]))			\
@@ -739,7 +744,7 @@ pic_init_number(pic_state *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_integer_p);
+  pic_defun(pic, "rational?", pic_number_real_p);
   pic_defun(pic, "integer?", pic_number_integer_p);
   pic_gc_arena_restore(pic, ai);
 
@@ -777,6 +782,9 @@ pic_init_number(pic_state *pic)
   pic_defun(pic, "floor-remainder", pic_number_floor_remainder);
   pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient);
   pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
+  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);

src/pair.c

@@ -45,6 +45,32 @@ pic_cdr(pic_state *pic, pic_value 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)
 {
@@ -235,6 +261,36 @@ pic_append(pic_state *pic, pic_value xs, pic_value 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_assq(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -253,6 +309,24 @@ pic_assq(pic_state *pic, pic_value key, pic_value 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)
 {
@@ -568,6 +642,46 @@ pic_pair_list_copy(pic_state *pic)
   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_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);
+}
+
 void
 pic_init_pair(pic_state *pic)
 {
@@ -592,4 +706,8 @@ pic_init_pair(pic_state *pic)
   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, "assq", pic_pair_assq);
+  pic_defun(pic, "assv", pic_pair_assv);
 }

src/port.c

@@ -306,7 +306,7 @@ pic_port_open_output_string(pic_state *pic)
 static pic_value
 pic_port_get_output_string(pic_state *pic)
 {
-  struct pic_port *port = pic_stdout(pic);;
+  struct pic_port *port = pic_stdout(pic);
 
   pic_get_args(pic, "|p", &port);
 
@@ -329,6 +329,8 @@ pic_port_open_input_blob(pic_state *pic)
   port->status = PIC_PORT_OPEN;
 
   xfwrite(blob->data, 1, blob->len, port->file);
+  xfflush(port->file);
+  xrewind(port->file);
 
   return pic_obj_value(port);
 }
@@ -351,7 +353,7 @@ pic_port_open_output_bytevector(pic_state *pic)
 static pic_value
 pic_port_get_output_bytevector(pic_state *pic)
 {
-  struct pic_port *port = pic_stdout(pic);;
+  struct pic_port *port = pic_stdout(pic);
   long endpos;
   char *buf;
 
@@ -682,9 +684,11 @@ pic_port_flush(pic_state *pic)
 void
 pic_init_port(pic_state *pic)
 {
-  pic_defvar(pic, "current-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN));
-  pic_defvar(pic, "current-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT));
-  pic_defvar(pic, "current-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT));
+  pic_deflibrary ("(picrin port)") {
+    pic_define(pic, "standard-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN));
+    pic_define(pic, "standard-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT));
+    pic_define(pic, "standard-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT));
+  }
 
   pic_defun(pic, "input-port?", pic_port_input_port_p);
   pic_defun(pic, "output-port?", pic_port_output_port_p);

src/proc.c

@@ -6,6 +6,7 @@
 #include "picrin/pair.h"
 #include "picrin/proc.h"
 #include "picrin/irep.h"
+#include "picrin/dict.h"
 
 struct pic_proc *
 pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
@@ -19,6 +20,7 @@ pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
   proc->u.func.f = func;
   proc->u.func.name = pic_intern_cstr(pic, name);
   proc->env = NULL;
+  proc->attr = NULL;
   return proc;
 }
 
@@ -31,6 +33,7 @@ pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
   proc->kind = PIC_PROC_KIND_IREP;
   proc->u.irep = irep;
   proc->env = env;
+  proc->attr = NULL;
   return proc;
 }
 
@@ -46,75 +49,25 @@ pic_proc_name(struct pic_proc *proc)
   UNREACHABLE();
 }
 
-void
-pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
+struct pic_dict *
+pic_attr(pic_state *pic, struct pic_proc *proc)
 {
-  struct pic_env *env;
-
-  if (proc->env != NULL) {
-    pic_error(pic, "env slot already in use");
+  if (proc->attr == NULL) {
+    proc->attr = pic_dict_new(pic);
   }
-  env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
-  env->regc = cv_size;
-  env->regs = (pic_value *)pic_calloc(pic, cv_size, sizeof(pic_value));
-  env->up = NULL;
-
-  proc->env = env;
-}
-
-int
-pic_proc_cv_size(pic_state *pic, struct pic_proc *proc)
-{
-  UNUSED(pic);
-  return proc->env ? proc->env->regc : 0;
+  return proc->attr;
 }
 
 pic_value
-pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i)
+pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key)
 {
-  if (proc->env == NULL) {
-    pic_error(pic, "no closed env");
-  }
-  return proc->env->regs[i];
+  return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key));
 }
 
 void
-pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
+pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v)
 {
-  if (proc->env == NULL) {
-    pic_error(pic, "no closed env");
-  }
-  proc->env->regs[i] = v;
-}
-
-static pic_value
-papply_call(pic_state *pic)
-{
-  size_t argc;
-  pic_value *argv, arg, arg_list;
-  struct pic_proc *proc;
-
-  pic_get_args(pic, "*", &argc, &argv);
-
-  proc = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
-  arg = pic_proc_cv_ref(pic, pic_get_proc(pic), 1);
-
-  arg_list = pic_list_by_array(pic, argc, argv);
-  arg_list = pic_cons(pic, arg, arg_list);
-  return pic_apply(pic, proc, arg_list);
-}
-
-struct pic_proc *
-pic_papply(pic_state *pic, struct pic_proc *proc, pic_value arg)
-{
-  struct pic_proc *pa_proc;
-
-  pa_proc = pic_proc_new(pic, papply_call, "<partial-applied-procedure>");
-  pic_proc_cv_init(pic, pa_proc, 2);
-  pic_proc_cv_set(pic, pa_proc, 0, pic_obj_value(proc));
-  pic_proc_cv_set(pic, pa_proc, 1, arg);
-
-  return pa_proc;
+  pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v);
 }
 
 static pic_value
@@ -206,6 +159,16 @@ pic_proc_for_each(pic_state *pic)
   return pic_none_value();
 }
 
+static pic_value
+pic_proc_attribute(pic_state *pic)
+{
+  struct pic_proc *proc;
+
+  pic_get_args(pic, "l", &proc);
+
+  return pic_obj_value(pic_attr(pic, proc));
+}
+
 void
 pic_init_proc(pic_state *pic)
 {
@@ -213,4 +176,8 @@ pic_init_proc(pic_state *pic)
   pic_defun(pic, "apply", pic_proc_apply);
   pic_defun(pic, "map", pic_proc_map);
   pic_defun(pic, "for-each", pic_proc_for_each);
+
+  pic_deflibrary ("(picrin attribute)") {
+    pic_defun(pic, "attribute", pic_proc_attribute);
+  }
 }

src/read.c

@@ -4,6 +4,7 @@
 
 #include <ctype.h>
 #include <math.h>
+#include <stdlib.h>
 #include "picrin.h"
 #include "picrin/error.h"
 #include "picrin/pair.h"
@@ -15,11 +16,12 @@
 typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, char);
 
 static pic_value read(pic_state *pic, struct pic_port *port, char c);
+static pic_value read_nullable(pic_state *pic, struct pic_port *port, char c);
 
 static noreturn void
 read_error(pic_state *pic, const char *msg)
 {
-  pic_error(pic, msg);
+  pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value());
 }
 
 static char
@@ -47,6 +49,26 @@ peek(struct pic_port *port)
   return c;
 }
 
+static bool
+expect(struct pic_port *port, const char *str)
+{
+  char c;
+
+  while ((c = *str++) != 0) {
+    if (c != peek(port))
+      return false;
+    next(port);
+  }
+
+  return true;
+}
+
+static bool
+isdelim(char c)
+{
+  return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
+}
+
 static pic_value
 read_comment(pic_state *pic, struct pic_port *port, char c)
 {
@@ -63,24 +85,22 @@ static pic_value
 read_block_comment(pic_state *pic, struct pic_port *port, char c)
 {
   char x, y;
-  int i;
+  int i = 1;
 
   UNUSED(pic);
   UNUSED(c);
 
-  x = next(port);
   y = next(port);
 
-  i = 1;
-  while (x != EOF && y != EOF && i > 0) {
+  while (y != EOF && i > 0) {
+    x = y;
+    y = next(port);
     if (x == '|' && y == '#') {
       i--;
     }
     if (x == '#' && y == '|') {
       i++;
     }
-    x = y;
-    y = next(port);
   }
 
   return pic_undef_value();
@@ -96,6 +116,27 @@ read_datum_comment(pic_state *pic, struct pic_port *port, char c)
   return pic_undef_value();
 }
 
+static pic_value
+read_directive(pic_state *pic, struct pic_port *port, char c)
+{
+  switch (peek(port)) {
+  case 'n':
+    if (expect(port, "no-fold-case")) {
+      /* :FIXME: set no-fold-case flag */
+      return pic_undef_value();
+    }
+    break;
+  case 'f':
+    if (expect(port, "fold-case")) {
+      /* :FIXME: set fold-case flag */
+      return pic_undef_value();
+    }
+    break;
+  }
+
+  return read_comment(pic, port, c);
+}
+
 static pic_value
 read_quote(pic_state *pic, struct pic_port *port, char c)
 {
@@ -127,7 +168,6 @@ read_comma(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_symbol(pic_state *pic, struct pic_port *port, char c)
 {
-  static const char TRAIL_SYMBOL[] = "+/*!$%&:@^~?<=>_.-";
   size_t len;
   char *buf;
   pic_sym sym;
@@ -140,9 +180,9 @@ read_symbol(pic_state *pic, struct pic_port *port, char c)
       c = next(port);
     }
     len += 1;
-    buf = pic_realloc(pic, buf, len);
+    buf = pic_realloc(pic, buf, len + 1);
     buf[len - 1] = c;
-  } while (isalnum(peek(port)) || strchr(TRAIL_SYMBOL, peek(port)));
+  } while (! isdelim(peek(port)));
 
   buf[len] = '\0';
   sym = pic_intern_cstr(pic, buf);
@@ -151,42 +191,55 @@ read_symbol(pic_state *pic, struct pic_port *port, char c)
   return pic_sym_value(sym);
 }
 
-static int64_t
-read_uinteger(pic_state *pic, struct pic_port *port, char c)
+static size_t
+read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[])
 {
-  int64_t n;
-
-  c = skip(port, c);
+  size_t i = 0;
 
   if (! isdigit(c)) {
     read_error(pic, "expected one or more digits");
   }
 
-  n = c - '0';
+  buf[i++] = c;
   while (isdigit(c = peek(port))) {
-    next(port);
-    n = n * 10 + c - '0';
+    buf[i++] = next(port);
   }
 
-  return n;
+  buf[i] = '\0';
+
+  return i;
 }
 
 static pic_value
 read_number(pic_state *pic, struct pic_port *port, char c)
 {
-  int64_t i, j;
+  char buf[256];
+  size_t i;
+  long n;
 
-  i = read_uinteger(pic, port, c);
+  i = read_uinteger(pic, port, c, buf);
 
-  if (peek(port) == '.') {
+  switch (peek(port)) {
+  case '.':
+    do {
+      buf[i++] = next(port);
+    } while (isdigit(peek(port)));
+    buf[i] = '\0';
+    return pic_float_value(atof(buf));
+
+  case '/':
+    n = atoi(buf);
     next(port);
-    j = read_uinteger(pic, port, next(port));
-    return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%lld", j)));
-  }
-  else {
-    return pic_int_value(i);
+    read_uinteger(pic, port, next(port), buf);
+    if (n == n / atoi(buf) * atoi(buf)) {
+      return pic_int_value(n / atoi(buf)); /* exact */
+    } else {
+      return pic_float_value(n / (double)atoi(buf));
     }
 
+  default:
+    return pic_int_value(atoi(buf));
+  }
 }
 
 static pic_value
@@ -202,29 +255,39 @@ negate(pic_value n)
 static pic_value
 read_minus(pic_state *pic, struct pic_port *port, char c)
 {
-  static const char DIGITS[] = "0123456789";
+  pic_value sym;
 
-  /* TODO: -inf.0, -nan.0 */
-
-  if (strchr(DIGITS, peek(port))) {
-    return negate(read_number(pic, port, c));
+  if (isdigit(peek(port))) {
+    return negate(read_number(pic, port, next(port)));
   }
   else {
-    return read_symbol(pic, port, c);
+    sym = read_symbol(pic, port, c);
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-inf.0")))) {
+      return pic_float_value(-INFINITY);
+    }
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-nan.0")))) {
+      return pic_float_value(-NAN);
+    }
+    return sym;
   }
 }
 
 static pic_value
 read_plus(pic_state *pic, struct pic_port *port, char c)
 {
-  static const char DIGITS[] = "0123456789";
+  pic_value sym;
 
-  /* TODO: +inf.0, +nan.0 */
-
-  if (strchr(DIGITS, peek(port))) {
-    return read_number(pic, port, c);
+  if (isdigit(peek(port))) {
+    return read_number(pic, port, next(port));
   }
   else {
+    sym = read_symbol(pic, port, c);
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+inf.0")))) {
+      return pic_float_value(INFINITY);
+    }
+    if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+nan.0")))) {
+      return pic_float_value(NAN);
+    }
     return read_symbol(pic, port, c);
   }
 }
@@ -235,24 +298,61 @@ read_boolean(pic_state *pic, struct pic_port *port, char c)
   UNUSED(pic);
   UNUSED(port);
 
-  /* TODO: support #true and #false */
+  if (! isdelim(peek(port))) {
+    if (c == 't') {
+      if (! expect(port, "rue")) {
+        goto fail;
+      }
+    } else {
+      if (! expect(port, "alse")) {
+        goto fail;
+      }
+    }
+  }
 
   if (c == 't') {
     return pic_true_value();
   } else {
     return pic_false_value();
   }
+
+ fail:
+  read_error(pic, "illegal character during reading boolean literal");
 }
 
 static pic_value
 read_char(pic_state *pic, struct pic_port *port, char c)
 {
-  UNUSED(pic);
-  UNUSED(c);
+  c = next(port);
 
-  /* TODO: #\alart, #\space, so on and so on */
+  if (! isdelim(peek(port))) {
+    switch (c) {
+    default: read_error(pic, "unexpected character after char literal");
+    case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break;
+    case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break;
+    case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break;
+    case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break;
+    case 'n':
+      if ((c = peek(port)) == 'e') {
+        c = '\n';
+        if (! expect(port, "ewline"))
+          goto fail;
+      } else {
+        c = '\0';
+        if (! expect(port, "ull"))
+          goto fail;
+      }
+      break;
+    case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break;
+    case 's': c = ' '; if (! expect(port, "pace")) goto fail; break;
+    case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break;
+    }
+  }
 
-  return pic_char_value(next(port));
+  return pic_char_value(c);
+
+ fail:
+  read_error(pic, "unexpected character while reading character literal");
 }
 
 static pic_value
@@ -285,17 +385,61 @@ read_string(pic_state *pic, struct pic_port *port, char c)
   }
   buf[cnt] = '\0';
 
-  str = pic_str_new(pic, buf, size);
+  str = pic_str_new(pic, buf, cnt);
   pic_free(pic, buf);
   return pic_obj_value(str);
 }
 
+static pic_value
+read_pipe(pic_state *pic, struct pic_port *port, char c)
+{
+  char *buf;
+  size_t size, cnt;
+  pic_sym sym;
+  /* Currently supports only ascii chars */
+  char HEX_BUF[3];
+  size_t i = 0;
+
+  size = 256;
+  buf = pic_alloc(pic, size);
+  cnt = 0;
+  while ((c = next(port)) != '|') {
+    if (c == '\\') {
+      switch (c = next(port)) {
+      case 'a': c = '\a'; break;
+      case 'b': c = '\b'; break;
+      case 't': c = '\t'; break;
+      case 'n': c = '\n'; break;
+      case 'r': c = '\r'; break;
+      case 'x':
+        i = 0;
+        while ((HEX_BUF[i++] = next(port)) != ';') {
+          if (i >= sizeof HEX_BUF)
+            read_error(pic, "expected ';'");
+        }
+        c = (char)strtol(HEX_BUF, NULL, 16);
+        break;
+      }
+    }
+    buf[cnt++] = c;
+    if (cnt >= size) {
+      buf = pic_realloc(pic, buf, size *= 2);
+    }
+  }
+  buf[cnt] = '\0';
+
+  sym = pic_intern_cstr(pic, buf);
+  pic_free(pic, buf);
+
+  return pic_sym_value(sym);
+}
+
 static pic_value
 read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
 {
   int nbits, n;
   size_t len;
-  char *buf;
+  char *dat, buf[256];
   pic_blob *blob;
 
   nbits = 0;
@@ -313,21 +457,22 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
   }
 
   len = 0;
-  buf = NULL;
+  dat = NULL;
   c = next(port);
   while ((c = skip(port, c)) != ')') {
-    n = read_uinteger(pic, port, c);
+    read_uinteger(pic, port, c, buf);
+    n = atoi(buf);
     if (n < 0 || (1 << nbits) <= n) {
       read_error(pic, "invalid element in bytevector literal");
     }
     len += 1;
-    buf = pic_realloc(pic, buf, len);
-    buf[len - 1] = n;
+    dat = pic_realloc(pic, dat, len);
+    dat[len - 1] = n;
     c = next(port);
   }
 
-  blob = pic_blob_new(pic, buf, len);
-  pic_free(pic, buf);
+  blob = pic_blob_new(pic, dat, len);
+  pic_free(pic, dat);
   return pic_obj_value(blob);
 }
 
@@ -337,21 +482,32 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
   char tOPEN = c, tCLOSE = (tOPEN == '(') ? ')' : ']';
   pic_value car, cdr;
 
+ retry:
+
   c = skip(port, ' ');
 
   if (c == tCLOSE) {
     return pic_nil_value();
   }
-  if (c == '.' && strchr("()#;,|'\" \t\n\r", peek(port)) != NULL) {
+  if (c == '.' && isdelim(peek(port))) {
     cdr = read(pic, port, next(port));
 
+  closing:
     if ((c = skip(port, ' ')) != tCLOSE) {
+      if (pic_undef_p(read_nullable(pic, port, c))) {
+        goto closing;
+      }
       read_error(pic, "unmatched parenthesis");
     }
     return cdr;
   }
   else {
-    car = read(pic, port, c);
+    car = read_nullable(pic, port, c);
+
+    if (pic_undef_p(car)) {
+      goto retry;
+    }
+
     cdr = read_pair(pic, port, tOPEN); /* FIXME: don't use recursion */
     return pic_cons(pic, car, cdr);
   }
@@ -360,16 +516,11 @@ read_pair(pic_state *pic, struct pic_port *port, char c)
 static pic_value
 read_vector(pic_state *pic, struct pic_port *port, char c)
 {
-  pic_value val;
+  pic_value list;
 
-  c = next(port);
+  list = read(pic, port, c);
 
-  val = pic_nil_value();
-  while ((c = skip(port, c)) != ')') {
-    val = pic_cons(pic, read(pic, port, c), val);
-    c = next(port);
-  }
-  return pic_obj_value(pic_vec_new_from_list(pic, pic_reverse(pic, val)));
+  return pic_obj_value(pic_vec_new_from_list(pic, list));
 }
 
 static pic_value
@@ -470,7 +621,7 @@ read_dispatch(pic_state *pic, struct pic_port *port, char c)
 
   switch (c) {
   case '!':
-    return read_comment(pic, port, c);
+    return read_directive(pic, port, c);
   case '|':
     return read_block_comment(pic, port, c);
   case ';':
@@ -513,6 +664,8 @@ read_nullable(pic_state *pic, struct pic_port *port, char c)
     return read_comma(pic, port, c);
   case '"':
     return read_string(pic, port, c);
+  case '|':
+    return read_pipe(pic, port, c);
   case '0': case '1': case '2': case '3': case '4':
   case '5': case '6': case '7': case '8': case '9':
     return read_number(pic, port, c);

src/state.c

@@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sUNQUOTE, "unquote");
   register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
   register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
-  register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");
@@ -116,6 +115,23 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sNOT, "not");
   pic_gc_arena_restore(pic, ai);
 
+#define register_renamed_symbol(pic,slot,name) do {              \
+    pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));     \
+  } while (0)
+
+  ai = pic_gc_arena_preserve(pic);
+  register_renamed_symbol(pic, rDEFINE, "define");
+  register_renamed_symbol(pic, rLAMBDA, "lambda");
+  register_renamed_symbol(pic, rIF, "if");
+  register_renamed_symbol(pic, rBEGIN, "begin");
+  register_renamed_symbol(pic, rSETBANG, "set!");
+  register_renamed_symbol(pic, rQUOTE, "quote");
+  register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
+  register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
+  register_renamed_symbol(pic, rIMPORT, "import");
+  register_renamed_symbol(pic, rEXPORT, "export");
+  pic_gc_arena_restore(pic, ai);
+
   pic_init_core(pic);
 
   /* set library */

src/string.c

@@ -74,28 +74,29 @@ pic_str_ref(pic_state *pic, pic_str *str, size_t i)
 static xrope *
 xr_put(xrope *rope, size_t i, char c)
 {
-  xrope *x, *y;
-  char buf[1];
+  xrope *x, *y, *z;
+  char buf[2];
 
   if (xr_len(rope) <= i) {
     return NULL;
   }
 
   buf[0] = c;
+  buf[1] = '\0';
 
   x = xr_sub(rope, 0, i);
   y = xr_new_copy(buf, 1);
-  rope = xr_cat(x, y);
+  z = xr_cat(x, y);
   XROPE_DECREF(x);
   XROPE_DECREF(y);
 
-  x = rope;
+  x = z;
   y = xr_sub(rope, i + 1, xr_len(rope));
-  rope = xr_cat(x, y);
+  z = xr_cat(z, y);
   XROPE_DECREF(x);
   XROPE_DECREF(y);
 
-  return rope;
+  return z;
 }
 
 void
@@ -349,6 +350,9 @@ pic_str_string_copy_ip(pic_state *pic)
   case 4:
     end = pic_strlen(from);
   }
+  if (to == from) {
+    from = pic_substr(pic, from, 0, end);
+  }
 
   while (start < end) {
     pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));
@@ -385,9 +389,9 @@ pic_str_string_fill_ip(pic_state *pic)
   n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end);
 
   switch (n) {
-  case 1:
-    start = 0;
   case 2:
+    start = 0;
+  case 3:
     end = pic_strlen(str);
   }
 

src/system.c

@@ -104,17 +104,17 @@ pic_system_getenvs(pic_state *pic)
   }
 
   for (envp = pic->envp; *envp; ++envp) {
-    pic_value key, val;
+    pic_str *key, *val;
     int i;
 
     for (i = 0; (*envp)[i] != '='; ++i)
       ;
 
-    key = pic_obj_value(pic_str_new(pic, *envp, i));
-    val = pic_obj_value(pic_str_new_cstr(pic, getenv(*envp)));
+    key = pic_str_new(pic, *envp, i);
+    val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key)));
 
     /* push */
-    data = pic_acons(pic, key, val, data);
+    data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
 
     pic_gc_arena_restore(pic, ai);
     pic_gc_protect(pic, data);

src/var.c

@@ -3,179 +3,184 @@
  */
 
 #include "picrin.h"
-#include "picrin/proc.h"
 #include "picrin/var.h"
+#include "picrin/pair.h"
+
+static pic_value
+var_ref(pic_state *pic, struct pic_var *var)
+{
+  return pic_car(pic, var->stack);
+}
+
+static void
+var_set(pic_state *pic, struct pic_var *var, pic_value value)
+{
+  pic_set_car(pic, var->stack, value);
+}
+
+static void
+var_push(pic_state *pic, struct pic_var *var, pic_value value)
+{
+  var->stack = pic_cons(pic, value, var->stack);
+}
+
+static void
+var_pop(pic_state *pic, struct pic_var *var)
+{
+  var->stack = pic_cdr(pic, var->stack);
+}
 
 struct pic_var *
-pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */)
+pic_var_new(pic_state *pic, pic_value init)
 {
   struct pic_var *var;
 
   var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR);
-  var->value = pic_undef_value();
-  var->conv = conv;
+  var->stack = pic_nil_value();
 
-  pic_var_set(pic, var, init);
+  var_push(pic, var, init);
 
   return var;
 }
 
 pic_value
-pic_var_ref(pic_state *pic, struct pic_var *var)
+pic_var_ref(pic_state *pic, const char *name)
 {
-  UNUSED(pic);
-  return var->value;
+  pic_value v;
+  struct pic_var *var;
+
+  v = pic_ref(pic, name);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  return var_ref(pic, var);
 }
 
 void
-pic_var_set(pic_state *pic, struct pic_var *var, pic_value value)
+pic_var_set(pic_state *pic, const char *name, pic_value value)
 {
-  if (var->conv) {
-    value = pic_apply1(pic, var->conv, value);
-  }
-  pic_var_set_force(pic, var, value);
+  pic_value v;
+  struct pic_var *var;
+
+  v = pic_ref(pic, name);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  var_set(pic, var, value);
 }
 
 void
-pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value)
-{
-  UNUSED(pic);
-  var->value = value;
-}
-
-static struct pic_var *
-get_var_from_proc(pic_state *pic, struct pic_proc *proc)
+pic_var_push(pic_state *pic, const char *name, pic_value value)
 {
   pic_value v;
+  struct pic_var *var;
 
-  if (! pic_proc_p(v)) {
-    goto typeerror;
-  }
-  if (! pic_proc_func_p(pic_proc_ptr(v))) {
-    goto typeerror;
-  }
-  if (pic_proc_cv_size(pic, proc) != 1) {
-    goto typeerror;
-  }
-  v = pic_proc_cv_ref(pic, proc, 0);
-  if (! pic_var_p(v)) {
-    goto typeerror;
-  }
-  return pic_var_ptr(v);
+  v = pic_ref(pic, name);
 
- typeerror:
-  pic_error(pic, "expected parameter");
-  UNREACHABLE();
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  var_push(pic, var, value);
+}
+
+void
+pic_var_pop(pic_state *pic, const char *name)
+{
+  pic_value v;
+  struct pic_var *var;
+
+  v = pic_ref(pic, name);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  var_pop(pic, var);
 }
 
 static pic_value
-var_call(pic_state *pic)
+pic_var_make_var(pic_state *pic)
 {
-  struct pic_proc *proc;
-  struct pic_var *var;
-  pic_value v;
-  int c;
-
-  proc = pic_get_proc(pic);
-
-  c = pic_get_args(pic, "|o", &v);
-  if (c == 0) {
-    var = pic_var_ptr(proc->env->regs[0]);
-    return pic_var_ref(pic, var);
-  }
-  else if (c == 1) {
-    var = pic_var_ptr(proc->env->regs[0]);
-
-    pic_var_set(pic, var, v);
-    return pic_none_value();
-  }
-  else {
-    pic_abort(pic, "logic flaw");
-  }
-  UNREACHABLE();
-}
-
-struct pic_proc *
-pic_wrap_var(pic_state *pic, struct pic_var *var)
-{
-  struct pic_proc *proc;
-
-  proc = pic_proc_new(pic, var_call, "<var-procedure>");
-  pic_proc_cv_init(pic, proc, 1);
-  pic_proc_cv_set(pic, proc, 0, pic_obj_value(var));
-  return proc;
-}
-
-struct pic_var *
-pic_unwrap_var(pic_state *pic, struct pic_proc *proc)
-{
-  return get_var_from_proc(pic, proc);
-}
-
-static pic_value
-pic_var_make_parameter(pic_state *pic)
-{
-  struct pic_proc *conv = NULL;
-  struct pic_var *var;
   pic_value init;
 
-  pic_get_args(pic, "o|l", &init, &conv);
+  pic_get_args(pic, "o", &init);
 
-  var = pic_var_new(pic, init, conv);
-  return pic_obj_value(pic_wrap_var(pic, var));
+  return pic_obj_value(pic_var_new(pic, init));
 }
 
 static pic_value
-pic_var_parameter_ref(pic_state *pic)
+pic_var_var_ref(pic_state *pic)
 {
-  struct pic_proc *proc;
-  struct pic_var *var;
-
-  pic_get_args(pic, "l", &proc);
-
-  var = get_var_from_proc(pic, proc);
-  return pic_var_ref(pic, var);
-}
-
-static pic_value
-pic_var_parameter_set(pic_state *pic)
-{
-  struct pic_proc *proc;
   struct pic_var *var;
   pic_value v;
 
-  pic_get_args(pic, "lo", &proc, &v);
+  pic_get_args(pic, "o", &v);
 
-  var = get_var_from_proc(pic, proc);
-  /* no convert */
-  pic_var_set_force(pic, var, v);
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+
+  return var_ref(pic, var);
+}
+
+static pic_value
+pic_var_var_set(pic_state *pic)
+{
+  struct pic_var *var;
+  pic_value v, val;
+
+  pic_get_args(pic, "oo", &v, &val);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+  var_set(pic, var, val);
   return pic_none_value();
 }
 
 static pic_value
-pic_var_parameter_converter(pic_state *pic)
+pic_var_var_push(pic_state *pic)
 {
-  struct pic_proc *proc;
   struct pic_var *var;
+  pic_value v, val;
 
-  pic_get_args(pic, "l", &proc);
+  pic_get_args(pic, "oo", &v, &val);
 
-  var = get_var_from_proc(pic, proc);
-  if (var->conv) {
-    return pic_obj_value(var->conv);
-  }
-  else {
-    return pic_false_value();
-  }
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+  var_push(pic, var, val);
+  return pic_none_value();
+}
+
+static pic_value
+pic_var_var_pop(pic_state *pic)
+{
+  struct pic_var *var;
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  pic_assert_type(pic, v, var);
+
+  var = pic_var_ptr(v);
+  var_pop(pic, var);
+  return pic_none_value();
 }
 
 void
 pic_init_var(pic_state *pic)
 {
-  pic_deflibrary ("(picrin parameter)") {
-    pic_defun(pic, "make-parameter", pic_var_make_parameter);
-    pic_defun(pic, "parameter-ref", pic_var_parameter_ref);
-    pic_defun(pic, "parameter-set!", pic_var_parameter_set); /* no convert */
-    pic_defun(pic, "parameter-converter", pic_var_parameter_converter);
+  pic_deflibrary ("(picrin var)") {
+    pic_defun(pic, "make-var", pic_var_make_var);
+    pic_defun(pic, "var-ref", pic_var_var_ref);
+    pic_defun(pic, "var-set!", pic_var_var_set);
+    pic_defun(pic, "var-push!", pic_var_var_push);
+    pic_defun(pic, "var-pop!", pic_var_var_pop);
   }
 }

src/vm.c

@@ -115,7 +115,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *f = pic_int(v);
           break;
         default:
-          pic_error(pic, "pic_get_args: expected float or int");
+          pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
         }
         i++;
       }
@@ -141,7 +141,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *e = true;
           break;
         default:
-          pic_error(pic, "pic_get_args: expected float or int");
+          pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
         }
         i++;
       }
@@ -167,7 +167,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *e = true;
           break;
         default:
-          pic_error(pic, "pic_get_args: expected float or int");
+          pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v);
         }
         i++;
       }
@@ -189,7 +189,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *k = pic_int(v);
           break;
         default:
-          pic_error(pic, "pic_get_args: expected int");
+          pic_errorf(pic, "pic_get_args: expected int, but got ~s", v);
         }
         i++;
       }
@@ -206,23 +206,23 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *str = pic_str_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected string");
+          pic_errorf(pic, "pic_get_args: expected string, but got ~s", v);
         }
         i++;
       }
       break;
     }
     case 'z': {
-      pic_value str;
       const char **cstr;
+      pic_value v;
 
       cstr = va_arg(ap, const char **);
       if (i < argc) {
-        str = GET_OPERAND(pic,i);
-        if (! pic_str_p(str)) {
-          pic_error(pic, "pic_get_args: expected string");
+        v = GET_OPERAND(pic,i);
+        if (! pic_str_p(v)) {
+          pic_errorf(pic, "pic_get_args: expected string, but got ~s", v);
         }
-        *cstr = pic_str_cstr(pic_str_ptr(str));
+        *cstr = pic_str_cstr(pic_str_ptr(v));
         i++;
       }
       break;
@@ -238,7 +238,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *m = pic_sym(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected symbol");
+          pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v);
         }
         i++;
       }
@@ -255,7 +255,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *vec = pic_vec_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected vector");
+          pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v);
         }
         i++;
       }
@@ -272,7 +272,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *b = pic_blob_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected bytevector");
+          pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v);
         }
         i++;
       }
@@ -289,7 +289,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *c = pic_char(v);
         }
         else {
-          pic_error(pic, "pic_get_args: expected char");
+          pic_errorf(pic, "pic_get_args: expected char, but got ~s", v);
         }
         i++;
       }
@@ -306,7 +306,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *l = pic_proc_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args, expected procedure");
+          pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v);
         }
         i++;
       }
@@ -323,7 +323,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *p = pic_port_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args, expected port");
+          pic_errorf(pic, "pic_get_args, expected port, but got ~s", v);
         }
         i++;
       }
@@ -340,7 +340,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
           *d = pic_dict_ptr(v);
         }
         else {
-          pic_error(pic, "pic_get_args, expected dictionary");
+          pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v);
         }
         i++;
       }
@@ -376,7 +376,7 @@ global_ref(pic_state *pic, const char *name)
   pic_sym sym, rename;
 
   sym = pic_intern_cstr(pic, name);
-  if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
+  if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
     return SIZE_MAX;
   }
   if (! (e = xh_get_int(&pic->global_tbl, rename))) {
@@ -398,7 +398,7 @@ global_def(pic_state *pic, const char *name)
   }
 
   /* register to the senv */
-  rename = pic_add_rename(pic, pic->lib->senv, sym);
+  rename = pic_add_rename(pic, pic->lib->env, sym);
 
   /* register to the global table */
   gidx = pic->glen++;
@@ -427,7 +427,7 @@ pic_ref(pic_state *pic, const char *name)
 
   gid = global_ref(pic, name);
   if (gid == SIZE_MAX) {
-    pic_error(pic, "symbol not defined");
+    pic_errorf(pic, "symbol \"%s\" not defined", name);
   }
   return pic->globals[gid];
 }
@@ -444,6 +444,18 @@ pic_set(pic_state *pic, const char *name, pic_value value)
   pic->globals[gid] = value;
 }
 
+pic_value
+pic_funcall(pic_state *pic, const char *name, pic_list args)
+{
+  pic_value proc;
+
+  proc = pic_ref(pic, name);
+
+  pic_assert_type(pic, proc, proc);
+
+  return pic_apply(pic, pic_proc_ptr(proc), args);
+}
+
 void
 pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
 {
@@ -453,15 +465,6 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
   pic_define(pic, name, pic_obj_value(proc));
 }
 
-void
-pic_defvar(pic_state *pic, const char *name, pic_value init)
-{
-  struct pic_var *var;
-
-  var = pic_var_new(pic, init, NULL);
-  pic_define(pic, name, pic_obj_value(pic_wrap_var(pic, var)));
-}
-
 static void
 vm_push_env(pic_state *pic)
 {

src/write.c

@@ -318,11 +318,6 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_MACRO:
     xfprintf(file, "#<macro %p>", pic_ptr(obj));
     break;
-  case PIC_TT_SC:
-    xfprintf(file, "#<sc %p: ", pic_ptr(obj));
-    write_core(p, pic_sc_ptr(obj)->expr);
-    xfprintf(file, ">");
-    break;
   case PIC_TT_LIB:
     xfprintf(file, "#<lib %p>", pic_ptr(obj));
     break;
@@ -335,9 +330,6 @@ write_core(struct writer_control *p, pic_value obj)
   case PIC_TT_DATA:
     xfprintf(file, "#<data %p>", pic_ptr(obj));
     break;
-  case PIC_TT_BOX:
-    xfprintf(file, "#<box %p>", pic_ptr(obj));
-    break;
   case PIC_TT_DICT:
     xfprintf(file, "#<dict %p>", pic_ptr(obj));
     break;

t/array.scm

@@ -0,0 +1,42 @@
+(import (scheme base)
+        (scheme write)
+        (picrin array))
+
+(define ary (make-array))
+
+(write ary)
+(newline)
+(array-push! ary 1)
+(write ary)
+(newline)
+(array-push! ary 2)
+(write ary)
+(newline)
+(array-push! ary 3)
+(write ary)
+(newline)
+(write (array-pop! ary))
+(newline)
+(write (array-pop! ary))
+(newline)
+(write (array-pop! ary))
+(newline)
+
+(write ary)
+(newline)
+(array-unshift! ary 1)
+(write ary)
+(newline)
+(array-unshift! ary 2)
+(write ary)
+(newline)
+(array-unshift! ary 3)
+(write ary)
+(newline)
+(write (array-shift! ary))
+(newline)
+(write (array-shift! ary))
+(newline)
+(write (array-shift! ary))
+(newline)
+

t/r7rs-tests.scm

@@ -32,52 +32,18 @@
 ;        (scheme complex)
         (scheme time)
         (scheme file)
-;        (scheme read)
+        (scheme read)
         (scheme write)
 ;        (scheme eval)
         (scheme process-context)
-;        (scheme case-lambda)
-        )
+        (scheme case-lambda)
+        (picrin test))
 
 ;; R7RS test suite.  Covers all procedures and syntax in the small
 ;; language except `delete-file'.  Currently assumes full-unicode
 ;; support, the full numeric tower and all standard libraries
 ;; provided.
 
-(define (test-begin . o) #f)
-
-(define (test-end . o) #f)
-
-(define counter 1)
-
-(define-syntax test
-  (syntax-rules ()
-    ((test expected expr)
-     (let ((res expr))
-       (display "case ")
-       (write counter)
-       (cond
-        ((equal? res expected)
-         (display " PASS: ")
-         (write 'expr)
-         (display " equals ")
-         (write expected)
-         (display "")
-         (newline)
-         )
-        ((not (equal? res expected))
-         (display " FAIL: ")
-         (write 'expr)
-         (newline)
-         (display "   expected ")
-         (write expected)
-         (display " but got ")
-         (write res)
-         (display "")
-         (newline)))
-       (set! counter (+ counter 1))))))
-
-(newline)
 
 (test-begin "R7RS")
 
@@ -240,7 +206,7 @@
             (mean / /))))
 (let*-values (((a b c) (means '(8 5 99 1 22))))
   (test 27 a)
-  (test 9.728 b)
+  (test 9.7280002558226410514 b)
   (test (/ 1800 497) c))
 
 (let*-values (((root rem) (exact-integer-sqrt 32)))
@@ -364,18 +330,18 @@
 
 
 
-;; (define radix
-;;   (make-parameter
-;;    10
-;;    (lambda (x)
-;;      (if (and (integer? x) (<= 2 x 16))
-;;          x
-;;          (error "invalid radix")))))
-;; (define (f n) (number->string n (radix)))
-;; (test "12" (f 12))
-;; (test "1100" (parameterize ((radix 2))
-;;                            (f 12)))
-;; (test "12" (f 12))
+(define radix
+  (make-parameter
+   10
+   (lambda (x)
+     (if (and (integer? x) (<= 2 x 16))
+         x
+         (error "invalid radix")))))
+(define (f n) (number->string n (radix)))
+(test "12" (f 12))
+(test "1100" (parameterize ((radix 2))
+                           (f 12)))
+(test "12" (f 12))
 (test '(list 3 4) `(list ,(+ 1 2) 4))
 (let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name)))
 (test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
@@ -389,70 +355,70 @@
 (test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) )
 (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4)))
 
-;; (define plus
-;;   (case-lambda 
-;;    (() 0)
-;;    ((x) x)
-;;    ((x y) (+ x y))
-;;    ((x y z) (+ (+ x y) z))
-;;    (args (apply + args))))
+(define plus
+  (case-lambda
+   (() 0)
+   ((x) x)
+   ((x y) (+ x y))
+   ((x y z) (+ (+ x y) z))
+   (args (apply + args))))
 
-;; (test 0 (plus))
-;; (test 1 (plus 1))
-;; (test 3 (plus 1 2))
-;; (test 6 (plus 1 2 3))
-;; (test 10 (plus 1 2 3 4))
+(test 0 (plus))
+(test 1 (plus 1))
+(test 3 (plus 1 2))
+(test 6 (plus 1 2 3))
+(test 10 (plus 1 2 3 4))
 
-;; (define mult
-;;   (case-lambda 
-;;    (() 1)
-;;    ((x) x)
-;;    ((x y) (* x y))
-;;    ((x y . z) (apply mult (* x y) z))))
+(define mult
+  (case-lambda
+   (() 1)
+   ((x) x)
+   ((x y) (* x y))
+   ((x y . z) (apply mult (* x y) z))))
 
-;; (test 1 (mult))
-;; (test 1 (mult 1))
-;; (test 2 (mult 1 2))
-;; (test 6 (mult 1 2 3))
-;; (test 24 (mult 1 2 3 4))
+(test 1 (mult))
+(test 1 (mult 1))
+(test 2 (mult 1 2))
+(test 6 (mult 1 2 3))
+(test 24 (mult 1 2 3 4))
 
 (test-end)
 
 (test-begin "4.3 Macros")
 
-;; (test 'now (let-syntax
-;;                ((when (syntax-rules ()
-;;                         ((when test stmt1 stmt2 ...)
-;;                          (if test
-;;                              (begin stmt1
-;;                                     stmt2 ...))))))
-;;              (let ((if #t))
-;;                (when if (set! if 'now))
-;;                if)))
+(test 'now (let-syntax
+               ((when (syntax-rules ()
+                        ((when test stmt1 stmt2 ...)
+                         (if test
+                             (begin stmt1
+                                    stmt2 ...))))))
+             (let ((if #t))
+               (when if (set! if 'now))
+               if)))
 
-;; (test 'outer (let ((x 'outer))
-;;   (let-syntax ((m (syntax-rules () ((m) x))))
-;;     (let ((x 'inner))
-;;       (m)))))
+(test 'outer (let ((x 'outer))
+  (let-syntax ((m (syntax-rules () ((m) x))))
+    (let ((x 'inner))
+      (m)))))
 
-;; (test 7 (letrec-syntax
-;;   ((my-or (syntax-rules ()
-;;             ((my-or) #f)
-;;             ((my-or e) e)
-;;             ((my-or e1 e2 ...)
-;;              (let ((temp e1))
-;;                (if temp
-;;                    temp
-;;                    (my-or e2 ...)))))))
-;;   (let ((x #f)
-;;         (y 7)
-;;         (temp 8)
-;;         (let odd?)
-;;         (if even?))
-;;     (my-or x
-;;            (let temp)
-;;            (if y)
-;;            y))))
+(test 7 (letrec-syntax
+  ((my-or (syntax-rules ()
+            ((my-or) #f)
+            ((my-or e) e)
+            ((my-or e1 e2 ...)
+             (let ((temp e1))
+               (if temp
+                   temp
+                   (my-or e2 ...)))))))
+  (let ((x #f)
+        (y 7)
+        (temp 8)
+        (let odd?)
+        (if even?))
+    (my-or x
+           (let temp)
+           (if y)
+           y))))
 
 (define-syntax be-like-begin
   (syntax-rules ()
@@ -500,10 +466,10 @@
     (let ()
       (define-values (x) (values 1))
       x))
-;; (test 3
-;;     (let ()
-;;       (define-values x (values 1 2))
-;;       (apply + x)))
+(test 3
+    (let ()
+      (define-values x (values 1 2))
+      (apply + x)))
 (test 3
     (let ()
       (define-values (x y) (values 1 2))
@@ -512,10 +478,10 @@
     (let ()
       (define-values (x y z) (values 1 2 3))
       (+ x y z)))
-;; (test 10
-;;     (let ()
-;;       (define-values (x y . z) (values 1 2 3 4))
-;;       (+ x y (car z) (cadr z))))
+(test 10
+    (let ()
+      (define-values (x y . z) (values 1 2 3 4))
+      (+ x y (car z) (cadr z))))
 
 (test '(2 1) (let ((x 1) (y 2))
   (define-syntax swap!
@@ -606,6 +572,53 @@
 (test #t (equal? (make-vector 5 'a)
                  (make-vector 5 'a)))
 
+;; circular objects
+(let ((l '(1 . 2))
+      (m '(1 . 2)))
+  (set-cdr! l l)
+  (set-cdr! m m)
+  (test #t (equal? l m)))
+
+(let ((l '(1 . 2))
+      (m '(2 . 1)))
+  (set-cdr! l l)
+  (set-cdr! m m)
+  (test #f (equal? l m)))
+
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 1)))
+  (vector-set! v 1 v)
+  (vector-set! w 1 w)
+  (test #t (equal? v w)))
+
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 2)))
+  (vector-set! v 1 v)
+  (vector-set! w 1 w)
+  (test #f (equal? v w)))
+
+(let ((v (make-vector 2 1))
+      (w (make-vector 2 1))
+      (l '(1 . 2))
+      (m '(1 . 2)))
+  (vector-set! v 1 l)
+  (vector-set! w 1 m)
+  (set-cdr! l v)
+  (set-cdr! m w)
+  (test #t  (equal? v w)))
+
+(let ((v (make-vector 2 2))
+      (w (make-vector 2 1))
+      (l '(1 . 2))
+      (m '(1 . 2)))
+  (vector-set! v 1 l)
+  (vector-set! w 1 m)
+  (set-cdr! l v)
+  (set-cdr! m w)
+  (test #f (equal? v w)))
+
 (test-end)
 
 (test-begin "6.2 Numbers")
@@ -618,11 +631,11 @@
 ;; (test #t (real? #e1e10))
 (test #t (real? +inf.0))
 (test #f (rational? -inf.0))
-;; (test #t (rational? 6/10))
-;; (test #t (rational? 6/3))
+(test #t (rational? 6/10))
+(test #t (rational? 6/3))
 ;; (test #t (integer? 3+0i))
 (test #t (integer? 3.0))
-;; (test #t (integer? 8/4))
+(test #t (integer? 8/4))
 
 (test #f (exact? 3.0))
 ;; (test #t (exact? #e3.0))
@@ -630,7 +643,7 @@
 
 (test #t (exact-integer? 32))
 (test #f (exact-integer? 32.0))
-;; (test #f (exact-integer? 32/5))
+(test #f (exact-integer? 32/5))
 
 (test #t (finite? 3))
 (test #f (finite? +inf.0))
@@ -648,14 +661,14 @@
 
 ;; (test #t (= 1 1.0 1.0+0.0i))
 ;; (test #f (= 1.0 1.0+1.0i))
-;; (test #t (< 1 2 3))
-;; (test #f (< 1 1 2))
-;; (test #t (> 3.0 2.0 1.0))
-;; (test #f (> -3.0 2.0 1.0))
-;; (test #t (<= 1 1 2))
-;; (test #f (<= 1 2 1))
-;; (test #t (>= 2 1 1))
-;; (test #f (>= 1 2 1))
+(test #t (< 1 2 3))
+(test #f (< 1 1 2))
+(test #t (> 3.0 2.0 1.0))
+(test #f (> -3.0 2.0 1.0))
+(test #t (<= 1 1 2))
+(test #f (<= 1 2 1))
+(test #t (>= 2 1 1))
+(test #f (>= 1 2 1))
 
 ;; From R7RS 6.2.6 Numerical operations:
 ;;
@@ -744,8 +757,8 @@
 (test -1 (- 3 4))
 (test -6 (- 3 4 5))
 (test -3 (- 3))
-;; (test 3/20 (/ 3 4 5))
-;; (test 1/3 (/ 3))
+(test 3/20 (/ 3 4 5))
+(test 1/3 (/ 3))
 
 (test 7 (abs -7))
 (test 7 (abs 7))
@@ -798,14 +811,14 @@
 (test 3.0 (truncate 3.5))
 (test 4.0 (round 3.5))
 
-;; (test 4 (round 7/2))
+(test 4 (exact (round 7/2)))
 (test 7 (round 7))
 
 ;; (test 1/3 (rationalize (exact .3) 1/10))
 ;; (test #i1/3 (rationalize .3 1/10))
 
 (test 1.0 (inexact (exp 0))) ;; may return exact number
-(test 20.0855369231877 (exp 3))
+(test 20.0855369231876679236 (exp 3))
 
 (test 0.0 (inexact (log 1))) ;; may return exact number
 (test 1.0 (log (exp 1)))
@@ -818,30 +831,30 @@
 (test 1.0 (inexact (cos 0))) ;; may return exact number
 (test -1.0 (cos 3.14159265358979))
 (test 0.0 (inexact (tan 0))) ;; may return exact number
-(test 1.5574077246549 (tan 1))
+(test 1.5574077246549020703 (tan 1))
 
 (test 0.0 (asin 0))
-(test 1.5707963267949 (asin 1))
+(test 1.5707963267948965580 (asin 1))
 (test 0.0 (acos 1))
-(test 3.14159265358979 (acos -1))
+(test 3.1415926535897931160 (acos -1))
 
 (test 0.0 (atan 0.0 1.0))
 (test -0.0 (atan -0.0 1.0))
-(test 0.785398163397448 (atan 1.0 1.0))
-(test 1.5707963267949 (atan 1.0 0.0))
-(test 2.35619449019234 (atan 1.0 -1.0))
-(test 3.14159265358979 (atan 0.0 -1.0))
-(test -3.14159265358979 (atan -0.0 -1.0)) ;
-(test -2.35619449019234 (atan -1.0 -1.0))
-(test -1.5707963267949 (atan -1.0 0.0))
-(test -0.785398163397448 (atan -1.0 1.0))
+(test 0.7853981633974482790 (atan 1.0 1.0))
+(test 1.5707963267948965580 (atan 1.0 0.0))
+(test 2.3561944901923448370 (atan 1.0 -1.0))
+(test 3.1415926535897931160 (atan 0.0 -1.0))
+(test -3.1415926535897931160 (atan -0.0 -1.0)) ;
+(test -2.3561944901923448370 (atan -1.0 -1.0))
+(test -1.5707963267948965580 (atan -1.0 0.0))
+(test -0.7853981633974482790 (atan -1.0 1.0))
 ;; (test undefined (atan 0.0 0.0))
 
 (test 1764 (square 42))
 (test 4 (square 2))
 
 (test 3.0 (inexact (sqrt 9)))
-(test 1.4142135623731 (sqrt 2))
+(test 1.4142135623730951454 (sqrt 2))
 ;; (test 0.0+1.0i (inexact (sqrt -1)))
 
 (test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list))
@@ -1151,7 +1164,7 @@
 ;;       (string-set! s 1 #\x1F700)
 ;;       s))
 
-#;(test #t (string=? "" ""))
+(test #t (string=? "" ""))
 (test #t (string=? "abc" "abc" "abc"))
 (test #f (string=? "" "abc"))
 (test #f (string=? "abc" "aBc"))
@@ -1275,29 +1288,29 @@
 (test "b" (string-copy "abc" 1 2))
 (test "bc" (string-copy "abc" 1 3))
 
-;; (test "-----"
-;;     (let ((str (make-string 5 #\x))) (string-fill! str #\-) str))
-;; (test "xx---"
-;;     (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str))
-;; (test "xx-xx"
-;;     (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str))
+(test "-----"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\-) str))
+(test "xx---"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str))
+(test "xx-xx"
+    (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str))
 
-;; (test "a12de"
-;;     (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str))
-;; (test "-----"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str))
-;; (test "---xx"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str))
-;; (test "xx---"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str))
-;; (test "xx-xx"
-;;     (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str))
+(test "a12de"
+    (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str))
+(test "-----"
+    (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str))
+(test "---xx"
+    (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str))
+(test "xx---"
+    (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str))
+(test "xx-xx"
+    (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str))
 
 ;; same source and dest
-;; (test "aabde"
-;;     (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str))
-;; (test "abcab"
-;;     (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str))
+(test "aabde"
+    (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str))
+(test "abcab"
+    (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str))
 
 (test-end)
 
@@ -1802,9 +1815,9 @@
       (output-port-open? out)))
 
 (test #t (eof-object? (eof-object)))
-;; (test #t (eof-object? (read (open-input-string ""))))
+(test #t (eof-object? (read (open-input-string ""))))
 (test #t (char-ready? (open-input-string "42")))
-;; (test 42 (read (open-input-string " 42 ")))
+(test 42 (read (open-input-string " 42 ")))
 
 (test #t (eof-object? (read-char (open-input-string ""))))
 (test #\a (read-char (open-input-string "abc")))
@@ -1962,62 +1975,56 @@
 (test-begin "Read syntax")
 
 ;; check reading boolean followed by eof
-;; (test #t (read (open-input-string "#t")))
-;; (test #t (read (open-input-string "#true")))
-;; (test #f (read (open-input-string "#f")))
-;; (test #f (read (open-input-string "#false")))
-;; (define (read2 port)
-;;   (let* ((o1 (read port)) (o2 (read port)))
-;;     (cons o1 o2)))
-;; ;; check reading boolean followed by delimiter
-;; (test '(#t . (5)) (read2 (open-input-string "#t(5)")))
-;; (test '(#t . 6) (read2 (open-input-string "#true 6 ")))
-;; (test '(#f . 7) (read2 (open-input-string "#f 7")))
-;; (test '(#f . "8") (read2 (open-input-string "#false\"8\"")))
+(test #t (read (open-input-string "#t")))
+(test #t (read (open-input-string "#true")))
+(test #f (read (open-input-string "#f")))
+(test #f (read (open-input-string "#false")))
+(define (read2 port)
+  (let* ((o1 (read port)) (o2 (read port)))
+    (cons o1 o2)))
+;; check reading boolean followed by delimiter
+(test '(#t . (5)) (read2 (open-input-string "#t(5)")))
+(test '(#t . 6) (read2 (open-input-string "#true 6 ")))
+(test '(#f . 7) (read2 (open-input-string "#f 7")))
+(test '(#f . "8") (read2 (open-input-string "#false\"8\"")))
 
-;; (test '() (read (open-input-string "()")))
-;; (test '(1 2) (read (open-input-string "(1 2)")))
-;; (test '(1 . 2) (read (open-input-string "(1 . 2)")))
-;; (test '(1 2) (read (open-input-string "(1 . (2))")))
-;; (test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))")))
-;; (test '1 (cadr (read (open-input-string "#0=(1 . #0#)"))))
-;; (test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)"))))
+(test '() (read (open-input-string "()")))
+(test '(1 2) (read (open-input-string "(1 2)")))
+(test '(1 . 2) (read (open-input-string "(1 . 2)")))
+(test '(1 2) (read (open-input-string "(1 . (2))")))
+(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))")))
+(test '1 (cadr (read (open-input-string "#0=(1 . #0#)"))))
+(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)"))))
 
-;; (test '(quote (1 2)) (read (open-input-string "'(1 2)")))
-;; (test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)")))
-;; (test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)")))
-;; (test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)")))
+(test '(quote (1 2)) (read (open-input-string "'(1 2)")))
+(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)")))
+(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)")))
+(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)")))
 
-;; (test #() (read (open-input-string "#()")))
-;; (test #(a b) (read (open-input-string "#(a b)")))
+(test #() (read (open-input-string "#()")))
+(test #(a b) (read (open-input-string "#(a b)")))
 
-;; (test #u8() (read (open-input-string "#u8()")))
-;; (test #u8(0 1) (read (open-input-string "#u8(0 1)")))
+(test #u8() (read (open-input-string "#u8()")))
+(test #u8(0 1) (read (open-input-string "#u8(0 1)")))
 
-;; (test 'abc (read (open-input-string "abc")))
-;; (test 'abc (read (open-input-string "abc def")))
-;; (test 'ABC (read (open-input-string "ABC")))
-;; (test 'Hello (read (open-input-string "|H\\x65;llo|")))
+(test 'abc (read (open-input-string "abc")))
+(test 'abc (read (open-input-string "abc def")))
+(test 'ABC (read (open-input-string "ABC")))
+(test 'Hello (read (open-input-string "|H\\x65;llo|")))
 
-;; (test 'abc (read (open-input-string "#!fold-case ABC")))
-;; (test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
+(test 'abc (read (open-input-string "#!fold-case ABC")))
+(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC")))
 
-;; (test 'def (read (open-input-string "#; abc def")))
-;; (test 'def (read (open-input-string "; abc \ndef")))
-;; (test 'def (read (open-input-string "#| abc |# def")))
-;; (test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
-;; (test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
-;; (test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
-;; (test '(a d) (read (open-input-string "(a #; #;b c d)")))
-;; (test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
-;; (test '(a . c) (read (open-input-string "(a . #;b c)")))
-;; (test '(a . b) (read (open-input-string "(a . b #;c)")))
-
-;; (define (test-read-error str)
-;;   (test-assert
-;;       (guard (exn (else #t))
-;;         (read (open-input-string str))
-;;         #f)))
+(test 'def (read (open-input-string "#; abc def")))
+(test 'def (read (open-input-string "; abc \ndef")))
+(test 'def (read (open-input-string "#| abc |# def")))
+(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi")))
+(test 'ghi (read (open-input-string "#; ; abc\n def ghi")))
+(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)")))
+(test '(a d) (read (open-input-string "(a #; #;b c d)")))
+(test '(a e) (read (open-input-string "(a #;(b #;c d) e)")))
+(test '(a . c) (read (open-input-string "(a . #;b c)")))
+(test '(a . b) (read (open-input-string "(a . b #;c)")))
 
 ;; (test-read-error "(#;a . b)")
 ;; (test-read-error "(a . #;b)")
@@ -2058,56 +2065,25 @@
 ;; (test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\"")))
 ;; (test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0)))
 
-;; (test-end)
+(test-end)
 
 (test-begin "Numeric syntax")
 
-;; Numeric syntax adapted from Peter Bex's tests.
-;;
-;; These are updated to R7RS, using string ports instead of
-;; string->number, and "error" tests removed because implementations
-;; are free to provide their own numeric extensions.  Currently all
-;; tests are run by default - need to cond-expand and test for
-;; infinities and -0.0.
-
-;; (define-syntax test-numeric-syntax
-;;   (syntax-rules ()
-;;     ((test-numeric-syntax str expect strs ...)
-;;      (let* ((z (read (open-input-string str)))
-;;             (out (open-output-string))
-;;             (z-str (begin (write z out) (get-output-string out))))
-;;        (test expect (values z))
-;;        (test #t (and (member z-str '(str strs ...)) #t))))))
-
-;; Each test is of the form:
-;;
-;;   (test-numeric-syntax input-str expected-value expected-write-values ...)
-;;
-;; where the input should be eqv? to the expected-value, and the
-;; written output the same as any of the expected-write-values.  The
-;; form
-;;
-;;   (test-numeric-syntax input-str expected-value)
-;;
-;; is a shorthand for
-;;
-;;   (test-numeric-syntax input-str expected-value (input-str))
-
 ;; Simple
-;; (test-numeric-syntax "1" 1)
+(test-numeric-syntax "1" 1)
 ;; (test-numeric-syntax "+1" 1 "1")
-;; (test-numeric-syntax "-1" -1)
+(test-numeric-syntax "-1" -1)
 ;; (test-numeric-syntax "#i1" 1.0 "1.0" "1.")
 ;; (test-numeric-syntax "#I1" 1.0 "1.0" "1.")
 ;; (test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.")
 ;; ;; Decimal
-;; (test-numeric-syntax "1.0" 1.0 "1.0" "1.")
-;; (test-numeric-syntax "1." 1.0 "1.0" "1.")
-;; (test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
-;; (test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
+(test-numeric-syntax "1.0" 1.0 "1.0" "1.")
+(test-numeric-syntax "1." 1.0 "1.0" "1.")
+(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3")
+(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3")
 ;; ;; Some Schemes don't allow negative zero. This is okay with the standard
-;; (test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
-;; (test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0")
+(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0")
 ;; (test-numeric-syntax "#i1.0" 1.0 "1.0" "1.")
 ;; (test-numeric-syntax "#e1.0" 1 "1")
 ;; (test-numeric-syntax "#e-.0" 0 "0")
@@ -2124,21 +2100,21 @@
 ;; (test-numeric-syntax "1l2" 100.0 "100.0" "100.")
 ;; (test-numeric-syntax "1L2" 100.0 "100.0" "100.")
 ;; ;; NaN, Inf
-;; (test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
-;; (test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
-;; (test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
-;; (test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
-;; (test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
-;; (test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0")
+(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0")
+(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0")
+(test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0")
 ;; (test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0")
 ;; (test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0")
 ;; (test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0")
 ;; ;; Exact ratios
-;; (test-numeric-syntax "1/2" (/ 1 2))
+(test-numeric-syntax "1/2" (/ 1 2))
 ;; (test-numeric-syntax "#e1/2" (/ 1 2) "1/2")
-;; (test-numeric-syntax "10/2" 5 "5")
-;; (test-numeric-syntax "-1/2" (- (/ 1 2)))
-;; (test-numeric-syntax "0/10" 0 "0")
+(test-numeric-syntax "10/2" 5 "5")
+(test-numeric-syntax "-1/2" (- (/ 1 2)))
+(test-numeric-syntax "0/10" 0 "0")
 ;; (test-numeric-syntax "#e0/10" 0 "0")
 ;; (test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5")
 ;; ;; Exact complex
@@ -2226,17 +2202,17 @@
 
 ;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH"))
 
-;; (test #t (string? (get-environment-variable "PATH")))
+(test #t (string? (get-environment-variable "PATH")))
 
 ;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables))
 
-;; (let ((env (get-environment-variables)))
-;;   (define (env-pair? x)
-;;     (and (pair? x) (string? (car x)) (string? (cdr x))))
-;;   (define (all? pred ls)
-;;     (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls)))))
-;;   (test #t (list? env))
-;;   (test #t (all? env-pair? env)))
+(let ((env (get-environment-variables)))
+  (define (env-pair? x)
+    (and (pair? x) (string? (car x)) (string? (cdr x))))
+  (define (all? pred ls)
+    (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls)))))
+  (test #t (list? env))
+  (test #t (all? env-pair? env)))
 
 (test #t (list? (command-line)))