Merge branch 'master' into equal

Conflicts:
	src/bool.c

.gitignore

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

.travis.yml

@@ -6,5 +6,5 @@ before_script:
   - cd build
 script:
   - perl --version
-  - cmake .. && make && make no-act
-  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make && make no-act
+  - cmake .. && make test
+  - cmake -DCMAKE_BUILD_TYPE=Debug .. && make no-act

CMakeLists.txt

@@ -39,11 +39,17 @@ include(tools/CMakeLists.txt)
 # $ make run
 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)
 
+# $ 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})

README.md

@@ -49,6 +49,8 @@ Change directory to `build` then run `ccmake` to create Makefile. Once `Makefile
 
 Actually you don't necessarily need to move to `build` directory before running `ccmake` (in that case `$ ccmake .`), but I strongly recommend to follow above instruction.
     
+Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled.
+
 ### Build
 
 A built executable binary will be under bin/ directory and shared libraries under lib/.
@@ -81,7 +83,6 @@ If you execute `cmake` with debug flag `-DCMAKE_BUILD_TYPE=Debug`, it builds the
 Picrin scheme depends on some external libraries to build the binary:
 
 - perl
-- lex (preferably, flex)
 - getopt
 - libedit (optional)
 - regex.h of POSIX.1 (optional)

cmake/FindFLEX.cmake

@@ -1,179 +0,0 @@
-# - Find flex executable and provides a macro to generate custom build rules
-#
-# The module defines the following variables:
-#  FLEX_FOUND - true is flex executable is found
-#  FLEX_EXECUTABLE - the path to the flex executable
-#  FLEX_VERSION - the version of flex
-#  FLEX_LIBRARIES - The flex libraries
-#
-# The minimum required version of flex can be specified using the
-# standard syntax, e.g. FIND_PACKAGE(FLEX 2.5.13)
-#
-#
-# If flex is found on the system, the module provides the macro:
-#  FLEX_TARGET(Name FlexInput FlexOutput [COMPILE_FLAGS <string>])
-# which creates a custom command  to generate the <FlexOutput> file from
-# the <FlexInput> file.  If  COMPILE_FLAGS option is specified, the next
-# parameter is added to the flex  command line. Name is an alias used to
-# get  details of  this custom  command.  Indeed the  macro defines  the
-# following variables:
-#  FLEX_${Name}_DEFINED - true is the macro ran successfully
-#  FLEX_${Name}_OUTPUTS - the source file generated by the custom rule, an
-#  alias for FlexOutput
-#  FLEX_${Name}_INPUT - the flex source file, an alias for ${FlexInput}
-#
-# Flex scanners oftenly use tokens  defined by Bison: the code generated
-# by Flex  depends of the header  generated by Bison.   This module also
-# defines a macro:
-#  ADD_FLEX_BISON_DEPENDENCY(FlexTarget BisonTarget)
-# which  adds the  required dependency  between a  scanner and  a parser
-# where  <FlexTarget>  and <BisonTarget>  are  the  first parameters  of
-# respectively FLEX_TARGET and BISON_TARGET macros.
-#
-#  ====================================================================
-#  Example:
-#
-#   find_package(BISON)
-#   find_package(FLEX)
-#
-#   BISON_TARGET(MyParser parser.y ${CMAKE_CURRENT_BINARY_DIR}/parser.cpp
-#   FLEX_TARGET(MyScanner lexer.l  ${CMAKE_CURRENT_BIANRY_DIR}/lexer.cpp)
-#   ADD_FLEX_BISON_DEPENDENCY(MyScanner MyParser)
-#
-#   include_directories(${CMAKE_CURRENT_BINARY_DIR})
-#   add_executable(Foo
-#      Foo.cc
-#      ${BISON_MyParser_OUTPUTS}
-#      ${FLEX_MyScanner_OUTPUTS}
-#   )
-#  ====================================================================
-
-#=============================================================================
-# Copyright 2009 Kitware, Inc.
-# Copyright 2006 Tristan Carel
-# Modified 2010 by Jon Siwek, backporting for CMake 2.6 compat
-#
-# Distributed under the OSI-approved BSD License (the "License"):
-# CMake - Cross Platform Makefile Generator
-# Copyright 2000-2009 Kitware, Inc., Insight Software Consortium
-# All rights reserved.
-
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that the following conditions
-# are met:
-#
-# * Redistributions of source code must retain the above copyright
-#   notice, this list of conditions and the following disclaimer.
-#
-# * Redistributions in binary form must reproduce the above copyright
-#   notice, this list of conditions and the following disclaimer in the
-#   documentation and/or other materials provided with the distribution.
-#
-# * Neither the names of Kitware, Inc., the Insight Software Consortium,
-#   nor the names of their contributors may be used to endorse or promote
-#   products derived from this software without specific prior written
-#   permission.
-#
-# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-#
-# This software is distributed WITHOUT ANY WARRANTY; without even the
-# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-# See the License for more information.
-#=============================================================================
-
-FIND_PROGRAM(FLEX_EXECUTABLE flex DOC "path to the flex executable")
-MARK_AS_ADVANCED(FLEX_EXECUTABLE)
-
-FIND_LIBRARY(FL_LIBRARY NAMES fl
-  DOC "path to the fl library")
-MARK_AS_ADVANCED(FL_LIBRARY)
-SET(FLEX_LIBRARIES ${FL_LIBRARY})
-
-IF(FLEX_EXECUTABLE)
-
-  EXECUTE_PROCESS(COMMAND ${FLEX_EXECUTABLE} --version
-    OUTPUT_VARIABLE FLEX_version_output
-    ERROR_VARIABLE FLEX_version_error
-    RESULT_VARIABLE FLEX_version_result
-    OUTPUT_STRIP_TRAILING_WHITESPACE)
-  IF(NOT ${FLEX_version_result} EQUAL 0)
-    IF(FLEX_FIND_REQUIRED)
-      MESSAGE(SEND_ERROR "Command \"${FLEX_EXECUTABLE} --version\" failed with output:\n${FLEX_version_output}\n${FLEX_version_error}")
-    ELSE()
-      MESSAGE("Command \"${FLEX_EXECUTABLE} --version\" failed with output:\n${FLEX_version_output}\n${FLEX_version_error}\nFLEX_VERSION will not be available")
-    ENDIF()
-  ELSE()
-    STRING(REGEX REPLACE "^flex (.*)$" "\\1"
-      FLEX_VERSION "${FLEX_version_output}")
-  ENDIF()
-
-  #============================================================
-  # FLEX_TARGET (public macro)
-  #============================================================
-  #
-  MACRO(FLEX_TARGET Name Input Output)
-    SET(FLEX_TARGET_usage "FLEX_TARGET(<Name> <Input> <Output> [COMPILE_FLAGS <string>]")
-    IF(${ARGC} GREATER 3)
-      IF(${ARGC} EQUAL 5)
-        IF("${ARGV3}" STREQUAL "COMPILE_FLAGS")
-          SET(FLEX_EXECUTABLE_opts  "${ARGV4}")
-          SEPARATE_ARGUMENTS(FLEX_EXECUTABLE_opts)
-        ELSE()
-          MESSAGE(SEND_ERROR ${FLEX_TARGET_usage})
-        ENDIF()
-      ELSE()
-        MESSAGE(SEND_ERROR ${FLEX_TARGET_usage})
-      ENDIF()
-    ENDIF()
-
-    ADD_CUSTOM_COMMAND(OUTPUT ${Output}
-      COMMAND ${FLEX_EXECUTABLE}
-      ARGS ${FLEX_EXECUTABLE_opts} -o${Output} ${Input}
-      DEPENDS ${Input}
-      COMMENT "[FLEX][${Name}] Building scanner with flex ${FLEX_VERSION}"
-      WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})
-
-    SET(FLEX_${Name}_DEFINED TRUE)
-    SET(FLEX_${Name}_OUTPUTS ${Output})
-    SET(FLEX_${Name}_INPUT ${Input})
-    SET(FLEX_${Name}_COMPILE_FLAGS ${FLEX_EXECUTABLE_opts})
-  ENDMACRO(FLEX_TARGET)
-  #============================================================
-
-
-  #============================================================
-  # ADD_FLEX_BISON_DEPENDENCY (public macro)
-  #============================================================
-  #
-  MACRO(ADD_FLEX_BISON_DEPENDENCY FlexTarget BisonTarget)
-
-    IF(NOT FLEX_${FlexTarget}_OUTPUTS)
-      MESSAGE(SEND_ERROR "Flex target `${FlexTarget}' does not exists.")
-    ENDIF()
-
-    IF(NOT BISON_${BisonTarget}_OUTPUT_HEADER)
-      MESSAGE(SEND_ERROR "Bison target `${BisonTarget}' does not exists.")
-    ENDIF()
-
-    SET_SOURCE_FILES_PROPERTIES(${FLEX_${FlexTarget}_OUTPUTS}
-      PROPERTIES OBJECT_DEPENDS ${BISON_${BisonTarget}_OUTPUT_HEADER})
-  ENDMACRO(ADD_FLEX_BISON_DEPENDENCY)
-  #============================================================
-
-ENDIF(FLEX_EXECUTABLE)
-
-INCLUDE(FindPackageHandleStandardArgs)
-FIND_PACKAGE_HANDLE_STANDARD_ARGS(FLEX FLEX_EXECUTABLE
-                                       FLEX_VERSION)
-
-# FindFLEX.cmake ends here

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,7 +5,7 @@ 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_LIBRARIES ${REGEX_LIBRARIES})

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,4 +1,5 @@
 file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt)
+list(SORT CONTRIBS)
 foreach(contrib ${CONTRIBS})
   include(${contrib})
 endforeach()

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/capi.rst

@@ -0,0 +1,103 @@
+C API
+=====
+
+You can write Picrin's extension by yourself from both sides of C and Scheme. This page describes the way to control the interpreter from the C world.
+
+Extension Library
+-----------------
+
+If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library.
+
+* contrib/add/CMakeLists.txt
+
+.. sourcecode:: cmake
+
+  list(APPEND PICRIN_CONTRIB_INITS "void pic_init_add(pic_state *)\; pic_init_add(pic)\;")
+  list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c)
+
+* contrib/add/add.c
+
+.. sourcecode:: c
+
+  #include "picrin.h"
+
+  static pic_value
+  pic_add(pic_state *pic)
+  {
+    double a, b;
+
+    pic_get_args(pic, "ff", &a, &b);
+
+    return pic_float_value(a + b);
+  }
+
+  void
+  pic_init_add(pic_state *pic)
+  {
+    pic_deflibrary ("(picrin add)") {
+      pic_defun(pic, "add", pic_add);
+    }
+  }
+
+After recompiling the interpreter, the library "(picrin add)" is available in the REPL, which library provides a funciton "add".
+
+User-data vs GC
+^^^^^^^^^^^^^^^
+
+When you use dynamic memory allocation inside C APIs, you must be caseful about Picrin's GC. Fortunately, we provides a set of wrapper functions for complete abstraction of GC. In the case below, the memory (de)allocators *create_foo* and *finalize_foo* are wrapped in pic_data object, so that when an instance of foo losts all references from others to it picrin can automatically finalize the orphan object.
+
+.. sourcecode:: c
+
+  /** foo.c **/
+  #include <stdlib.h>
+  #include "picrin.h"
+  #include "picrin/data.h"
+
+  /*
+   * C-side API
+   */
+
+  struct foo {
+    // blah blah blah
+  };
+
+  struct foo *
+  create_foo ()
+  {
+    return malloc(sizeof(struct foo));
+  }
+
+  void
+  finalize_foo (void *foo) {
+    struct foo *f = foo;
+    free(f);
+  }
+
+
+  /*
+   * picrin-side FFI interface
+   */
+
+  static const pic_data_type foo_type = { "foo", finalize_foo };
+
+  static pic_value
+  pic_create_foo(pic_state *pic)
+  {
+    struct foo *f;
+    struct pic_data *dat;
+
+    pic_get_args(pic, ""); // no args here
+
+    f = create_foo();
+
+    data = pic_data_alloc(pic, &foo_type, md);
+
+    return pic_obj_value(data);
+  }
+
+  void
+  pic_init_foo(pic_state *pic)
+  {
+    pic_defun(pic, "create-foo", pic_create_foo); // (create-foo)
+  }
+

docs/deploy.rst

@@ -25,6 +25,8 @@ Change directory to `build` then run `ccmake` to create Makefile. Once `Makefile
 
 Actually you don't necessarily need to move to `build` directory before running `ccmake` (in that case `$ ccmake .`), but I strongly recommend to follow above instruction.
 
+Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled.
+
 Build
 ^^^^^
 
@@ -62,7 +64,6 @@ Requirement
 Picrin scheme depends on some external libraries to build the binary:
 
 - perl
-- lex (preferably, flex)
 - getopt
 - readline (optional)
 - regex.h of POSIX.1 (optional)

docs/index.rst

@@ -15,6 +15,7 @@ Contents:
    deploy.rst
    lang.rst
    libs.rst
+   capi.rst
 
 Indices and tables
 ==================

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,7 +58,7 @@ 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

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,19 @@ Utility functions and syntaces for macro definition.
 
 - define-macro
 - gensym
-- macroexpand expr
+- macroexpand
 
 Old-fashioned macro.
 
-- make-syntactic-closure
 - identifier?
 - identifier=?
 
+- make-syntactic-closure
+- close-syntax
+
+- sc-macro-transformer
+- rsc-macro-transformer
+
 Syntactic closures.
 
 - er-macro-transformer
@@ -79,6 +96,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 +213,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 +237,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/mkloader.pl

@@ -3,6 +3,13 @@
 use strict;
 
 print <<EOL;
+/**
+ *                                !!NOTICE!!
+ * This file was automatically generated by mkloader.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"
 #include "picrin/error.h"
 

extlib/xfile

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

extlib/xrope

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

include/picrin.h

@@ -81,11 +81,17 @@ typedef struct {
   pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
   pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
+  pic_sym sLET_SYNTAX, sLETREC_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, rDEFINE_MACRO;
+  pic_sym rLET_SYNTAX, rLETREC_SYNTAX;
+  pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
+
   xhash syms;                   /* name to symbol */
   xhash sym_names;              /* symbol to name */
   int sym_cnt;
@@ -100,6 +106,8 @@ typedef struct {
   pic_value lib_tbl;
   struct pic_lib *lib;
 
+  xhash rlabels;
+
   jmp_buf *jmp;
   struct pic_error *err;
   struct pic_jmpbuf *try_jmps;
@@ -125,6 +133,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 *);
@@ -133,11 +148,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);
 
@@ -150,7 +166,8 @@ bool pic_interned_p(pic_state *, pic_sym);
 char *pic_strdup(pic_state *, const char *);
 char *pic_strndup(pic_state *, const char *, size_t);
 
-pic_value pic_read(pic_state *, const char *);
+pic_value pic_read(pic_state *, struct pic_port *);
+pic_value pic_read_cstr(pic_state *, const char *);
 pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */
 pic_list pic_parse_cstr(pic_state *, const char *);
 
@@ -178,7 +195,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value);
 #define pic_deflibrary_helper__(i, prev_lib, spec)                      \
   for (int i = 0; ! i; )                                                \
     for (struct pic_lib *prev_lib; ! i; )                               \
-      for ((prev_lib = pic->lib), pic_make_library(pic, pic_read(pic, spec)), pic_in_library(pic, pic_read(pic, spec)); ! i++; pic->lib = prev_lib)
+      for ((prev_lib = pic->lib), pic_make_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib)
 
 void pic_import(pic_state *, pic_value);
 void pic_export(pic_state *, pic_sym);

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/macro.h

@@ -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,14 @@ 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);
+
 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);

include/picrin/parse.h

@@ -1,46 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#ifndef PICRIN_PARSE_H__
-#define PICRIN_PARSE_H__
-
-#if defined(__cplusplus)
-extern "C" {
-#endif
-
-enum {
-  tEOF = 0,
-  tLABEL_SET, tLABEL_REF, tDATUM_COMMENT,
-  tLPAREN, tRPAREN, tLBRACKET, tRBRACKET, tDOT, tVPAREN,
-  tQUOTE, tQUASIQUOTE, tUNQUOTE, tUNQUOTE_SPLICING,
-  tINT, tBOOLEAN,
-  tFLOAT,
-  tSYMBOL, tSTRING,
-  tCHAR,
-  tBYTEVECTOR,
-};
-
-typedef union YYSTYPE {
-  int i;
-  double f;
-  struct {
-    char *dat;
-    size_t len;
-  } buf;
-  char c;
-} YYSTYPE;
-
-struct parser_control {
-  pic_state *pic;
-  YYSTYPE yylval;
-  xhash labels;
-  jmp_buf jmp;
-  const char *msg;
-};
-
-#if defined(__cplusplus)
-}
-#endif
-
-#endif

include/picrin/port.h

@@ -37,6 +37,7 @@ struct pic_port *pic_stdin(pic_state *);
 struct pic_port *pic_stdout(pic_state *);
 struct pic_port *pic_stderr(pic_state *);
 
+struct pic_port *pic_open_input_string(pic_state *, const char *);
 struct pic_port *pic_open_output_string(pic_state *);
 struct pic_string *pic_get_output_string(pic_state *, struct pic_port *);
 

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
 };
 
@@ -158,6 +156,7 @@ typedef struct pic_blob pic_blob;
 #define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT)
 #define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL)
 #define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR)
+#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF)
 
 #define pic_test(v) (! pic_false_p(v))
 
@@ -255,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:
@@ -269,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";
   }
@@ -443,6 +438,8 @@ pic_eq_p(pic_value x, pic_value y)
   switch (pic_type(x)) {
   case PIC_TT_NIL:
     return true;
+  case PIC_TT_BOOL:
+    return pic_vtype(x) == pic_vtype(y);
   case PIC_TT_SYMBOL:
     return pic_sym(x) == pic_sym(y);
   default:
@@ -459,6 +456,8 @@ pic_eqv_p(pic_value x, pic_value y)
   switch (pic_type(x)) {
   case PIC_TT_NIL:
     return true;
+  case PIC_TT_BOOL:
+    return pic_vtype(x) == pic_vtype(y);
   case PIC_TT_SYMBOL:
     return pic_sym(x) == pic_sym(y);
   case PIC_TT_FLOAT:

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,12 @@
 list(APPEND PICLIB_SCHEME_LIBS
-  ${PROJECT_SOURCE_DIR}/piclib/built-in.scm
+  ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.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/prelude.scm

@@ -36,7 +36,64 @@
 
 ;;; hygienic macros
 (define-library (picrin macro)
-  (import (scheme base))
+  (import (scheme base)
+          (picrin dictionary))
+
+  (define (memq obj list)
+    (if (null? list)
+        #f
+        (if (eq? obj (car list))
+            list
+            (memq obj (cdr list)))))
+
+  (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 (vector-map proc expr)
+    (list->vector (map proc (vector->list expr))))
+
+  (define (walk proc expr)
+    (if (null? expr)
+        '()
+        (if (pair? expr)
+            (cons (walk proc (car expr))
+                  (walk proc (cdr expr)))
+            (if (vector? expr)
+                (vector-map proc expr)
+                (proc expr)))))
+
+  (define (make-syntactic-closure form free env)
+    (define cache (make-dictionary))
+    (walk
+     (lambda (atom)
+       (if (not (symbol? atom))
+           atom
+           (if (memq atom free)
+               atom
+               (if (dictionary-has? cache atom)
+                   (dictionary-ref cache atom)
+                   (begin
+                     (define id (make-identifier atom env))
+                     (dictionary-set! cache atom id)
+                     id)))))))
+
+  (define (close-syntax form env)
+    (make-syntactic-closure form '() env))
 
   (define (sc-macro-transformer f)
     (lambda (expr use-env mac-env)
@@ -46,8 +103,86 @@
     (lambda (expr use-env mac-env)
       (make-syntactic-closure use-env '() (f expr mac-env))))
 
-  (export sc-macro-transformer
-          rsc-macro-transformer))
+  (define (er-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define cache (make-dictionary))
+
+      (define (rename sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym mac-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (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 protects (make-dictionary))
+
+      (define (wrap expr)
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (begin
+                 (define id (make-identifier atom use-env))
+                 (dictionary-set! protects id atom) ; lookup *atom* from id
+                 id)))
+         expr))
+
+      (define (unwrap expr)
+        (define cache (make-dictionary))
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (if (dictionary-has? protects atom)
+                   (dictionary-ref protects atom)
+                   (if (dictionary-has? cache atom)
+                       (dictionary-ref cache atom)
+                       (begin
+                         ;; implicit renaming
+                         (define id (make-identifier atom mac-env))
+                         (dictionary-set! cache atom id)
+                         id)))))
+         expr))
+
+      (define cache (make-dictionary))
+
+      (define (inject sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym use-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? mac-env x mac-env y))))
+
+      (unwrap (f (wrap expr) inject compare))))
+
+  (export make-syntactic-closure
+          close-syntax
+          sc-macro-transformer
+          rsc-macro-transformer
+          er-macro-transformer
+          ir-macro-transformer))
 
 ;;; core syntaces
 (define-library (picrin core-syntax)
@@ -55,6 +190,20 @@
           (scheme cxr)
           (picrin macro))
 
+  (define-syntax define-auxiliary-syntax
+    (er-macro-transformer
+     (lambda (expr r c)
+       (list (r 'define-syntax) (cadr expr)
+             (list (r 'lambda) '_
+                   (list (r 'error) "invalid use of auxiliary syntax"))))))
+
+  (define-auxiliary-syntax 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)
@@ -84,9 +233,9 @@
                  (if (if (>= (length (car clauses)) 2)
                          (compare (r '=>) (cadar clauses))
                          #f)
-                     (list (r 'let) (list (list 'x (caar clauses)))
-                           (list (r 'if) 'x
-                                 (list (caddar clauses) 'x)
+                     (list (r 'let) (list (list (r 'x) (caar clauses)))
+                           (list (r 'if) (r 'x)
+                                 (list (caddar clauses) (r 'x))
                                  (cons (r 'cond) (cdr clauses))))
                      (list (r 'if) (caar clauses)
                            (cons (r 'begin) (cdar clauses))
@@ -136,6 +285,22 @@
   (define (unquote-splicing? form compare?)
     (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
 
+  (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 (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)
@@ -170,6 +335,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))))
@@ -273,31 +441,28 @@
                           `(,(r 'begin) ,@(cdar clauses)))
                         ,(loop (cdr clauses))))))))))
 
+  (define-syntax letrec-syntax
+    (er-macro-transformer
+     (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 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)
-       `(,(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)
-
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or
           cond case else =>
           do when unless
+          letrec-syntax
           _ ... syntax-error))
 
 
@@ -324,24 +489,63 @@
      (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 (predefine var)
+    `(define ,var #f))
+
+  (define (predefines vars)
+    (map predefine vars))
+
+  (define (assign var val)
+    `(set! ,var ,val))
+
+  (define (assigns vars vals)
+    (map assign vars vals))
+
+  (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
+            ,@(predefines (flatten formal))
+            (call-with-values (lambda () ,@exprs)
+              (lambda ,formal*
+                ,@(assigns (flatten formal) (flatten formal*)))))))))
 
   (export let-values
           let*-values
@@ -352,33 +556,70 @@
   (import (scheme base)
           (scheme cxr)
           (picrin macro)
-          (picrin core-syntax))
+          (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)
@@ -534,6 +775,7 @@
         and or
         cond case else =>
         do when unless
+        letrec-syntax
         _ ... syntax-error)
 
 (export let-values
@@ -719,14 +961,20 @@
   (apply vector list))
 
 (define (vector-copy! to at from . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (vector-length from))))
-    (do ((i at (+ i 1))
-	 (j start (+ j 1)))
-	((= j end))
-      (vector-set! to i (vector-ref from j)))))
+  (let* ((start (if (pair? opts) (car opts) 0))
+         (end (if (>= (length opts) 2)
+                  (cadr opts)
+                  (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))))))
 
 (define (vector-copy v . opts)
   (let ((start (if (pair? opts) (car opts) 0))
@@ -778,14 +1026,20 @@
 	(bytevector-u8-set! v i (car l))))))
 
 (define (bytevector-copy! to at from . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
+  (let* ((start (if (pair? opts) (car opts) 0))
+         (end (if (>= (length opts) 2)
 		 (cadr opts)
-		 (bytevector-length from))))
-    (do ((i at (+ i 1))
-	 (j start (+ j 1)))
-	((= j end))
-      (bytevector-u8-set! to i (bytevector-u8-ref from j)))))
+		 (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))))))
 
 (define (bytevector-copy v . opts)
   (let ((start (if (pair? opts) (car opts) 0))
@@ -880,6 +1134,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,6 +1152,40 @@
 
 (export call-with-port)
 
+(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))
+
+;;; include syntax
+
+(import (scheme read)
+        (scheme file))
+
+(define (read-many filename)
+  (call-with-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 include
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (let ((filenames (cdr form)))
+       (let ((exprs (apply append (map read-many filenames))))
+         `(,(rename 'begin) ,@exprs))))))
+
+(export include)
+
 ;;; Appendix A. Standard Libraries Lazy
 (define-library (scheme lazy)
   (import (scheme base)
@@ -926,7 +1224,7 @@
   (define (make-promise obj)
     (if (promise? obj)
 	obj
-	(make-promise% #f obj)))
+	(make-promise% #t obj)))
 
   (export delay-force delay force make-promise promise?))
 
@@ -1063,7 +1361,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 +1423,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) '()))
@@ -1255,3 +1553,33 @@
 
 (import (picrin syntax-rules))
 (export syntax-rules)
+
+(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/srfi/1.scm

@@ -1,6 +1,6 @@
 (define-library (srfi 1)
   (import (scheme base)
-	  (scheme cxr))
+          (scheme cxr))
 
   ;; # Constructors
   ;; cons list
@@ -15,32 +15,32 @@
   (define (cons* x . args)
     (let rec ((acc '()) (x x) (lst args))
       (if (null? lst)
-	  (append-reverse acc x)
-	  (rec (cons x acc) (car lst) (cdr lst)))))
+          (append-reverse acc x)
+          (rec (cons x acc) (car lst) (cdr lst)))))
 
   (define (list-tabulate n init-proc)
     (let rec ((acc '()) (n (- n 1)))
       (if (zero? n)
-	  (cons n acc)
-	  (rec (cons n acc) (- n 1)))))
+          (cons n acc)
+          (rec (cons n acc) (- n 1)))))
 
   (define (circular-list elt . args)
     (let ((lst (cons elt args)))
       (let rec ((l lst))
-	(if (null? (cdr l))
-	    (set-cdr! l lst)
-	    (rec (cdr l))))
+        (if (null? (cdr l))
+            (set-cdr! l lst)
+            (rec (cdr l))))
       lst))
 
   (define (iota count . lst)
     (let ((start (if (pair? lst) (car lst) 0))
-	  (step (if (and (pair? lst) (pair? (cdr lst)))
-		    (cadr lst) 1)))
+          (step (if (and (pair? lst) (pair? (cdr lst)))
+                    (cadr lst) 1)))
       (let rec ((count (- count 1)) (acc '()))
-	(if (zero? count)
-	    (cons start acc)
-	    (rec (- count 1)
-		 (cons (+ start (* count step)) acc))))))
+        (if (zero? count)
+            (cons start acc)
+            (rec (- count 1)
+                 (cons (+ start (* count step)) acc))))))
 
   (export cons list xcons make-list list-tabulate list-copy circular-list iota)
 
@@ -55,38 +55,38 @@
   (define (circular-list? x)
     (let rec ((rapid x) (local x))
       (if (and (pair? rapid) (pair? (cdr rapid)))
-        (if (eq? (cddr rapid) (cdr local))
-          #t
-          (rec (cddr rapid) (cdr local)))
-        #f)))
+          (if (eq? (cddr rapid) (cdr local))
+              #t
+              (rec (cddr rapid) (cdr local)))
+          #f)))
 
   (define proper-list? list?)
 
   (define (dotted-list? x)
     (and (pair? x)
-	 (not (proper-list? x))
-	 (not (circular-list? x))))
+         (not (proper-list? x))
+         (not (circular-list? x))))
 
   (define (null-list? x)
     (cond ((pair? x) #f)
-	  ((null? x) #t)
-	  (else (error "null-list?: argument out of domain" x))))
+          ((null? x) #t)
+          (else (error "null-list?: argument out of domain" x))))
 
   (define (list= elt= . lists)
     (or (null? lists)
-	(let rec1 ((list1 (car lists)) (others (cdr lists)))
-	  (or (null? others)
-	      (let ((list2 (car others))
-		    (others (cdr others)))
-		(if (eq? list1 list2)
-		    (rec1 list2 others)
-		    (let rec2 ((l1 list1) (l2 list2))
-		      (if (null-list? l1)
-			  (and (null-list? l2)
-			       (rec1 list2 others))
-			  (and (not (null-list? l2))
-			       (elt= (car l1) (car l2))
-			       (rec2 (cdr l1) (cdr l2)))))))))))
+        (let rec1 ((list1 (car lists)) (others (cdr lists)))
+          (or (null? others)
+              (let ((list2 (car others))
+                    (others (cdr others)))
+                (if (eq? list1 list2)
+                    (rec1 list2 others)
+                    (let rec2 ((l1 list1) (l2 list2))
+                      (if (null-list? l1)
+                          (and (null-list? l2)
+                               (rec1 list2 others))
+                          (and (not (null-list? l2))
+                               (elt= (car l1) (car l2))
+                               (rec2 (cdr l1) (cdr l2)))))))))))
 
   (export pair? null? not-pair? proper-list? circular-list? null-list? list=)
 
@@ -124,17 +124,17 @@
   (define (take! x i)
     (let rec ((lis x) (n (- i 1)))
       (if (zero? n)
-	  (begin (set-cdr! lis '()) x)
-	  (rec (cdr lis) (- n 1)))))
+          (begin (set-cdr! lis '()) x)
+          (rec (cdr lis) (- n 1)))))
 
   (define (drop-right! flist i)
     (let ((lead (drop flist i)))
       (if (not-pair? lead)
-	  '()
-	  (let rec ((lis1 flist) (lis2 (cdr lead)))
-	    (if (pair? lis2)
-		(rec (cdr lis1) (cdr lis2))
-		(begin (set-cdr! lis1 '()) flist))))))
+          '()
+          (let rec ((lis1 flist) (lis2 (cdr lead)))
+            (if (pair? lis2)
+                (rec (cdr lis1) (cdr lis2))
+                (begin (set-cdr! lis1 '()) flist))))))
 
   (define (split-at x i)
     (values (take x i) (drop x i)))
@@ -167,12 +167,12 @@
 
 
   (export car cdr car+cdr list-ref
-	  caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
-	  caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
-	  cdadar cdaddr cddaar cddadr cdddar cddddr
-	  first second third fourth fifth sixth seventh eighth ninth tenth
+          caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
+          cdadar cdaddr cddaar cddadr cdddar cddddr
+          first second third fourth fifth sixth seventh eighth ninth tenth
           take drop take-right drop-right take! drop-right!
-	  split-at split-at! last last-pair)
+          split-at split-at! last last-pair)
 
   ;; # Miscellaneous
   ;; length length+
@@ -183,19 +183,19 @@
   ;; count
   (define (length+ lst)
     (if (not (circular-list? lst))
-	(length lst)))
+        (length lst)))
 
   (define (concatenate lists)
     (apply append lists))
 
   (define (append! . lists)
     (if (null? lists)
-	'()
-	(let rec ((lst lists))
-	  (if (not-pair? (cdr lst))
-	      (car lst)
-	      (begin (set-cdr! (last-pair (car lst)) (cdr lst))
-		     (rec (cdr lst)))))))
+        '()
+        (let rec ((lst lists))
+          (if (not-pair? (cdr lst))
+              (car lst)
+              (begin (set-cdr! (last-pair (car lst)) (cdr lst))
+                     (rec (cdr lst)))))))
 
   (define (concatenate! lists)
     (apply append! lists))
@@ -203,10 +203,10 @@
   (define (reverse! list)
     (let rec ((lst list) (acc '()))
       (if (null? lst)
-	  acc
-	  (let ((rst (cdr lst)))
-	    (set-cdr! lst acc)
-	    (rec rst lst)))))
+          acc
+          (let ((rst (cdr lst)))
+            (set-cdr! lst acc)
+            (rec rst lst)))))
 
   (set! append-reverse
         (lambda (rev-head tail)
@@ -217,9 +217,9 @@
   (define (append-reverse! rev-head tail)
     (let ((rst (cdr rev-head)))
       (if (null? rev-head)
-	  tail
-	  (begin (set-cdr! rev-head tail)
-		 (append-reverse! rst rev-head)))))
+          tail
+          (begin (set-cdr! rev-head tail)
+                 (append-reverse! rst rev-head)))))
 
   (define (zip . lists)
     (apply map list lists))
@@ -229,37 +229,37 @@
 
   (define (unzip2 list)
     (values (map first list)
-	    (map second list)))
+            (map second list)))
 
   (define (unzip3 list)
     (values (map first list)
-	    (map second list)
-	    (map third list)))
+            (map second list)
+            (map third list)))
 
   (define (unzip4 list)
     (values (map first list)
-	    (map second list)
-	    (map third list)
-	    (map fourth list)))
+            (map second list)
+            (map third list)
+            (map fourth list)))
 
   (define (unzip5 list)
     (values (map first list)
-	    (map second list)
-	    (map third list)
-	    (map fourth list)
-	    (map fifth list)))
+            (map second list)
+            (map third list)
+            (map fourth list)
+            (map fifth list)))
 
   (define (count pred . clists)
     (let rec ((tflst (apply map pred clists)) (n 0))
       (if (null? tflst)
-	  n
-	  (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))
+          n
+          (rec (cdr tflst) (if (car tflst) (+ n 1) n)))))
 
   (export length length+
-	  append append! concatenate concatenate!
-	  reverse reverse! append-reverse append-reverse!
-	  zip unzip1 unzip2 unzip3 unzip4 unzip5
-	  count)
+          append append! concatenate concatenate!
+          reverse reverse! append-reverse append-reverse!
+          zip unzip1 unzip2 unzip3 unzip4 unzip5
+          count)
 
   ;; # Fold, unfold & map
   ;; map for-each
@@ -273,80 +273,80 @@
 
   (define (fold kons knil clist . clists)
     (if (null? clists)
-	(let rec ((acc knil) (clist clist))
-	  (if (null? clist)
-	      acc
-	      (rec (kons (car clist) acc) (cdr clist))))
-	(let rec ((acc knil) (clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (rec (apply kons (append (map car clists) (list acc)))
-		   (map cdr clists))
-	      acc))))
+        (let rec ((acc knil) (clist clist))
+          (if (null? clist)
+              acc
+              (rec (kons (car clist) acc) (cdr clist))))
+        (let rec ((acc knil) (clists (cons clist clists)))
+          (if (every pair? clists)
+              (rec (apply kons (append (map car clists) (list acc)))
+                   (map cdr clists))
+              acc))))
 
   (define (fold-right kons knil clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (cont values))
-	  (if (null? clist)
-	      (cont knil)
-	      (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))
-	(let rec ((clists (cons clist clists)) (cont values))
-	  (if (every pair? clists)
-	      (rec (map cdr clists)
-		   (lambda (x)
-		     (cont (apply kons (append (map car clists) (list x))))))
-	      (cont knil)))))
+        (let rec ((clist clist) (cont values))
+          (if (null? clist)
+              (cont knil)
+              (rec (cdr clist) (lambda (x) (cont (kons (car clist) x))))))
+        (let rec ((clists (cons clist clists)) (cont values))
+          (if (every pair? clists)
+              (rec (map cdr clists)
+                   (lambda (x)
+                     (cont (apply kons (append (map car clists) (list x))))))
+              (cont knil)))))
 
   (define (pair-fold kons knil clist . clists)
     (if (null? clists)
-	(let rec ((acc knil) (clist clist))
-	  (if (null? clist)
-	      acc
-	      (let ((tail (cdr clist)))
-		(rec (kons clist acc) tail))))
-	(let rec ((acc knil) (clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (let ((tail (map cdr clists)))
-		(rec (apply kons (append clists (list acc)))
-		     tail))
-	      acc))))
+        (let rec ((acc knil) (clist clist))
+          (if (null? clist)
+              acc
+              (let ((tail (cdr clist)))
+                (rec (kons clist acc) tail))))
+        (let rec ((acc knil) (clists (cons clist clists)))
+          (if (every pair? clists)
+              (let ((tail (map cdr clists)))
+                (rec (apply kons (append clists (list acc)))
+                     tail))
+              acc))))
 
   (define (pair-fold-right kons knil clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (cont values))
-	  (if (null? clist)
-	      (cont knil)
-	      (let ((tail (map cdr clists)))
-		(rec tail (lambda (x) (cont (kons clist x)))))))
-	(let rec ((clists (cons clist clists)) (cont values))
-	  (if (every pair? clists)
-	      (let ((tail (map cdr clists)))
-		(rec tail
-		     (lambda (x)
-		       (cont (apply kons (append clists (list x)))))))
-	      (cont knil)))))
+        (let rec ((clist clist) (cont values))
+          (if (null? clist)
+              (cont knil)
+              (let ((tail (map cdr clists)))
+                (rec tail (lambda (x) (cont (kons clist x)))))))
+        (let rec ((clists (cons clist clists)) (cont values))
+          (if (every pair? clists)
+              (let ((tail (map cdr clists)))
+                (rec tail
+                     (lambda (x)
+                       (cont (apply kons (append clists (list x)))))))
+              (cont knil)))))
 
   (define (reduce f ridentity list)
     (if (null? list)
-	ridentity
-	(fold f (car list) (cdr list))))
+        ridentity
+        (fold f (car list) (cdr list))))
 
   (define (reduce-right f ridentity list)
     (fold-right f ridentity list))
 
   (define (unfold p f g seed . tail-gen)
     (let ((tail-gen (if (null? tail-gen)
-			(lambda (x) '())
-			(car tail-gen))))
+                        (lambda (x) '())
+                        (car tail-gen))))
       (let rec ((seed seed) (cont values))
-	(if (p seed)
-	    (cont (tail-gen seed))
-	    (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))
+        (if (p seed)
+            (cont (tail-gen seed))
+            (rec (g seed) (lambda (x) (cont (cons (f seed) x))))))))
 
   (define (unfold-right p f g seed . tail)
     (let rec ((seed seed) (lst tail))
       (if (p seed)
-	  lst
-	  (rec (g seed) (cons (f seed) lst)))))
+          lst
+          (rec (g seed) (cons (f seed) lst)))))
 
   (define (append-map f . clists)
     (apply append (apply map f clists)))
@@ -356,63 +356,54 @@
 
   (define (pair-for-each f clist . clists)
     (if (null? clist)
-	(let rec ((clist clist))
-	  (if (pair? clist)
-	      (begin (f (car clist)) (rec (cdr clist)))))
-	(let rec ((clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (begin (apply f (map car clists)) (rec (map cdr clists)))))))
+        (let rec ((clist clist))
+          (if (pair? clist)
+              (begin (f clist) (rec (cdr clist)))))
+        (let rec ((clists (cons clist clists)))
+          (if (every pair? clists)
+              (begin (apply f clists) (rec (map cdr clists)))))))
 
   (define (map! f list . lists)
     (if (null? lists)
-	(pair-for-each (lambda (x) (set-car! x (f (car x)))) list)
-	(let rec ((list list) (lists lists))
-	  (if (pair? list)
-	      (let ((head (map car lists))
-		    (rest (map cdr lists)))
-		(set-car! list (apply f (car list) head))
-		(rec (cdr list) rest)))))
+        (pair-for-each (lambda (x) (set-car! x (f (car x)))) list)
+        (let rec ((list list) (lists lists))
+          (if (pair? list)
+              (let ((head (map car lists))
+                    (rest (map cdr lists)))
+                (set-car! list (apply f (car list) head))
+                (rec (cdr list) rest)))))
     list)
 
   (define (map-in-order f clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (acc '()))
-	  (if (null? clist)
-	      (reverse! acc)
-	      (rec (cdr clist) (cons (f (car clist)) acc))))
-	(let rec ((clists (cons clist clists)) (acc '()))
-	  (if (every pair? clists)
-	      (rec (map cdr clists)
-		   (cons* (apply f (map car clists)) acc))
-	      (reverse! acc)))))
+        (let rec ((clist clist) (acc '()))
+          (if (null? clist)
+              (reverse! acc)
+              (rec (cdr clist) (cons (f (car clist)) acc))))
+        (let rec ((clists (cons clist clists)) (acc '()))
+          (if (every pair? clists)
+              (rec (map cdr clists)
+                   (cons* (apply f (map car clists)) acc))
+              (reverse! acc)))))
 
   (define (filter-map f clist . clists)
-    (if (null? clists)
-	(let rec ((clist clist) (cont values))
-	  (if (null? clist)
-	      (cont '())
-	      (rec (cdr clist)
-		   (let ((it (f (car clist))))
-		     (if it
-			 (lambda (x) (cont (cons it x)))
-			 (lambda (x) (cont x)))))))))
+    (let recur ((l (apply map f clist clists)))
+      (cond ((null? l) '())
+            ((car l)   (cons (car l) (recur (cdr l))))
+            (else      (recur (cdr l))))))
 
   (export map for-each
-	  fold unfold pair-fold reduce
-	  fold-right unfold-right pair-fold-right reduce-right
-	  append-map append-map!
-	  map! pair-for-each filter-map map-in-order)
+          fold unfold pair-fold reduce
+          fold-right unfold-right pair-fold-right reduce-right
+          append-map append-map!
+          map! pair-for-each filter-map map-in-order)
 
   ;; # Filtering & partitioning
   ;; filter partition remove
   ;; filter! partition! remove!
   (define (filter pred list)
-    (if (null? list)
-        '()
-        (if (pred (car list))
-            (cons (car list)
-                  (filter pred (cdr list)))
-            (filter pred (cdr list)))))
+    (let ((pcons (lambda (v acc) (if (pred v) (cons v acc) acc))))
+      (reverse (fold pcons '() list))))
 
   (define (remove pred list)
     (filter (lambda (x) (not (pred x))) list))
@@ -424,21 +415,21 @@
   (define (filter! pred list)
     (let rec ((lst list))
       (if (null? lst)
-	  lst
-	  (if (pred (car lst))
-	      (begin (set-cdr! lst (rec (cdr lst)))
-		     lst)
-	      (rec (cdr lst))))))
+          lst
+          (if (pred (car lst))
+              (begin (set-cdr! lst (rec (cdr lst)))
+                     lst)
+              (rec (cdr lst))))))
 
   (define (remove! pred list)
     (filter! (lambda (x) (not (pred x))) list))
 
   (define (partition! pred list)
     (values (filter! pred list)
-	    (remove! pred list)))
+            (remove! pred list)))
 
   (export filter partition remove
-	  filter! partition! remove!)
+          filter! partition! remove!)
 
   ;; # Searching
   ;; member memq memv
@@ -464,55 +455,55 @@
   (define (take-while pred clist)
     (let rec ((clist clist) (cont values))
       (if (null? clist)
-	  (cont '())
-	  (if (pred (car clist))
-	      (rec (cdr clist)
-		   (lambda (x) (cont (cons (car clist) x))))
-	      (cont '())))))
+          (cont '())
+          (if (pred (car clist))
+              (rec (cdr clist)
+                   (lambda (x) (cont (cons (car clist) x))))
+              (cont '())))))
 
   (define (take-while! pred clist)
     (let rec ((clist clist))
       (if (null? clist)
-	  '()
-	  (if (pred (car clist))
-	      (begin (set-cdr! clist (rec (cdr clist)))
-		     clist)
-	      '()))))
+          '()
+          (if (pred (car clist))
+              (begin (set-cdr! clist (rec (cdr clist)))
+                     clist)
+              '()))))
 
   (define (drop-while pred clist)
     (let rec ((clist clist))
       (if (null? clist)
-	  '()
-	  (if (pred (car clist))
-	      (rec (cdr clist))
-	      clist))))
+          '()
+          (if (pred (car clist))
+              (rec (cdr clist))
+              clist))))
 
   (define (span pred clist)
     (values (take-while pred clist)
-	    (drop-while pred clist)))
+            (drop-while pred clist)))
 
   (define (span! pred clist)
     (values (take-while! pred clist)
-	    (drop-while pred clist)))
+            (drop-while pred clist)))
 
   (define (break pred clist)
     (values (take-while (lambda (x) (not (pred x))) clist)
-	    (drop-while (lambda (x) (not (pred x))) clist)))
+            (drop-while (lambda (x) (not (pred x))) clist)))
 
   (define (break! pred clist)
     (values (take-while! (lambda (x) (not (pred x))) clist)
-	    (drop-while (lambda (x) (not (pred x))) clist)))
+            (drop-while (lambda (x) (not (pred x))) clist)))
 
   (define (any pred clist . clists)
     (if (null? clists)
-	(let rec ((clist clist))
-	  (if (pair? clist)
-	      (or (pred (car clist))
-		  (rec (cdr clist)))))
-	(let rec ((clists (cons clist clists)))
-	  (if (every pair? clists)
-	      (or (apply pred (map car clists))
-		  (rec (map cdr clists)))))))
+        (let rec ((clist clist))
+          (if (pair? clist)
+              (or (pred (car clist))
+                  (rec (cdr clist)))))
+        (let rec ((clists (cons clist clists)))
+          (if (every pair? clists)
+              (or (apply pred (map car clists))
+                  (rec (map cdr clists)))))))
 
   (set! every
         (lambda (pred clist . clists)
@@ -528,23 +519,23 @@
 
   (define (list-index pred clist . clists)
     (if (null? clists)
-	(let rec ((clist clist) (n 0))
-	  (if (pair? clist)
-	      (if (pred (car clist))
-		  n
-		  (rec (cdr clist) (+ n 1)))))
-	(let rec ((clists (cons clist clists)) (n 0))
-	  (if (every pair? clists)
-	      (if (apply pred (map car clists))
-		  n
-		  (rec (map cdr clists) (+ n 1)))))))
+        (let rec ((clist clist) (n 0))
+          (if (pair? clist)
+              (if (pred (car clist))
+                  n
+                  (rec (cdr clist) (+ n 1)))))
+        (let rec ((clists (cons clist clists)) (n 0))
+          (if (every pair? clists)
+              (if (apply pred (map car clists))
+                  n
+                  (rec (map cdr clists) (+ n 1)))))))
 
   (export member memq memv
-	  find find-tail
-	  any every
-	  list-index
-	  take-while drop-while take-while!
-	  span break span! break!)
+          find find-tail
+          any every
+          list-index
+          take-while drop-while take-while!
+          span break span! break!)
 
   ;; # Deleting
   ;; delete delete-duplicates
@@ -559,26 +550,26 @@
 
   (define (delete-duplicates list . =)
     (let ((= (if (null? =) equal? (car =))))
-      (let rec ((list list))
-	(if (null? list)
-	    list
-	    (let* ((x (car list))
-		   (rest (cdr list))
-		   (deleted (rec (delete x list =))))
-	      (if (eq? rest deleted) list (cons x deleted)))))))
+      (let rec ((list list) (cont values))
+        (if (null? list)
+            (cont '())
+            (let* ((x (car list))
+                   (rest (cdr list))
+                   (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))
-	(if (null? list)
-	    list
-	    (let* ((x (car list))
-		   (rest (cdr list))
-		   (deleted (rec (delete! x list =))))
-	      (if (eq? rest deleted) list (cons x deleted)))))))
+      (let rec ((list list) (cont values))
+        (if (null? list)
+            (cont '())
+            (let* ((x (car list))
+                   (rest (cdr list))
+                   (deleted (delete! x list =)))
+              (rec deleted (lambda (y) (cont (cons x y)))))))))
 
   (export delete delete-duplicates
-	  delete! delete-duplicates!)
+          delete! delete-duplicates!)
 
   ;; # Association lists
   ;; assoc assq assv
@@ -599,8 +590,8 @@
       (remove! (lambda (x) (= key (car x))) alist)))
 
   (export assoc assq assv
-	  alist-cons alist-copy
-	  alist-delete alist-delete!)
+          alist-cons alist-copy
+          alist-delete alist-delete!)
 
   ;; # Set operations on lists
   ;; lset<= lset= lset-adjoin
@@ -611,156 +602,156 @@
   ;; lset-diff+intersenction lset-diff+intersection!
   (define (lset<= = . lists)
     (or (null? lists)
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (or (null? rest)
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(and (or (eq? head next)
-			 (every (lambda (x) (member x next =)) head))
-		     (rec next rest)))))))
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (or (null? rest)
+              (let ((next (car rest)) (rest (cdr rest)))
+                (and (or (eq? head next)
+                         (every (lambda (x) (member x next =)) head))
+                     (rec next rest)))))))
 
   (define (lset= = . lists)
     (or (null? lists)
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (or (null? rest)
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(and (or (eq? head next)
-			 (and (every (lambda (x) (member x next =)) head)
-			      (every (lambda (x) (member x head =)) next))
-			 (rec next rest))))))))
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (or (null? rest)
+              (let ((next (car rest)) (rest (cdr rest)))
+                (and (or (eq? head next)
+                         (and (every (lambda (x) (member x next =)) head)
+                              (every (lambda (x) (member x head =)) next))
+                         (rec next rest))))))))
 
   (define (lset-adjoin = list . elts)
     (let rec ((list list) (elts elts))
       (if (null? elts)
-	  list
-	  (if (member (car elts) list)
-	      (rec list (cdr elts))
-	      (rec (cons (car elts) list) (cdr elts))))))
+          list
+          (if (member (car elts) list)
+              (rec list (cdr elts))
+              (rec (cons (car elts) list) (cdr elts))))))
 
   (define (lset-union = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    (rec head rest)
-		    (rec (apply lset-adjoin = head next) rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    (rec head rest)
+                    (rec (apply lset-adjoin = head next) rest)))))))
 
   (define (lset-intersection = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    (rec head rest)
-		    (rec (filter (lambda (x) (member x next =)) head)
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    (rec head rest)
+                    (rec (filter (lambda (x) (member x next =)) head)
+                         rest)))))))
 
   (define (lset-difference = list . lists)
     (let rec ((head list) (rest lists))
       (if (null? rest)
-	  head
-	  (let ((next (car rest)) (rest (cdr rest)))
-	    (if (eq? head next)
-		'()
-		(rec (remove (lambda (x) (member x next =)) head)
-		     rest))))))
+          head
+          (let ((next (car rest)) (rest (cdr rest)))
+            (if (eq? head next)
+                '()
+                (rec (remove (lambda (x) (member x next =)) head)
+                     rest))))))
 
   (define (lset-xor = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    '()
-		    (rec (append (remove (lambda (x) (member x next =)) head)
-				 (remove (lambda (x) (member x head =)) next))
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    '()
+                    (rec (append (remove (lambda (x) (member x next =)) head)
+                                 (remove (lambda (x) (member x head =)) next))
+                         rest)))))))
 
   (define (lset-diff+intersection = list . lists)
     (values (apply lset-difference = list lists)
-	    (lset-intersection = list (apply lset-union lists))))
+            (lset-intersection = list (apply lset-union lists))))
 
   (define (lset-adjoin! = list . elts)
     (let rec ((list list) (elts elts))
       (if (null? elts)
-	  list
-	  (if (member (car elts) list)
-	      (rec list (cdr elts))
-	      (let ((tail (cdr elts)))
-		(set-cdr! elts list)
-		(rec elts tail))))))
+          list
+          (if (member (car elts) list)
+              (rec list (cdr elts))
+              (let ((tail (cdr elts)))
+                (set-cdr! elts list)
+                (rec elts tail))))))
 
   (define (lset-union! = . lists)
     (letrec ((adjoin
-	      (lambda (lst1 lst2)
-		(if (null? lst2)
-		    lst1
-		    (if (member (car lst2) lst1 =)
-			(adjoin lst1 (cdr lst2))
-			(let ((tail (cdr lst2)))
-			  (set-cdr! lst2 lst1)
-			  (adjoin lst2 tail)))))))
+              (lambda (lst1 lst2)
+                (if (null? lst2)
+                    lst1
+                    (if (member (car lst2) lst1 =)
+                        (adjoin lst1 (cdr lst2))
+                        (let ((tail (cdr lst2)))
+                          (set-cdr! lst2 lst1)
+                          (adjoin lst2 tail)))))))
       (if (null? lists)
-	  lists
-	  (let rec ((head (car lists)) (rest (cdr lists)))
-	    (if (null? rest)
-		head
-		(let ((next (car rest)) (rest (cdr rest)))
-		  (if (eq? head next)
-		      (rec head rest)
-		      (rec (adjoin head next) rest))))))))
+          lists
+          (let rec ((head (car lists)) (rest (cdr lists)))
+            (if (null? rest)
+                head
+                (let ((next (car rest)) (rest (cdr rest)))
+                  (if (eq? head next)
+                      (rec head rest)
+                      (rec (adjoin head next) rest))))))))
 
   (define (lset-intersection! = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    (rec head rest)
-		    (rec (filter! (lambda (x) (member x next =)) head)
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    (rec head rest)
+                    (rec (filter! (lambda (x) (member x next =)) head)
+                         rest)))))))
 
   (define (lset-difference! = list . lists)
     (let rec ((head list) (rest lists))
       (if (null? rest)
-	  head
-	  (let ((next (car rest)) (rest (cdr rest)))
-	    (if (eq? head next)
-		'()
-		(rec (remove! (lambda (x) (member x next =)) head)
-		     rest))))))
+          head
+          (let ((next (car rest)) (rest (cdr rest)))
+            (if (eq? head next)
+                '()
+                (rec (remove! (lambda (x) (member x next =)) head)
+                     rest))))))
 
   (define (lset-xor! = . lists)
     (if (null? lists)
-	lists
-	(let rec ((head (car lists)) (rest (cdr lists)))
-	  (if (null? rest)
-	      head
-	      (let ((next (car rest)) (rest (cdr rest)))
-		(if (eq? head next)
-		    '()
-		    (rec (append! (remove! (lambda (x) (member x next =)) head)
-				  (remove! (lambda (x) (member x head =)) next))
-			 rest)))))))
+        lists
+        (let rec ((head (car lists)) (rest (cdr lists)))
+          (if (null? rest)
+              head
+              (let ((next (car rest)) (rest (cdr rest)))
+                (if (eq? head next)
+                    '()
+                    (rec (append! (remove! (lambda (x) (member x next =)) head)
+                                  (remove! (lambda (x) (member x head =)) next))
+                         rest)))))))
 
   (define (lset-diff+intersection! = list . lists)
     (values (apply lset-difference! = list lists)
-	    (lset-intersection! = list (apply lset-union! lists))))
+            (lset-intersection! = list (apply lset-union! lists))))
 
   (export lset<= lset= lset-adjoin
-	  lset-union lset-union!
-	  lset-intersection lset-intersection!
-	  lset-difference lset-difference!
-	  lset-xor lset-xor!
-	  lset-diff+intersection lset-diff+intersection!)
+          lset-union lset-union!
+          lset-intersection lset-intersection!
+          lset-difference lset-difference!
+          lset-xor lset-xor!
+          lset-diff+intersection lset-diff+intersection!)
 
   ;; # Primitive side-effects
   ;; set-car! set-cdr!

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

@@ -0,0 +1,247 @@
+(define-library (srfi 43)
+  (import (scheme base)
+          (srfi 8))
+  
+  ;; # Constructors
+  (define (vector-unfold f length . seeds)
+    (let ((seeds (if (null? seeds) '(0) seeds))
+          (vect (make-vector length)))
+      (letrec ((tabulate
+                (lambda (count . args)
+                  (if (= length count)
+                      vect
+                      (receive lst (apply f count args)
+                               (vector-set! vect count (car lst))
+                               (apply tabulate (+ 1 count) (cdr lst)))))))
+        (apply tabulate 0 seeds))))
+
+  (define (vector-unfold-right f length . seeds)
+    (let ((seeds (if (null? seeds) '(0) seeds))
+          (vect (make-vector length)))
+      (letrec ((tabulate
+                (lambda (count . args)
+                  (if (< count 0)
+                      vect
+                      (receive lst (apply f count args)
+                               (vector-set! vect count (car lst))
+                               (apply tabulate (- count 1) (cdr lst)))))))
+        (apply tabulate (- length 1) seeds))))
+
+  (define (vector-reverse-copy vec . rst)
+    (let* ((start (if (null? rst) 0 (car rst)))
+           (end (if (or (null? rst) (null? (cdr rst)))
+                    (vector-length vec)
+                    (cadr rst)))
+           (new-vect (make-vector (- end start))))
+      (let loop ((i (- end 1)) (count 0))
+        (if (< i start)
+            new-vect
+            (begin
+              (vector-set! new-vect count (vector-ref vec i))
+              (loop (- i 1) (+ 1 count)))))))
+
+  (define (vector-concatenate list-of-vectors)
+    (apply vector-append list-of-vectors))
+
+  
+  ;; # Predicates
+  (define (vector-empty? vec)
+    (zero? (vector-length vec)))
+
+                                        ; for the symmetry, this should be rather 'vector=?' than 'vector='.
+  (define (vector= elt=? . vects)
+    (letrec ((vector2=
+              (lambda (v1 v2)
+                (let ((ln1 (vector-length v1)))
+                  (and (= ln1 (vector-length v2))
+                       (let loop ((count 0))
+                         (if (= ln1 count)
+                             #t
+                             (and (elt=? (vector-ref v1 count)
+                                         (vector-ref v2 count))
+                                  (loop (+ 1 count))))))))))
+      (or (null? vects)
+          (let rec1 ((vect1 (car vects)) (others (cdr vects)))
+            (or (null? others)
+                (let ((vect2 (car others))
+                      (others (cdr others)))
+                  (if (eq? vect1 vect2)
+                      (rec1 vect1 others)
+                      (and (vector2= vect1 vect2)
+                           (rec1 vect2 others)))))))))
+
+  
+  ;; # Iteration
+  (define (vector-fold kons knil vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (apply min (map vector-length vects))))
+      (let rec ((acc knil) (count 0))
+        (if (= count veclen)
+            acc
+            (rec (apply kons count acc
+                        (map (lambda (v) (vector-ref v count)) vects))
+                 (+ 1 count))))))
+
+  (define (vector-fold-right kons knil vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (apply min (map vector-length vects))))
+      (let rec ((acc knil) (count (- veclen 1)))
+        (if (< count 0)
+            acc
+            (rec (apply kons count acc
+                        (map (lambda (v) (vector-ref v count)) vects))
+                 (- count 1))))))
+
+  (define (vector-map! f vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (apply min (map vector-length vects)))
+           (new-vect (make-vector veclen)))
+      (let rec ((count 0))
+        (if (< count veclen)
+            (begin
+              (vector-set! vec count
+                           (apply f (map (lambda (v) (vector-ref v count))
+                                         vects)))
+              (rec (+ 1 count)))))))
+
+  (define (vector-count pred? vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (apply min (map vector-length vects))))
+      (let rec ((i 0) (count 0))
+        (if (= i veclen)
+            count
+            (if (apply pred? count (map (lambda (v) (vector-ref v count)) vects))
+                (rec (+ 1 i) (+ 1 count))
+                (rec (+ 1 i) count))))))
+
+  ;; # Searching
+  (define (vector-index pred? vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (apply min (map vector-length vects))))
+      (let rec ((count 0))
+        (cond
+         ((= count veclen) #f)
+         ((apply pred? (map (lambda (v) (vector-ref v count)) vects))
+          count)
+         (else (rec (+ 1 count)))))))
+
+  (define (vector-index-right pred? vec . vects)
+    (let ((vects (cons vec vects))
+          (veclen (vector-length vec)))
+      (let rec ((count (- veclen 1)))
+        (cond
+         ((< count 0) #f)
+         ((apply pred? (map (lambda (v) (vector-ref v count)) vects))
+          count)
+         (else (rec (- count 1)))))))
+
+  (define (vector-skip pred? vec . vects)
+    (apply vector-index (lambda args (not (apply pred? args))) vec vects))
+
+  (define (vector-skip-right pred? vec . vects)
+    (apply vector-index-right (lambda args (not (apply pred? args))) vec vects))
+
+  (define (vector-binary-search vec value cmp)
+    (let rec ((start 0) (end (vector-length vec)) (n -1))
+      (let ((count (floor/ (+ start end) 2)))
+        (if (or (= start end) (= count n))
+            #f
+            (let ((comparison (cmp (vector-ref vec count) value)))
+              (cond
+               ((zero? comparison) count)
+               ((positive? comparison) (rec start count count))
+               (else (rec count end count))))))))
+
+  (define (vector-any pred? vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (vector-length vec)))
+      (let rec ((count 0))
+        (if (= count veclen)
+            #f
+            (or (apply pred? (map (lambda (v) (vector-ref v count)) vects))
+                (rec (+ 1 count)))))))
+
+  (define (vector-every pred? vec . vects)
+    (let* ((vects (cons vec vects))
+           (veclen (vector-length vec)))
+      (let rec ((count 0))
+        (if (= count veclen)
+            #t
+            (and (apply pred? (map (lambda (v) (vector-ref v count)) vects))
+                 (rec (+ 1 count)))))))
+
+  ;; # Mutators
+  (define (vector-swap! vec i j)
+    (let ((tmp (vector-ref vec i)))
+      (vector-set! vec i (vector-ref vec j))
+      (vector-set! vec j tmp)))
+
+  (define (vector-reverse! vec . rst)
+    (let ((start (if (null? rst) 0 (car rst)))
+          (end (if (or (null? rst) (cdr rst))
+                   (vector-length vec)
+                   (cadr rst))))
+      (let rec ((i start) (j (- end 1)))
+        (if (< i j)
+            (begin
+              (vector-swap! vec i j)
+              (rec (+ 1 i) (- j 1)))))))
+
+  (define (vector-reverse-copy! target tstart source . rst)
+    (let ((sstart (if (null? rst) 0 (car rst)))
+          (send (if (or (null? rst) (cdr rst))
+                    (vector-length source)
+                    (cadr rst))))
+      (let rec ((i tstart) (j (- send 1)))
+        (if (>= j sstart)
+            (begin
+              (vector-set! target i (vector-ref source j))
+              (rec (+ 1 i) (- j 1)))))))
+
+  ;; # Conversion
+  (define (reverse-vector->list vec . rst)
+    (let ((start (if (null? rst) 0 (car rst)))
+          (end (if (or (null? rst) (cdr rst))
+                   (vector-length vec)
+                   (cadr rst))))
+      (let rec ((i start) (acc '()))
+        (if (= i end)
+            acc
+            (rec (+ 1 i) (cons (vector-ref vec i) acc))))))
+
+  (define (reverse-list->vector proper-list)
+    (apply vector (reverse proper-list)))
+
+  (export vector?
+          make-vector
+          vector
+          vector-length
+          vector-ref
+          vector-set!
+          vector->list
+          list->vector
+          vector-fill!
+          vector-copy!
+
+          vector-unfold
+          vector-unfold-right
+          vector-reverse-copy
+          vector-concatenate
+          vector-empty?
+          vector=
+          vector-fold
+          vector-fold-right
+          vector-map!
+          vector-count
+          vector-index
+          vector-index-right
+          vector-skip
+          vector-skip-right
+          vector-binary-search
+          vector-any
+          vector-every
+          vector-swap!
+          vector-reverse!
+          vector-reverse-copy!
+          reverse-vector->list
+          reverse-list->vector))

piclib/srfi/60.scm

@@ -0,0 +1,182 @@
+(define-library (srfi 60)
+  (import (scheme base)
+          (srfi 1))
+
+  ;; # Bitwise Operations
+  (define (logand . args)
+    (letrec ((lgand
+              (lambda (x y)
+                (if (or (zero? x) (zero? y))
+                    0
+                    (+ (* (lgand (floor/ x 2) (floor/ y 2)) 2)
+                       (if (or (even? x) (even? y)) 0 1))))))
+      (fold lgand -1 args)))
+
+  (define bitwise-and logand)
+
+  (define (logior . args)
+    (letrec ((lgior
+              (lambda (x y)
+                (cond
+                 ((= x y) x)
+                 ((zero? x) y)
+                 ((zero? y) x)
+                 (else
+                  (+ (* (lgior (truncate-quotient x 2)
+                               (truncate-quotient y 2))
+                        2)
+                     (if (and (even? x) (even? y)) 0 1)))))))
+      (fold lgior 0 args)))
+
+  (define bitwise-ior logior)
+
+  (define (logxor . args)
+    (letrec ((lgxor
+              (lambda (x y)
+                (cond
+                 ((zero? x) y)
+                 ((zero? y) x)
+                 (else
+                  (+ (* (lgxor (floor/ x 2) (floor/ y 2)) 2)
+                     (if (even? x)
+                         (if (even? y) 0 1)
+                         (if (even? y) 1 0))))))))
+      (fold lgxor 0 args)))
+
+  (define bitwise-xor logxor)
+
+  (define (lognot n)
+    (- -1 n))
+
+  (define bitwise-not lognot)
+
+  (define (bitwise-if mask n0 n1)
+    (logior (logand mask n0)
+            (logand (lognot mask) n1)))
+
+  (define bitwise-merge bitwise-if)
+
+  (define (logtest j k)
+    (not (zero? (logand j k))))
+
+  (define any-bits-set? logtest)
+
+  ;; # Integer Properties
+  (define (logcount n)
+    (letrec ((lgcnt
+              (lambda (n)
+                (if (zero? n) 0
+                    (+ (lgcnt (floor/ n 2))
+                       (if (even? n) 0 1))))))
+      (if (negative? n)
+          (lgcnt (lognot n))
+          (lgcnt n))))
+
+  (define bit-count logcount)
+
+  (define (integer-length n)
+    (let loop ((n n) (count 0))
+      (if (zero? n)
+          count
+          (loop (floor/ n 2) (+ count 1)))))
+
+  (define (log2-binary-factors n)
+    (+ -1 (integer-length (logand n (- n)))))
+
+  (define first-set-bit log2-binary-factors)
+  
+  ;; # Bit Within Word
+  (define (logbit? index n)
+    (logtest (expt 2 index) n))
+
+  (define bit-set? logbit?)
+
+  (define (copy-bit index from bit)
+    (if bit
+        (logior from (expt 2 index))
+        (logand from (lognot (expt 2 index)))))
+
+
+  ;; # Field of Bits
+  (define (ash n count)
+    (if (negative? count)
+        (let ((k (expt 2 (- count))))
+          (if (negative? n)
+              (+ -1 (truncate-quotient (+ 1 n) k))
+              (truncate-quotient n k)))
+        (* (expt 2 count) n)))
+
+  (define arithmetic-shift ash)
+
+  (define (bit-field n start end)
+    (logand (lognot (ash -1 (- end start)))
+            (ash n (- start))))
+
+  (define (copy-bit-field to from start end)
+    (bitwise-if (ash (lognot (ash -1 (- end start))) start)
+                (ash from start)
+                to))
+
+  (define (rotate-bit-field n count start end)
+    (let* ((width (- start end))
+           (count (floor-remainder count width))
+           (mask (lognot (ash -1 width)))
+           (zn (logand mask (ash n (- start)))))
+      (logior (ash (logior (logand mask (ash zn count))
+                           (ash zn (- count width)))
+                   start)
+              (logand (lognot (ash mask start)) n))))
+
+  (define (reverse-bit-field n start end)
+    (letrec ((bit-reverse
+              (lambda (k n)
+                (let loop ((m (if (negative? n) (lognot n) n))
+                           (k (- k 1))
+                           (rvs 0))
+                  (if (negative? k)
+                      (if (negative? n) (lognot rvs) rvs)
+                      (loop (ash m -1)
+                            (- k 1)
+                            (logior (ash rvs 1) (logand 1 m))))))))
+      (let* ((width (- start end))
+             (mask (lognot (ash -1 width)))
+             (zn (logand mask (ash n (- start)))))
+        (logior (ash (bit-reverse width zn) start)
+                (logand (lognot (ash mask start)) n)))))
+
+  ;; Bits as Booleans
+  (define (integer->list k . len)
+    (let ((len (if (null? len) (integer-length k) len)))
+      (let loop ((k k) (len len) (acc '()))
+        (if (or (zero? k) (zero? len))
+            acc
+            (loop (floor/ k 2) (- len 1) (cons (if (even? k) #f #t) acc))))))
+
+  (define (list->integer lst)
+    (let loop ((lst lst) (acc 0))
+      (if (null? lst)
+          acc
+          (loop (cdr lst) (+ (* acc 2) (if (car lst) 1 0))))))
+
+  (define (booleans->integer . args)
+    (list->integer args))
+
+  (export logand bitwise-and
+          logior bitwise-ior
+          logxor bitwise-xor
+          lognot bitwise-not
+          bitwise-if bitwise-merge
+          logtest any-bits-set?
+          logcount bit-count
+          integer-length
+          log2-binary-factors first-set-bit
+          logbit? bit-set?
+          copy-bit
+          bit-field
+          copy-bit-field
+          ash arithmetic-shift
+          rotate-bit-field
+          reverse-bit-field
+          integer->list
+          list->integer
+          booleans->integer))

piclib/srfi/8.scm

@@ -0,0 +1,10 @@
+(define-library (srfi 8)
+  (import (scheme base))
+
+  (define-syntax receive
+    (syntax-rules ()
+      ((receive formals expression body ...)
+       (call-with-values (lambda () expression)
+         (lambda formals body ...)))))
+
+    (export receive))

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,3 @@
-# flex
-find_package(FLEX REQUIRED)
-flex_target(scan src/scan.l ${PROJECT_SOURCE_DIR}/src/lex.yy.c COMPILE_FLAGS --header-file="src/lex.yy.h")
-set_directory_properties(PROPERTIES ADDITIONAL_MAKE_CLEAN_FILES ${PROJECT_SOURCE_DIR}/src/lex.yy.h)
-
 # xfile
 set(XFILE_SOURCES extlib/xfile/xfile.c)
 
@@ -18,7 +13,7 @@ add_custom_command(
 
 # build!
 file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c)
-add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${FLEX_scan_OUTPUTS} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES})
+add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES})
 target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
 
 # install

src/bool.c

@@ -90,25 +90,34 @@ pic_internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xha
     }else{
       return false;
     }
-      
-  case PIC_TT_VECTOR:{
+  case PIC_TT_BLOB: {
     size_t i;
-    struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y);
-    
-    if(v1->len != v2->len){
+    struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y);
+
+    if (u->len != v->len) {
       return false;
     }
-    for(i = 0; i < v1->len; ++i){
-      if(! pic_internal_equal_p(pic, v1->data[i], v2->data[i], depth + 1, ht)){
-        return false;          
-        }
+    for (i = 0; i < u->len; ++i) {
+      if (u->data[i] != v->data[i])
+        return false;
+    }
+    return true;
+  }
+  case PIC_TT_VECTOR: {
+    size_t i;
+    struct pic_vector *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 (! pic_internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
+        return false;
     }
     return true;
   }
-  case PIC_TT_BLOB: 
-    return pic_blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
   case PIC_TT_STRING:
-    return pic_string_equal_p(pic_str_ptr(x), pic_str_ptr(y));
+    return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0;
   default:
     return false;
   }

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

@@ -68,7 +68,7 @@ new_analyze_state(pic_state *pic)
   state->pic = pic;
   state->scope = NULL;
 
-  stdlib = pic_find_library(pic, pic_read(pic, "(scheme base)"));
+  stdlib = pic_find_library(pic, pic_read_cstr(pic, "(scheme base)"));
 
   /* native VM procedures */
   register_renamed_symbol(pic, state, rCONS, stdlib, "cons");
@@ -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);
   }
@@ -1442,13 +1447,13 @@ pic_compile(pic_state *pic, pic_value obj)
   size_t ai = pic_gc_arena_preserve(pic);
 
 #if DEBUG
-  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 
   fprintf(stdout, "# input expression\n");
   pic_debug(pic, obj);
   fprintf(stdout, "\n");
 
-  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* macroexpand */
@@ -1457,7 +1462,7 @@ pic_compile(pic_state *pic, pic_value obj)
   fprintf(stdout, "## macroexpand completed\n");
   pic_debug(pic, obj);
   fprintf(stdout, "\n");
-  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* analyze */
@@ -1466,7 +1471,7 @@ pic_compile(pic_state *pic, pic_value obj)
   fprintf(stdout, "## analyzer completed\n");
   pic_debug(pic, obj);
   fprintf(stdout, "\n");
-  fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic));
+  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 #endif
 
   /* codegen */

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,12 +460,6 @@ 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);
@@ -472,10 +468,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
   }
   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;
@@ -641,9 +629,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
   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

@@ -29,6 +29,7 @@ void pic_init_macro(pic_state *);
 void pic_init_var(pic_state *);
 void pic_init_load(pic_state *);
 void pic_init_write(pic_state *);
+void pic_init_read(pic_state *);
 void pic_init_dict(pic_state *);
 
 void pic_load_piclib(pic_state *);
@@ -67,13 +68,15 @@ pic_init_core(pic_state *pic)
 
     /* 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_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX);
+    pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX, pic->rLETREC_SYNTAX);
 
     pic_init_bool(pic); DONE;
     pic_init_pair(pic); DONE;
@@ -94,6 +97,7 @@ pic_init_core(pic_state *pic)
     pic_init_var(pic); DONE;
     pic_init_load(pic); DONE;
     pic_init_write(pic); DONE;
+    pic_init_read(pic); DONE;
     pic_init_dict(pic); DONE;
 
     pic_load_piclib(pic); DONE;

src/load.c

@@ -14,7 +14,7 @@ pic_load_cstr(pic_state *pic, const char *src)
 
   exprs = pic_parse_cstr(pic, src);
   if (pic_undef_p(exprs)) {
-    pic_error(pic, "load: unexpected EOF");
+    pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
   }
 
   pic_for_each (v, exprs) {
@@ -48,7 +48,7 @@ pic_load(pic_state *pic, const char *fn)
 
   exprs = pic_parse_file(pic, file);
   if (pic_undef_p(exprs)) {
-    pic_error(pic, "load: unexpected EOF");
+    pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
   }
 
   pic_for_each (v, exprs) {

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]))			\
@@ -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)
 {
@@ -501,6 +527,10 @@ pic_pair_append(pic_state *pic)
 
   pic_get_args(pic, "*", &argc, &args);
 
+  if (argc == 0) {
+    return pic_nil_value();
+  }
+
   list = args[--argc];
 
   while (argc-- > 0) {

src/port.c

@@ -54,6 +54,23 @@ port_new_stdport(pic_state *pic, xFILE *file, short dir)
   return pic_obj_value(port);
 }
 
+struct pic_port *
+pic_open_input_string(pic_state *pic, const char *str)
+{
+  struct pic_port *port;
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
+  port->file = xmopen();
+  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
+  port->status = PIC_PORT_OPEN;
+
+  xfputs(str, port->file);
+  xfflush(port->file);
+  xrewind(port->file);
+
+  return port;
+}
+
 struct pic_port *
 pic_open_output_string(pic_state *pic)
 {
@@ -70,19 +87,20 @@ pic_open_output_string(pic_state *pic)
 struct pic_string *
 pic_get_output_string(pic_state *pic, struct pic_port *port)
 {
-  long endpos;
+  long size;
   char *buf;
 
   /* get endpos */
   xfflush(port->file);
-  endpos = xftell(port->file);
+  size = xftell(port->file);
   xrewind(port->file);
 
   /* copy to buf */
-  buf = (char *)pic_alloc(pic, endpos);
-  xfread(buf, 1, endpos, port->file);
+  buf = (char *)pic_alloc(pic, size + 1);
+  buf[size] = 0;
+  xfread(buf, size, 1, port->file);
 
-  return pic_str_new(pic, buf, endpos);
+  return pic_str_new(pic, buf, size);
 }
 
 void
@@ -268,14 +286,7 @@ pic_port_open_input_string(pic_state *pic)
 
   pic_get_args(pic, "z", &str);
 
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
-  port->file = xmopen();
-  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
-  port->status = PIC_PORT_OPEN;
-
-  xfputs(str, port->file);
-  xfflush(port->file);
-  xrewind(port->file);
+  port = pic_open_input_string(pic, str);
 
   return pic_obj_value(port);
 }
@@ -295,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);
 
@@ -318,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);
 }
@@ -340,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;
 
@@ -671,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

@@ -2,84 +2,499 @@
  * See Copyright Notice in picrin.h
  */
 
+#include <ctype.h>
+#include <math.h>
 #include "picrin.h"
-#include "picrin/parse.h"
+#include "picrin/error.h"
 #include "picrin/pair.h"
 #include "picrin/string.h"
 #include "picrin/vector.h"
 #include "picrin/blob.h"
 #include "picrin/port.h"
 
-#define YY_NO_UNISTD_H
-#include "lex.yy.h"
+typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, char);
 
-static pic_value read(int, yyscan_t);
+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);
 
-#define pic (yyget_extra(scanner)->pic)
-#define yylval (yyget_extra(scanner)->yylval)
-#define yylabels (yyget_extra(scanner)->labels)
-#define yymsg (yyget_extra(scanner)->msg)
-#define yyjmp (yyget_extra(scanner)->jmp)
-
-static void
-error(const char *msg, yyscan_t scanner)
+static noreturn void
+read_error(pic_state *pic, const char *msg)
 {
-  yymsg = msg;
-  longjmp(yyjmp, 1);
+  pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value());
 }
 
-static int
-gettok(yyscan_t scanner)
+static char
+skip(struct pic_port *port, char c)
 {
-  int tok;
-
-  while ((tok = yylex(scanner)) == tDATUM_COMMENT) {
-    read(gettok(scanner), scanner); /* discard */
+  while (isspace(c)) {
+    c = xfgetc(port->file);
   }
-  return tok;
+  return c;
+}
+
+static char
+next(struct pic_port *port)
+{
+  return xfgetc(port->file);
+}
+
+static char
+peek(struct pic_port *port)
+{
+  char c;
+
+  xungetc((c = xfgetc(port->file)), port->file);
+
+  return c;
+}
+
+static bool
+expect(struct pic_port *port, const char *str)
+{
+  char c;
+
+  while ((c = *str++) != 0) {
+    if (c != next(port))
+      return false;
+  }
+
+  return true;
+}
+
+static bool
+isdelim(char c)
+{
+  return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
 }
 
 static pic_value
-read_label_set(int i, yyscan_t scanner)
+read_comment(pic_state *pic, struct pic_port *port, char c)
 {
-  int tok;
-  pic_value val;
+  UNUSED(pic);
 
-  switch (tok = gettok(scanner)) {
-  case tLPAREN:
-  case tLBRACKET:
+  do {
+    c = next(port);
+  } while (! (c == EOF || c == '\n'));
+
+  return pic_undef_value();
+}
+
+static pic_value
+read_block_comment(pic_state *pic, struct pic_port *port, char c)
+{
+  char x, y;
+  int i = 1;
+
+  UNUSED(pic);
+  UNUSED(c);
+
+  y = next(port);
+
+  while (y != EOF && i > 0) {
+    x = y;
+    y = next(port);
+    if (x == '|' && y == '#') {
+      i--;
+    }
+    if (x == '#' && y == '|') {
+      i++;
+    }
+  }
+
+  return pic_undef_value();
+}
+
+static pic_value
+read_datum_comment(pic_state *pic, struct pic_port *port, char c)
+{
+  UNUSED(c);
+
+  read(pic, port, next(port));
+
+  return pic_undef_value();
+}
+
+static pic_value
+read_quote(pic_state *pic, struct pic_port *port, char c)
+{
+  UNUSED(c);
+
+  return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port)));
+}
+
+static pic_value
+read_quasiquote(pic_state *pic, struct pic_port *port, char c)
+{
+  UNUSED(c);
+
+  return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port)));
+}
+
+static pic_value
+read_comma(pic_state *pic, struct pic_port *port, char c)
+{
+  c = next(port);
+
+  if (c == '@') {
+    return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port)));
+  } else {
+    return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, c));
+  }
+}
+
+static pic_value
+read_symbol(pic_state *pic, struct pic_port *port, char c)
+{
+  size_t len;
+  char *buf;
+  pic_sym sym;
+
+  len = 0;
+  buf = NULL;
+
+  do {
+    if (len != 0) {
+      c = next(port);
+    }
+    len += 1;
+    buf = pic_realloc(pic, buf, len + 1);
+    buf[len - 1] = c;
+  } while (! isdelim(peek(port)));
+
+  buf[len] = '\0';
+  sym = pic_intern_cstr(pic, buf);
+  pic_free(pic, buf);
+
+  return pic_sym_value(sym);
+}
+
+static size_t
+read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[])
+{
+  size_t i = 0;
+
+  if (! isdigit(c)) {
+    read_error(pic, "expected one or more digits");
+  }
+
+  buf[i++] = c;
+  while (isdigit(c = peek(port))) {
+    buf[i++] = next(port);
+  }
+
+  buf[i] = '\0';
+
+  return i;
+}
+
+static pic_value
+read_number(pic_state *pic, struct pic_port *port, char c)
+{
+  char buf[256];
+  size_t i;
+  long n;
+
+  i = read_uinteger(pic, port, c, buf);
+
+  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);
+    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
+negate(pic_value n)
+{
+  if (pic_int_p(n)) {
+    return pic_int_value(-pic_int(n));
+  } else {
+    return pic_float_value(-pic_float(n));
+  }
+}
+
+static pic_value
+read_minus(pic_state *pic, struct pic_port *port, char c)
+{
+  pic_value sym;
+
+  if (isdigit(peek(port))) {
+    return negate(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 sym;
+  }
+}
+
+static pic_value
+read_plus(pic_state *pic, struct pic_port *port, char c)
+{
+  pic_value sym;
+
+  if (isdigit(peek(port))) {
+    return read_number(pic, port, c);
+  }
+  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);
+  }
+}
+
+static pic_value
+read_boolean(pic_state *pic, struct pic_port *port, char c)
+{
+  UNUSED(pic);
+  UNUSED(port);
+
+  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)
+{
+  c = next(port);
+
+  if (! isdelim(peek(port))) {
+    switch (c) {
+    default: read_error(pic, "unexpected character after char literal");
+    case 'a': c = '\a'; expect(port, "lerm"); break;
+    case 'b': c = '\b'; expect(port, "ackspace"); break;
+    case 'd': c = 0x7F; expect(port, "elete"); break;
+    case 'e': c = 0x1B; expect(port, "scape"); break;
+    case 'n': c = peek(port) == 'e' ? (expect(port, "ewline"), '\n') : (expect(port, "ull"), '\0'); break;
+    case 'r': c = '\r'; expect(port, "eturn"); break;
+    case 's': c = ' '; expect(port, "pace"); break;
+    case 't': c = '\t'; expect(port, "ab"); break;
+    }
+  }
+
+  return pic_char_value(c);
+}
+
+static pic_value
+read_string(pic_state *pic, struct pic_port *port, char c)
+{
+  char *buf;
+  size_t size, cnt;
+  pic_str *str;
+
+  size = 256;
+  buf = pic_alloc(pic, size);
+  cnt = 0;
+
+  /* TODO: intraline whitespaces */
+
+  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;
+      }
+    }
+    buf[cnt++] = c;
+    if (cnt >= size) {
+      buf = pic_realloc(pic, buf, size *= 2);
+    }
+  }
+  buf[cnt] = '\0';
+
+  str = pic_str_new(pic, buf, cnt);
+  pic_free(pic, buf);
+  return pic_obj_value(str);
+}
+
+static pic_value
+read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
+{
+  int nbits, n;
+  size_t len;
+  char *dat, buf[256];
+  pic_blob *blob;
+
+  nbits = 0;
+
+  while (isdigit(c = next(port))) {
+    nbits = 10 * nbits + c - '0';
+  }
+
+  if (nbits != 8) {
+    read_error(pic, "unsupported bytevector bit width");
+  }
+
+  if (c != '(') {
+    read_error(pic, "expected '(' character");
+  }
+
+  len = 0;
+  dat = NULL;
+  c = next(port);
+  while ((c = skip(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;
+    dat = pic_realloc(pic, dat, len);
+    dat[len - 1] = n;
+    c = next(port);
+  }
+
+  blob = pic_blob_new(pic, dat, len);
+  pic_free(pic, dat);
+  return pic_obj_value(blob);
+}
+
+static pic_value
+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 == '.' && 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_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);
+  }
+}
+
+static pic_value
+read_vector(pic_state *pic, struct pic_port *port, char c)
+{
+  pic_value list;
+
+  list = read(pic, port, c);
+
+  return pic_obj_value(pic_vec_new_from_list(pic, list));
+}
+
+static pic_value
+read_label_set(pic_state *pic, struct pic_port *port, int i)
+{
+  pic_value val;
+  char c;
+
+  switch (c = skip(port, ' ')) {
+  case '(': case '[':
     {
       pic_value tmp;
 
       val = pic_cons(pic, pic_none_value(), pic_none_value());
 
-      xh_put_int(&yylabels, i, &val);
+      xh_put_int(&pic->rlabels, i, &val);
 
-      tmp = read(tok, scanner);
+      tmp = read(pic, port, c);
       pic_pair_ptr(val)->car = pic_car(pic, tmp);
       pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp);
 
       return val;
     }
-  case tVPAREN:
+  case '#':
     {
-      pic_vec *tmp;
+      bool vect;
 
-      val = pic_obj_value(pic_vec_new(pic, 0));
+      if (peek(port) == '(') {
+        vect = true;
+      } else {
+        vect = false;
+      }
 
-      xh_put_int(&yylabels, i, &val);
+      if (vect) {
+        pic_vec *tmp;
 
-      tmp = pic_vec_ptr(read(tok, scanner));
-      SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
-      SWAP(size_t, tmp->len, pic_vec_ptr(val)->len);
+        val = pic_obj_value(pic_vec_new(pic, 0));
 
-      return val;
+        xh_put_int(&pic->rlabels, i, &val);
+
+        tmp = pic_vec_ptr(read(pic, port, c));
+        SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
+        SWAP(size_t, tmp->len, pic_vec_ptr(val)->len);
+
+        return val;
+      }
+
+      FALLTHROUGH;
     }
   default:
     {
-      val = read(tok, scanner);
+      val = read(pic, port, c);
 
-      xh_put_int(&yylabels, i, &val);
+      xh_put_int(&pic->rlabels, i, &val);
 
       return val;
     }
@@ -87,239 +502,206 @@ read_label_set(int i, yyscan_t scanner)
 }
 
 static pic_value
-read_label_ref(int i, yyscan_t scanner)
+read_label_ref(pic_state *pic, struct pic_port *port, int i)
 {
   xh_entry *e;
 
-  e = xh_get_int(&yylabels, i);
+  UNUSED(port);
+
+  e = xh_get_int(&pic->rlabels, i);
   if (! e) {
-    error("label of given index not defined", scanner);
+    read_error(pic, "label of given index not defined");
   }
   return xh_val(e, pic_value);
 }
 
 static pic_value
-read_pair(int tOPEN, yyscan_t scanner)
+read_label(pic_state *pic, struct pic_port *port, char c)
 {
-  int tok, tCLOSE = (tOPEN == tLPAREN) ? tRPAREN : tRBRACKET;
-  pic_value car, cdr;
+  int i;
 
-  tok = gettok(scanner);
-  if (tok == tCLOSE) {
-    return pic_nil_value();
-  }
-  if (tok == tDOT) {
-    cdr = read(gettok(scanner), scanner);
+  i = 0;
+  do {
+    i = i * 10 + c;
+  } while (isdigit(c = next(port)));
 
-    if (gettok(scanner) != tCLOSE) {
-      error("unmatched parenthesis", scanner);
-    }
-    return cdr;
+  if (c == '=') {
+    return read_label_set(pic, port, i);
   }
-  else {
-    car = read(tok, scanner);
-    cdr = read_pair(tOPEN, scanner);
-    return pic_cons(pic, car, cdr);
+  if (c == '#') {
+    return read_label_ref(pic, port, i);
   }
-}
-
-static pic_vec *
-read_vect(yyscan_t scanner)
-{
-  int tok;
-  pic_value val;
-
-  val = pic_nil_value();
-  while ((tok = gettok(scanner)) != tRPAREN) {
-    val = pic_cons(pic, read(tok, scanner), val);
-  }
-  return pic_vec_new_from_list(pic, pic_reverse(pic, val));
+  read_error(pic, "broken label expression");
 }
 
 static pic_value
-read_abbrev(pic_sym sym, yyscan_t scanner)
+read_dispatch(pic_state *pic, struct pic_port *port, char c)
 {
-  return pic_cons(pic, pic_sym_value(sym), pic_cons(pic, read(gettok(scanner), scanner), pic_nil_value()));
+  c = next(port);
+
+  switch (c) {
+  case '!':
+    return read_comment(pic, port, c);
+  case '|':
+    return read_block_comment(pic, port, c);
+  case ';':
+    return read_datum_comment(pic, port, c);
+  case 't': case 'f':
+    return read_boolean(pic, port, c);
+  case '\\':
+    return read_char(pic, port, c);
+  case '(':
+    return read_vector(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_label(pic, port, c);
+  case 'u':
+    return read_unsigned_blob(pic, port, c);
+  default:
+    read_error(pic, "unexpected dispatch character");
+  }
 }
 
 static pic_value
-read_datum(int tok, yyscan_t scanner)
+read_nullable(pic_state *pic, struct pic_port *port, char c)
 {
-  pic_value val;
+  c = skip(port, c);
 
-  switch (tok) {
-  case tLABEL_SET:
-    return read_label_set(yylval.i, scanner);
-
-  case tLABEL_REF:
-    return read_label_ref(yylval.i, scanner);
-
-  case tSYMBOL:
-    return pic_symbol_value(pic_intern(pic, yylval.buf.dat, yylval.buf.len));
-
-  case tINT:
-    return pic_int_value(yylval.i);
-
-  case tFLOAT:
-    return pic_float_value(yylval.f);
-
-  case tBOOLEAN:
-    return pic_bool_value(yylval.i);
-
-  case tCHAR:
-    return pic_char_value(yylval.c);
-
-  case tSTRING:
-    val = pic_obj_value(pic_str_new(pic, yylval.buf.dat, yylval.buf.len));
-    pic_free(pic, yylval.buf.dat);
-    return val;
-
-  case tBYTEVECTOR:
-    val = pic_obj_value(pic_blob_new(pic, yylval.buf.dat, yylval.buf.len));
-    pic_free(pic, yylval.buf.dat);
-    return val;
-
-  case tLPAREN:
-  case tLBRACKET:
-    return read_pair(tok, scanner);
-
-  case tVPAREN:
-    return pic_obj_value(read_vect(scanner));
-
-  case tQUOTE:
-    return read_abbrev(pic->sQUOTE, scanner);
-
-  case tQUASIQUOTE:
-    return read_abbrev(pic->sQUASIQUOTE, scanner);
-
-  case tUNQUOTE:
-    return read_abbrev(pic->sUNQUOTE, scanner);
-
-  case tUNQUOTE_SPLICING:
-    return read_abbrev(pic->sUNQUOTE_SPLICING, scanner);
-
-  case tRPAREN:
-    error("unexpected close parenthesis", scanner);
-
-  case tRBRACKET:
-    error("unexpected close bracket", scanner);
-
-  case tDOT:
-    error("unexpected '.'", scanner);
-
-  case tEOF:
-    error(NULL, scanner);
+  if (c == EOF) {
+    read_error(pic, "unexpected EOF");
   }
 
-  UNREACHABLE();
+  switch (c) {
+  case ';':
+    return read_comment(pic, port, c);
+  case '#':
+    return read_dispatch(pic, port, c);
+  case '\'':
+    return read_quote(pic, port, c);
+  case '`':
+    return read_quasiquote(pic, port, c);
+  case ',':
+    return read_comma(pic, port, c);
+  case '"':
+    return read_string(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);
+  case '+':
+    return read_plus(pic, port, c);
+  case '-':
+    return read_minus(pic, port, c);
+  case '(': case '[':
+    return read_pair(pic, port, c);
+  default:
+    return read_symbol(pic, port, c);
+  }
 }
 
 static pic_value
-read(int tok, yyscan_t scanner)
+read(pic_state *pic, struct pic_port *port, char c)
 {
-  size_t ai = pic_gc_arena_preserve(pic);
   pic_value val;
 
-  val = read_datum(tok, scanner);
+ retry:
+  val = read_nullable(pic, port, c);
+
+  if (pic_undef_p(val)) {
+    c = next(port);
+    goto retry;
+  }
 
-  pic_gc_arena_restore(pic, ai);
-  pic_gc_protect(pic, val);
   return val;
 }
 
 pic_value
-read_one(yyscan_t scanner)
+pic_read(pic_state *pic, struct pic_port *port)
 {
-  int tok;
+  pic_value val;
+  char c = next(port);
 
-  if (setjmp(yyjmp) != 0) {
-    pic_errorf(pic, "%s", yymsg ? yymsg : "unexpected EOF");
+ retry:
+  c = skip(port, c);
+
+  if (c == EOF) {
+    return pic_eof_object();
   }
 
-  if ((tok = gettok(scanner)) == tEOF) {
+  val = read_nullable(pic, port, c);
+
+  if (pic_undef_p(val)) {
+    c = next(port);
+    goto retry;
+  }
+
+  return val;
+}
+
+pic_value
+pic_read_cstr(pic_state *pic, const char *str)
+{
+  struct pic_port *port;
+
+  port = pic_open_input_string(pic, str);
+
+  return pic_read(pic, port);
+}
+
+static pic_value
+pic_parse(pic_state *pic, struct pic_port *port)
+{
+  pic_value val, acc;
+
+  pic_try {
+    acc = pic_nil_value();
+    while (! pic_eof_p(val = pic_read(pic, port))) {
+      pic_push(pic, val, acc);
+    }
+  }
+  pic_catch {
     return pic_undef_value();
   }
-  return read(tok, scanner);
-}
 
-pic_list
-read_many(yyscan_t scanner)
-{
-  int tok;
-  pic_value vals;
-
-  if (setjmp(yyjmp) != 0) {
-    if (yymsg) {
-      pic_errorf(pic, "%s", yymsg);
-    }
-    return pic_undef_value();   /* incomplete string */
-  }
-
-  vals = pic_nil_value();
-  while ((tok = gettok(scanner)) != tEOF) {
-    vals = pic_cons(pic, read(tok, scanner), vals);
-  }
-  return pic_reverse(pic, vals);
-}
-
-#undef pic
-
-pic_value
-pic_read(pic_state *pic, const char *cstr)
-{
-  yyscan_t scanner;
-  struct parser_control ctrl;
-  pic_value val;
-
-  ctrl.pic = pic;
-  xh_init_int(&ctrl.labels, sizeof(pic_value));
-  yylex_init_extra(&ctrl, &scanner);
-  yy_scan_string(cstr, scanner);
-
-  val = read_one(scanner);
-
-  yylex_destroy(scanner);
-  xh_destroy(&ctrl.labels);
-
-  return val;
+  return pic_reverse(pic, acc);
 }
 
 pic_list
 pic_parse_file(pic_state *pic, FILE *file)
 {
-  yyscan_t scanner;
-  struct parser_control ctrl;
-  pic_value vals;
+  struct pic_port *port;
 
-  ctrl.pic = pic;
-  xh_init_int(&ctrl.labels, sizeof(pic_value));
-  yylex_init_extra(&ctrl, &scanner);
-  yyset_in(file, scanner);
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
+  port->file = xfpopen(file);
+  port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
+  port->status = PIC_PORT_OPEN;
 
-  vals = read_many(scanner);
-
-  yylex_destroy(scanner);
-  xh_destroy(&ctrl.labels);
-
-  return vals;
+  return pic_parse(pic, port);
 }
 
 pic_list
-pic_parse_cstr(pic_state *pic, const char *cstr)
+pic_parse_cstr(pic_state *pic, const char *str)
 {
-  yyscan_t scanner;
-  struct parser_control ctrl;
-  pic_value vals;
+  struct pic_port *port;
 
-  ctrl.pic = pic;
-  xh_init_int(&ctrl.labels, sizeof(pic_value));
-  yylex_init_extra(&ctrl, &scanner);
-  yy_scan_string(cstr, scanner);
+  port = pic_open_input_string(pic, str);
 
-  vals = read_many(scanner);
-
-  yylex_destroy(scanner);
-  xh_destroy(&ctrl.labels);
-
-  return vals;
+  return pic_parse(pic, port);
+}
+
+static pic_value
+pic_read_read(pic_state *pic)
+{
+  struct pic_port *port = pic_stdin(pic);
+
+  pic_get_args(pic, "|p", &port);
+
+  return pic_read(pic, port);
+}
+
+void
+pic_init_read(pic_state *pic)
+{
+  pic_deflibrary ("(scheme read)") {
+    pic_defun(pic, "read", pic_read_read);
+  }
 }

src/scan.l

@@ -1,230 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-%{
-#include "picrin.h"
-#include "picrin/parse.h"
-
-#define yylval (yyextra->yylval)
-
-#define YY_NO_UNISTD_H
-
-/* NOTE:
- *  An internal function `yy_fatal_error` takes yyscanner for its second
- * argument but doesn't use it. This invokes a `unused variable` compiler
- * warning and it became super unusable if `-Werror` is turned on the system.
- * Since there's no flag to switch `yy_fatal_error` off and replace it with
- * a user-defined function, we modify this macro constant to use yyscanner
- * at least once avoiding get flex affected in any condition.
- */
-#define YY_EXIT_FAILURE ( (void)yyscanner, 2 )
-%}
-
-%option reentrant
-
-%option noyyalloc
-%option noyyrealloc
-%option noyyfree
-%option noinput
-%option nounput
-%option noyywrap
-
-%option extra-type="struct parser_control *"
-%option never-interactive
-
-  /* shebang */
-shebang		#!.*$
-
-  /* comment */
-comment		;.*$
-
-  /* boolean */
-boolean		#t|#f|#true|#false
-
-  /* symbol */
-identifier	[a-z0-9A-Z+/*!$%&:@^~?<=>_.-]+
-
-  /* number */
-digit		[0-9]
-real		{sign}{ureal}|{infnan}
-ureal		{uinteger}|\.{digit}+|{digit}+\.{digit}*
-integer		{sign}{uinteger}
-uinteger	{digit}+
-sign		[+-]?
-infnan		"+inf.0"|"-inf.0"|"+nan.0"|"-nan.0"
-
-  /* char */
-%x CHAR
-
-  /* string */
-%x STRING
-
-  /* bytevector */
-%x BYTEVECTOR
-
-  /* block comment */
-%x BLOCK_COMMENT
-
-  /* datum label */
-label		#{uinteger}
-%x DATUM_LABEL
-
-%%
-
-[ \t\n\r]	/* skip whitespace */
-{comment}	/* skip comment */
-{shebang}	/* skip shebang */
-
-"#|"		{
-  BEGIN(BLOCK_COMMENT);
-  yylval.i = 0;
-}
-<BLOCK_COMMENT>"#|" 	{
-  yylval.i++;
-}
-<BLOCK_COMMENT>"|#"	{
-  if (yylval.i == 0)
-    BEGIN(INITIAL);
-  else
-    yylval.i--;
-}
-<BLOCK_COMMENT>.|\n	{
-  /* skip block comment */
-}
-
-{label}		{
-  BEGIN(DATUM_LABEL);
-  yylval.i = atoi(yytext + 1);
-}
-<DATUM_LABEL>=	{
-  BEGIN(INITIAL);
-  return tLABEL_SET;
-}
-<DATUM_LABEL>#	{
-  BEGIN(INITIAL);
-  return tLABEL_REF;
-}
-
-"#;"		return tDATUM_COMMENT;
-"."		return tDOT;
-"("		return tLPAREN;
-")"		return tRPAREN;
-"["		return tLBRACKET;
-"]"		return tRBRACKET;
-"#("		return tVPAREN;
-"'"		return tQUOTE;
-"`"		return tQUASIQUOTE;
-","		return tUNQUOTE;
-",@"		return tUNQUOTE_SPLICING;
-
-{boolean}	{
-  yylval.i = (yytext[1] == 't');
-  return tBOOLEAN;
-}
-
-{integer}	{
-  yylval.i = atoi(yytext);
-  return tINT;
-}
-
-{real} 		{
-  yylval.f = atof(yytext);
-  return tFLOAT;
-}
-
-{identifier}	{
-  yylval.buf.dat = yytext;
-  yylval.buf.len = yyleng;
-  return tSYMBOL;
-}
-
-"\""		{
-  BEGIN(STRING);
-  yylval.buf.len = 0;
-  yylval.buf.dat = yyalloc(yylval.buf.len + 1, yyscanner);
-  strcpy(yylval.buf.dat, "");
-}
-<STRING>[^\\"]+	{
-  yylval.buf.len += yyleng;
-  yylval.buf.dat = yyrealloc(yylval.buf.dat, yylval.buf.len + 1, yyscanner);
-  strcpy(yylval.buf.dat + yylval.buf.len - yyleng, yytext);
-}
-<STRING>\\.	{
-  yylval.buf.len += 1;
-  yylval.buf.dat = yyrealloc(yylval.buf.dat, yylval.buf.len + 1, yyscanner);
-  yylval.buf.dat[yylval.buf.len] = '\0';
-
-  switch (yytext[yyleng - 1]) {
-  case 'a': yylval.buf.dat[yylval.buf.len - 1] = '\a'; break;
-  case 'b': yylval.buf.dat[yylval.buf.len - 1] = '\b'; break;
-  case 't': yylval.buf.dat[yylval.buf.len - 1] = '\t'; break;
-  case 'n': yylval.buf.dat[yylval.buf.len - 1] = '\n'; break;
-  case 'r': yylval.buf.dat[yylval.buf.len - 1] = '\r'; break;
-  default: yylval.buf.dat[yylval.buf.len - 1] = yytext[yyleng - 1]; break;
-  }
-}
-<STRING>\\[:blank:]*\n[:blank:]* {
-  /* skip intraline whitespaces */
-}
-<STRING>\"	{
-  BEGIN(INITIAL);
-  return tSTRING;
-}
-
-#\\		{
-  BEGIN(CHAR);
-}
-<CHAR>alarm	{ yylval.c = '\a'; BEGIN(INITIAL); return tCHAR; }
-<CHAR>backspace	{ yylval.c = '\b'; BEGIN(INITIAL); return tCHAR; }
-<CHAR>delete	{ yylval.c = 0x7f; BEGIN(INITIAL); return tCHAR; }
-<CHAR>escape	{ yylval.c = 0x1b; BEGIN(INITIAL); return tCHAR; }
-<CHAR>newline	{ yylval.c = '\n'; BEGIN(INITIAL); return tCHAR; }
-<CHAR>null	{ yylval.c = '\0'; BEGIN(INITIAL); return tCHAR; }
-<CHAR>return	{ yylval.c = '\r'; BEGIN(INITIAL); return tCHAR; }
-<CHAR>space	{ yylval.c = ' ';  BEGIN(INITIAL); return tCHAR; }
-<CHAR>tab	{ yylval.c = '\t'; BEGIN(INITIAL); return tCHAR; }
-<CHAR>.		{ yylval.c = yytext[0]; BEGIN(INITIAL); return tCHAR; }
-
-"#u8("		{
-  BEGIN(BYTEVECTOR);
-  yylval.buf.len = 0;
-  yylval.buf.dat = NULL;
-}
-<BYTEVECTOR>[ \r\n\t]	{
-  /* skip whitespace */
-}
-<BYTEVECTOR>{uinteger}	{
-  int i = atoi(yytext);
-  if (0 > i || i > 255) {
-    yyfree(yylval.buf.dat, yyscanner);
-    REJECT;
-  }
-  yylval.buf.len += 1;
-  yylval.buf.dat = yyrealloc(yylval.buf.dat, yylval.buf.len, yyscanner);
-  yylval.buf.dat[yylval.buf.len - 1] = (char)i;
-}
-<BYTEVECTOR>")"	{
-  BEGIN(INITIAL);
-  return tBYTEVECTOR;
-}
-
-%%
-
-void *
-yyalloc(size_t bytes, yyscan_t yyscanner)
-{
-  return pic_alloc(yyget_extra(yyscanner)->pic, bytes);
-}
-
-void *
-yyrealloc(void *ptr, size_t bytes, yyscan_t yyscanner)
-{
-  return pic_realloc(yyget_extra(yyscanner)->pic, ptr, bytes);
-}
-
-void
-yyfree(void * ptr, yyscan_t yyscanner)
-{
-  return pic_free(yyget_extra(yyscanner)->pic, ptr);
-}

src/state.c

@@ -64,6 +64,9 @@ pic_open(int argc, char *argv[], char **envp)
   pic->lib_tbl = pic_nil_value();
   pic->lib = NULL;
 
+  /* reader */
+  xh_init_int(&pic->rlabels, sizeof(pic_value));
+
   /* error handling */
   pic->jmp = NULL;
   pic->err = NULL;
@@ -93,6 +96,8 @@ pic_open(int argc, char *argv[], char **envp)
   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, sLET_SYNTAX, "let-syntax");
+  register_core_symbol(pic, sLETREC_SYNTAX, "letrec-syntax");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIMPORT, "import");
   register_core_symbol(pic, sEXPORT, "export");
@@ -113,11 +118,31 @@ 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_MACRO, "define-macro");
+  register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
+  register_renamed_symbol(pic, rLETREC_SYNTAX, "letrec-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 */
-  pic_make_library(pic, pic_read(pic, "(picrin user)"));
-  pic_in_library(pic, pic_read(pic, "(picrin user)"));
+  pic_make_library(pic, pic_read_cstr(pic, "(picrin user)"));
+  pic_in_library(pic, pic_read_cstr(pic, "(picrin user)"));
 
   return pic;
 }
@@ -154,6 +179,7 @@ pic_close(pic_state *pic)
   xh_destroy(&pic->syms);
   xh_destroy(&pic->global_tbl);
   xh_destroy(&pic->macros);
+  xh_destroy(&pic->rlabels);
 
   /* free GC arena */
   free(pic->arena);

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
@@ -385,9 +386,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++;
       }
@@ -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)
 {
@@ -747,7 +750,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
 
         /* invoke! */
 	pic->sp[0] = proc->u.func.f(pic);
-        pic->sp += ci->retc;
+        pic->sp += pic->ci->retc;
 
         pic_gc_arena_restore(pic, ai);
         goto L_RET;
@@ -994,29 +997,26 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
   } VM_LOOP_END;
 }
 
-static pic_code trampoline_iseq[] = {
-  { OP_NOP,		{0} },
-  { OP_TAILCALL,	{0} },
-};
-
 pic_value
 pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args)
 {
-  pic_value v, call_list, *fp = pic->ci->fp;
+  static const pic_code iseq = { OP_TAILCALL, { .i = -1 } };
+
+  pic_value v, *sp;
   pic_callinfo *ci;
 
-  call_list = pic_cons(pic, pic_obj_value(proc), args);
+  *pic->sp++ = pic_obj_value(proc);
 
-  pic_for_each (v, call_list) {
-    *fp++ = v;
+  sp = pic->sp;
+  pic_for_each (v, args) {
+    *sp++ = v;
   }
 
-  trampoline_iseq[1].u.i = pic_length(pic, call_list);
-
   ci = PUSHCI();
-  ci->ip = trampoline_iseq;
-  ci->fp = fp - 1;         /* the last argument is pushed by the VM */
-  return v;
+  ci->ip = (pic_code *)&iseq - 1;
+  ci->fp = pic->sp;
+  ci->retc = pic_length(pic, args);
+  return pic_obj_value(proc);
 }
 
 pic_value

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;
@@ -440,8 +432,8 @@ pic_printf(pic_state *pic, const char *fmt, ...)
 
   va_end(ap);
 
-  printf("%s", pic_str_cstr(str));
-  fflush(stdout);
+  xprintf("%s", pic_str_cstr(str));
+  xfflush(xstdout);
 }
 
 static pic_value

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)
+

tools/main.c

@@ -39,16 +39,17 @@ import_repllib(pic_state *pic)
 {
   int ai = pic_gc_arena_preserve(pic);
 
-  pic_import(pic, pic_read(pic, "(scheme base)"));
-  pic_import(pic, pic_read(pic, "(scheme load)"));
-  pic_import(pic, pic_read(pic, "(scheme process-context)"));
-  pic_import(pic, pic_read(pic, "(scheme write)"));
-  pic_import(pic, pic_read(pic, "(scheme file)"));
-  pic_import(pic, pic_read(pic, "(scheme inexact)"));
-  pic_import(pic, pic_read(pic, "(scheme cxr)"));
-  pic_import(pic, pic_read(pic, "(scheme lazy)"));
-  pic_import(pic, pic_read(pic, "(scheme time)"));
-  pic_import(pic, pic_read(pic, "(picrin macro)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme base)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme load)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme process-context)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme read)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme write)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme file)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme inexact)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme cxr)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme lazy)"));
+  pic_import(pic, pic_read_cstr(pic, "(scheme time)"));
+  pic_import(pic, pic_read_cstr(pic, "(picrin macro)"));
 
 #if DEBUG
   puts("* imported repl libraries");