diff --git a/.gitignore b/.gitignore index 6b185c72..e0975baf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,4 @@ build/* -src/lex.yy.c -src/lex.yy.h src/load_piclib.c .dir-locals.el GPATH diff --git a/.travis.yml b/.travis.yml index 5bccf52b..2d33fec2 100644 --- a/.travis.yml +++ b/.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 diff --git a/CMakeLists.txt b/CMakeLists.txt index 22cc4f9d..c9311e1b 100644 --- a/CMakeLists.txt +++ b/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}) diff --git a/README.md b/README.md index 9c61e195..dceed0be 100644 --- a/README.md +++ b/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) diff --git a/cmake/FindFLEX.cmake b/cmake/FindFLEX.cmake deleted file mode 100644 index c56e8eda..00000000 --- a/cmake/FindFLEX.cmake +++ /dev/null @@ -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 ]) -# which creates a custom command to generate the file from -# the 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 and 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( [COMPILE_FLAGS ]") - 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 diff --git a/contrib/10.partcont/CMakeLists.txt b/contrib/10.partcont/CMakeLists.txt new file mode 100644 index 00000000..65f16fb2 --- /dev/null +++ b/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}) diff --git a/contrib/partcont/piclib/partcont.scm b/contrib/10.partcont/piclib/partcont.scm similarity index 100% rename from contrib/partcont/piclib/partcont.scm rename to contrib/10.partcont/piclib/partcont.scm diff --git a/contrib/10.pretty-print/CMakeLists.txt b/contrib/10.pretty-print/CMakeLists.txt new file mode 100644 index 00000000..cf0327da --- /dev/null +++ b/contrib/10.pretty-print/CMakeLists.txt @@ -0,0 +1 @@ +list(APPEND PICLIB_CONTRIB_LIBS ${PROJECT_SOURCE_DIR}/contrib/10.pretty-print/pretty-print.scm) diff --git a/contrib/10.pretty-print/pretty-print.scm b/contrib/10.pretty-print/pretty-print.scm new file mode 100644 index 00000000..0c25882c --- /dev/null +++ b/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 + ;; 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)) diff --git a/contrib/regexp/CMakeLists.txt b/contrib/10.regexp/CMakeLists.txt similarity index 81% rename from contrib/regexp/CMakeLists.txt rename to contrib/10.regexp/CMakeLists.txt index 0e28d430..f71ccfc7 100644 --- a/contrib/regexp/CMakeLists.txt +++ b/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}) diff --git a/contrib/regexp/src/regexp.c b/contrib/10.regexp/src/regexp.c similarity index 100% rename from contrib/regexp/src/regexp.c rename to contrib/10.regexp/src/regexp.c diff --git a/contrib/20.for/CMakeLists.txt b/contrib/20.for/CMakeLists.txt new file mode 100644 index 00000000..ebe66a42 --- /dev/null +++ b/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}) diff --git a/contrib/20.for/piclib/for.scm b/contrib/20.for/piclib/for.scm new file mode 100644 index 00000000..3befa0ba --- /dev/null +++ b/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)) diff --git a/contrib/CMakeLists.txt b/contrib/CMakeLists.txt index 2a25b8b8..2487f0d0 100644 --- a/contrib/CMakeLists.txt +++ b/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() diff --git a/contrib/partcont/CMakeLists.txt b/contrib/partcont/CMakeLists.txt deleted file mode 100644 index c1ad29ad..00000000 --- a/contrib/partcont/CMakeLists.txt +++ /dev/null @@ -1,2 +0,0 @@ -file(GLOB PARTCONT_FILES ${PROJECT_SOURCE_DIR}/contrib/partcont/piclib/*.scm) -list(APPEND PICLIB_CONTRIB_LIBS ${PARTCONT_FILES}) diff --git a/docs/capi.rst b/docs/capi.rst new file mode 100644 index 00000000..c8840573 --- /dev/null +++ b/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 + #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) + } + diff --git a/docs/deploy.rst b/docs/deploy.rst index 2268ad01..0807466b 100644 --- a/docs/deploy.rst +++ b/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) diff --git a/docs/index.rst b/docs/index.rst index 0b1a4491..5c620a0d 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -15,6 +15,7 @@ Contents: deploy.rst lang.rst libs.rst + capi.rst Indices and tables ================== diff --git a/docs/lang.rst b/docs/lang.rst index fe0e60f7..9c4152ff 100644 --- a/docs/lang.rst +++ b/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 diff --git a/docs/libs.rst b/docs/libs.rst index 9d71963f..ced52fd2 100644 --- a/docs/libs.rst +++ b/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) ------------- diff --git a/etc/mkloader.pl b/etc/mkloader.pl index ff60c784..1702414c 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -3,6 +3,13 @@ use strict; print <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); diff --git a/include/picrin/box.h b/include/picrin/box.h deleted file mode 100644 index f9826eed..00000000 --- a/include/picrin/box.h +++ /dev/null @@ -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 diff --git a/include/picrin/dict.h b/include/picrin/dict.h index bb720534..8bc58ad8 100644 --- a/include/picrin/dict.h +++ b/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 diff --git a/include/picrin/error.h b/include/picrin/error.h index 024d5d29..75361c1a 100644 --- a/include/picrin/error.h +++ b/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 diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 151eb144..023c2785 100644 --- a/include/picrin/macro.h +++ b/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) } diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 64d5d1cb..1f7fccfa 100644 --- a/include/picrin/pair.h +++ b/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); diff --git a/include/picrin/parse.h b/include/picrin/parse.h deleted file mode 100644 index 0451d201..00000000 --- a/include/picrin/parse.h +++ /dev/null @@ -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 diff --git a/include/picrin/port.h b/include/picrin/port.h index 9fabf8ed..e51d8759 100644 --- a/include/picrin/port.h +++ b/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 *); diff --git a/include/picrin/proc.h b/include/picrin/proc.h index d96fb6c3..b91960de 100644 --- a/include/picrin/proc.h +++ b/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) } diff --git a/include/picrin/value.h b/include/picrin/value.h index 44dd0763..283bac28 100644 --- a/include/picrin/value.h +++ b/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: diff --git a/include/picrin/var.h b/include/picrin/var.h index bc098200..9926c092 100644 --- a/include/picrin/var.h +++ b/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) } diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index b795ad54..6898de1b 100644 --- a/piclib/CMakeLists.txt +++ b/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 ) diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm new file mode 100644 index 00000000..4f8295d5 --- /dev/null +++ b/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)) diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm new file mode 100644 index 00000000..a532b2e4 --- /dev/null +++ b/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)) diff --git a/piclib/built-in.scm b/piclib/prelude.scm similarity index 74% rename from piclib/built-in.scm rename to piclib/prelude.scm index 64e2ee10..3b84c974 100644 --- a/piclib/built-in.scm +++ b/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)) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index e1b2a4f1..8859b06b 100644 --- a/piclib/srfi/1.scm +++ b/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! diff --git a/piclib/srfi/111.scm b/piclib/srfi/111.scm new file mode 100644 index 00000000..aafb4c8b --- /dev/null +++ b/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!)) diff --git a/piclib/srfi/43.scm b/piclib/srfi/43.scm new file mode 100644 index 00000000..88ebc083 --- /dev/null +++ b/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)) diff --git a/piclib/srfi/60.scm b/piclib/srfi/60.scm new file mode 100644 index 00000000..627a71cf --- /dev/null +++ b/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)) diff --git a/piclib/srfi/8.scm b/piclib/srfi/8.scm new file mode 100644 index 00000000..082abe68 --- /dev/null +++ b/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)) diff --git a/piclib/srfi/95.scm b/piclib/srfi/95.scm index 9effaece..0036da62 100644 --- a/piclib/srfi/95.scm +++ b/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)) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 7a727e9b..9318f442 100644 --- a/src/CMakeLists.txt +++ b/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 diff --git a/src/bool.c b/src/bool.c index 8ed9cc02..319355dc 100644 --- a/src/bool.c +++ b/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; } diff --git a/src/box.c b/src/box.c deleted file mode 100644 index b9948fc7..00000000 --- a/src/box.c +++ /dev/null @@ -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; -} diff --git a/src/codegen.c b/src/codegen.c index 63abd247..df4c0239 100644 --- a/src/codegen.c +++ b/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 */ diff --git a/src/cont.c b/src/cont.c index f84e55c7..de076874 100644 --- a/src/cont.c +++ b/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, ""); /* 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, ""); /* 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))); } diff --git a/src/dict.c b/src/dict.c index ddbe2cb5..1ba9d565 100644 --- a/src/dict.c +++ b/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); } } diff --git a/src/error.c b/src/error.c index f4b96675..21f6d487 100644 --- a/src/error.c +++ b/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 diff --git a/src/gc.c b/src/gc.c index efbd98f5..d77393c8 100644 --- a/src/gc.c +++ b/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); diff --git a/src/init.c b/src/init.c index 91e55daa..4fdba1e0 100644 --- a/src/init.c +++ b/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; diff --git a/src/load.c b/src/load.c index b1fcf39a..f4b4db73 100644 --- a/src/load.c +++ b/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) { diff --git a/src/macro.c b/src/macro.c index 7783c0e4..636a968e 100644 --- a/src/macro.c +++ b/src/macro.c @@ -9,33 +9,7 @@ #include "picrin/macro.h" #include "picrin/lib.h" #include "picrin/error.h" -#include "picrin/box.h" - -struct pic_senv * -pic_null_syntactic_environment(pic_state *pic) -{ - struct pic_senv *senv; - - senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = NULL; - xh_init_int(&senv->renames, sizeof(pic_sym)); - - pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, senv, pic->sIMPORT); - pic_define_syntactic_keyword(pic, senv, pic->sEXPORT); - - return senv; -} - -void -pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym) -{ - pic_put_rename(pic, senv, sym, sym); - - if (pic->lib && pic->lib->senv == senv) { - pic_export(pic, sym); - } -} +#include "picrin/dict.h" pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) @@ -60,7 +34,12 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren { xh_entry *e; - UNUSED(pic); + if (! pic_interned_p(pic, sym)) { + if (rename != NULL) { + *rename = sym; + } + return true; + } if ((e = xh_get_int(&senv->renames, sym)) == NULL) { return false; @@ -94,112 +73,11 @@ find_macro(pic_state *pic, pic_sym rename) return xh_val(e, struct pic_macro *); } -void -pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) -{ - pic_sym sym, rename; - - /* symbol registration */ - sym = pic_intern_cstr(pic, name); - rename = pic_add_rename(pic, pic->lib->senv, sym); - define_macro(pic, rename, macro, NULL); - - /* auto export! */ - pic_export(pic, sym); -} - -static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value); - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - - v = macroexpand_node(pic, expr, senv, assoc_box); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; -} - -static struct pic_senv * -push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) -{ - struct pic_senv *senv; - pic_value a; - - senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = up; - xh_init_int(&senv->renames, sizeof(pic_sym)); - - for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value v = pic_car(pic, a); - - if (! pic_sym_p(v)) { - v = macroexpand(pic, v, up, assoc_box); - } - if (! pic_sym_p(v)) { - pic_error(pic, "syntax error"); - } - pic_add_rename(pic, senv, pic_sym(v)); - } - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, up, assoc_box); - } - if (pic_sym_p(a)) { - pic_add_rename(pic, senv, pic_sym(a)); - } - else if (! pic_nil_p(a)) { - pic_error(pic, "syntax error"); - } - return senv; -} - -static pic_value -macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v, vs; - - /* macroexpand in order */ - vs = pic_nil_value(); - while (pic_pair_p(list)) { - v = pic_car(pic, list); - - vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs); - list = pic_cdr(pic, list); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, vs); - pic_gc_protect(pic, list); - } - - list = macroexpand(pic, list, senv, assoc_box); - - /* reverse the result */ - pic_for_each (v, vs) { - list = pic_cons(pic, v, list); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, vs); - pic_gc_protect(pic, list); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, list); - return list; -} - static pic_sym -macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) +make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) { pic_sym rename; - pic_value x; - if (! pic_interned_p(pic, sym)) { - return sym; - } while (true) { if (pic_find_rename(pic, senv, sym, &rename)) { return rename; @@ -208,48 +86,21 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value break; senv = senv->up; } - x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box)); - if (pic_test(x)) { - return pic_sym(pic_cdr(pic, x)); - } else { - rename = pic_gensym(pic, sym); - pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box))); - return rename; - } + return pic_gensym(pic, sym); +} + +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); + +static pic_value +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) +{ + return pic_sym_value(make_identifier(pic, sym, senv)); } static pic_value -macroexpand_deflibrary(pic_state *pic, pic_value expr) +macroexpand_quote(pic_state *pic, pic_value expr) { - struct pic_lib *prev = pic->lib; - pic_value v; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - pic_make_library(pic, pic_cadr(pic, expr)); - - pic_try { - pic_in_library(pic, pic_cadr(pic, expr)); - - pic_for_each (v, pic_cddr(pic, expr)) { - size_t ai = pic_gc_arena_preserve(pic); - - pic_eval(pic, v); - - pic_gc_arena_restore(pic, ai); - } - - pic_in_library(pic, prev->name); - } - pic_catch { - /* restores pic->lib even if an error occurs */ - pic_in_library(pic, prev->name); - pic_throw(pic, pic->err); - } - - return pic_none_value(); + return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -301,7 +152,135 @@ macroexpand_export(pic_state *pic, pic_value expr) } static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_deflibrary(pic_state *pic, pic_value expr) +{ + struct pic_lib *prev = pic->lib; + pic_value v; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + pic_make_library(pic, pic_cadr(pic, expr)); + + pic_try { + pic_in_library(pic, pic_cadr(pic, expr)); + + pic_for_each (v, pic_cddr(pic, expr)) { + pic_void(pic_eval(pic, v)); + } + + pic_in_library(pic, prev->name); + } + pic_catch { + pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ + pic_throw_error(pic, pic->err); + } + + return pic_none_value(); +} + +static pic_value +macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value x, head, tail; + + if (pic_pair_p(obj)) { + head = macroexpand(pic, pic_car(pic, obj), senv); + tail = macroexpand_list(pic, pic_cdr(pic, obj), senv); + x = pic_cons(pic, head, tail); + } else { + x = macroexpand(pic, obj, senv); + } + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, x); + return x; +} + +static pic_value +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_value formal, body; + struct pic_senv *in; + pic_value a; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + in->up = senv; + xh_init_int(&in->renames, sizeof(pic_sym)); + + for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value v = pic_car(pic, a); + + if (! pic_sym_p(v)) { + v = macroexpand(pic, v, senv); + } + if (! pic_sym_p(v)) { + pic_error(pic, "syntax error"); + } + pic_add_rename(pic, in, pic_sym(v)); + } + if (! pic_sym_p(a)) { + a = macroexpand(pic, a, senv); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, in, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_error(pic, "syntax error"); + } + + formal = macroexpand_list(pic, pic_cadr(pic, expr), in); + body = macroexpand_list(pic, pic_cddr(pic, expr), in); + + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); +} + +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_sym sym; + pic_value formal, body, var, val; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + formal = pic_cadr(pic, expr); + if (pic_pair_p(formal)) { + var = pic_car(pic, formal); + } else { + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + var = formal; + } + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv); + } + if (! pic_sym_p(var)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, NULL)) { + pic_add_rename(pic, senv, sym); + } + body = pic_cddr(pic, expr); + if (pic_pair_p(formal)) { + val = macroexpand_lambda(pic, pic_cons(pic, pic_false_value(), pic_cons(pic, pic_cdr(pic, formal), body)), senv); + } else { + val = macroexpand(pic, pic_car(pic, body), senv); + } + return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv), val); +} + +static pic_value +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) { pic_value var, val; pic_sym sym, rename; @@ -312,7 +291,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic var = pic_cadr(pic, expr); if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, assoc_box); + var = macroexpand(pic, var, senv); } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); @@ -387,73 +366,47 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) } static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv) { - pic_sym sym; - pic_value formals; + struct pic_senv *in; + pic_value formal, v, var, val; + pic_sym sym, rename; + + in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + in->up = senv; + xh_init_int(&in->renames, sizeof(pic_sym)); if (pic_length(pic, expr) < 2) { pic_error(pic, "syntax error"); } - formals = pic_cadr(pic, expr); - if (pic_pair_p(formals)) { - struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, assoc_box); - pic_value a; - - /* defined symbol */ - a = pic_car(pic, formals); - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv, assoc_box); + formal = pic_cadr(pic, expr); + if (! pic_list_p(formal)) { + pic_error(pic, "syntax error"); + } + pic_for_each (v, formal) { + var = pic_car(pic, v); + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv); } - if (! pic_sym_p(a)) { + if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } - sym = pic_sym(a); - if (! pic_find_rename(pic, senv, sym, NULL)) { - pic_add_rename(pic, senv, sym); + sym = pic_sym(var); + if (! pic_find_rename(pic, in, sym, &rename)) { + rename = pic_add_rename(pic, in, sym); } - - /* binding value */ - return pic_cons(pic, pic_sym_value(pic->sDEFINE), - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), - macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); + val = pic_eval(pic, pic_cadr(pic, v)); + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var); + } + define_macro(pic, rename, pic_proc_ptr(val), senv); } - - if (! pic_sym_p(formals)) { - formals = macroexpand(pic, formals, senv, assoc_box); - } - if (! pic_sym_p(formals)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(formals); - if (! pic_find_rename(pic, senv, sym, NULL)) { - pic_add_rename(pic, senv, sym); - } - - return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in)); } static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) -{ - struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, assoc_box); - - return pic_cons(pic, pic_sym_value(pic->sLAMBDA), - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, assoc_box), - macroexpand_list(pic, pic_cddr(pic, expr), in, assoc_box))); -} - -static pic_value -macroexpand_quote(pic_state *pic, pic_value expr) -{ - return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); -} - -static pic_value -macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) { pic_value v, args; @@ -482,11 +435,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct puts(""); #endif - return macroexpand(pic, v, senv, assoc_box); + return macroexpand(pic, v, senv); } static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) { #if DEBUG printf("[macroexpand] expanding... "); @@ -495,11 +448,8 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu #endif switch (pic_type(expr)) { - case PIC_TT_SC: { - return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box); - } case PIC_TT_SYMBOL: { - return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box)); + return macroexpand_symbol(pic, pic_sym(expr), senv); } case PIC_TT_PAIR: { pic_value car; @@ -509,41 +459,47 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); } - car = macroexpand(pic, pic_car(pic, expr), senv, assoc_box); + car = macroexpand(pic, pic_car(pic, expr), senv); if (pic_sym_p(car)) { pic_sym tag = pic_sym(car); - if (tag == pic->sDEFINE_LIBRARY) { + if (tag == pic->rDEFINE_LIBRARY) { return macroexpand_deflibrary(pic, expr); } - else if (tag == pic->sIMPORT) { + else if (tag == pic->rIMPORT) { return macroexpand_import(pic, expr); } - else if (tag == pic->sEXPORT) { + else if (tag == pic->rEXPORT) { return macroexpand_export(pic, expr); } - else if (tag == pic->sDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, senv, assoc_box); + else if (tag == pic->rDEFINE_SYNTAX) { + return macroexpand_defsyntax(pic, expr, senv); } - else if (tag == pic->sDEFINE_MACRO) { + else if (tag == pic->rDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } - else if (tag == pic->sLAMBDA) { - return macroexpand_lambda(pic, expr, senv, assoc_box); + else if (tag == pic->rLET_SYNTAX) { + return macroexpand_let_syntax(pic, expr, senv); } - else if (tag == pic->sDEFINE) { - return macroexpand_define(pic, expr, senv, assoc_box); + /* else if (tag == pic->sLETREC_SYNTAX) { */ + /* return macroexpand_letrec_syntax(pic, expr, senv); */ + /* } */ + else if (tag == pic->rLAMBDA) { + return macroexpand_lambda(pic, expr, senv); } - else if (tag == pic->sQUOTE) { + else if (tag == pic->rDEFINE) { + return macroexpand_define(pic, expr, senv); + } + else if (tag == pic->rQUOTE) { return macroexpand_quote(pic, expr); } if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_macro(pic, mac, expr, senv, assoc_box); + return macroexpand_macro(pic, mac, expr, senv); } } - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); } case PIC_TT_EOF: case PIC_TT_NIL: @@ -568,17 +524,29 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu case PIC_TT_VAR: case PIC_TT_IREP: case PIC_TT_DATA: - case PIC_TT_BOX: case PIC_TT_DICT: pic_errorf(pic, "unexpected value type: ~s", expr); } UNREACHABLE(); } +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v; + + v = macroexpand_node(pic, expr, senv); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + pic_value pic_macroexpand(pic_state *pic, pic_value expr) { - pic_value v, box; + pic_value v; #if DEBUG puts("before expand:"); @@ -586,9 +554,7 @@ pic_macroexpand(pic_state *pic, pic_value expr) puts(""); #endif - box = pic_box(pic, pic_nil_value()); - - v = macroexpand(pic, expr, pic->lib->senv, box); + v = macroexpand(pic, expr, pic->lib->senv); #if DEBUG puts("after expand:"); @@ -599,37 +565,59 @@ pic_macroexpand(pic_state *pic, pic_value expr) return v; } -/* once read.c is implemented move there */ -static pic_value -pic_macro_include(pic_state *pic) +struct pic_senv * +pic_null_syntactic_environment(pic_state *pic) { - size_t argc, i; - pic_value *argv, exprs, body; - FILE *file; + struct pic_senv *senv; - pic_get_args(pic, "*", &argc, &argv); + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = NULL; + xh_init_int(&senv->renames, sizeof(pic_sym)); - /* FIXME unhygienic */ - body = pic_list1(pic, pic_sym_value(pic->sBEGIN)); + pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT); + pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT); - for (i = 0; i < argc; ++i) { - const char *filename; - if (! pic_str_p(argv[i])) { - pic_error(pic, "expected string"); - } - filename = pic_str_cstr(pic_str_ptr(argv[i])); - file = fopen(filename, "r"); - if (file == NULL) { - pic_error(pic, "could not open file"); - } - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - pic_error(pic, "parse error"); - } - body = pic_append(pic, body, exprs); + return senv; +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) +{ + pic_put_rename(pic, senv, sym, rsym); + + if (pic->lib && pic->lib->senv == senv) { + pic_export(pic, sym); } +} - return body; +void +pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) +{ + pic_sym sym, rename; + + /* symbol registration */ + sym = pic_intern_cstr(pic, name); + rename = pic_add_rename(pic, pic->lib->senv, sym); + define_macro(pic, rename, macro, NULL); + + /* auto export! */ + pic_export(pic, sym); +} + +bool +pic_identifier_p(pic_state *pic, pic_value obj) +{ + return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); +} + +bool +pic_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_sym x, struct pic_senv *e2, pic_sym y) +{ + x = make_identifier(pic, x, e1); + y = make_identifier(pic, y, e2); + + return x == y; } static pic_value @@ -654,63 +642,6 @@ pic_macro_macroexpand(pic_state *pic) return pic_macroexpand(pic, expr); } -static struct pic_sc * -sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - struct pic_sc *sc; - - sc = (struct pic_sc *)pic_obj_alloc(pic, sizeof(struct pic_sc), PIC_TT_SC); - sc->expr = expr; - sc->senv = senv; - return sc; -} - -static bool -sc_identifier_p(pic_value obj) -{ - if (pic_sym_p(obj)) { - return true; - } - if (pic_sc_p(obj)) { - return sc_identifier_p(pic_sc_ptr(obj)->expr); - } - return false; -} - -static bool -sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y) -{ - pic_value box; - - if (! (sc_identifier_p(x) && sc_identifier_p(y))) { - return false; - } - - box = pic_box(pic, pic_nil_value()); - - x = macroexpand(pic, x, e1, box); - y = macroexpand(pic, y, e2, box); - - return pic_eq_p(x, y); -} - -static pic_value -pic_macro_make_sc(pic_state *pic) -{ - pic_value senv, free_vars, expr; - struct pic_sc *sc; - - pic_get_args(pic, "ooo", &senv, &free_vars, &expr); - - if (! pic_senv_p(senv)) - pic_error(pic, "make-syntactic-closure: senv required"); - - /* just ignore free_vars for now */ - sc = sc_new(pic, expr, pic_senv_ptr(senv)); - - return pic_obj_value(sc); -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -718,16 +649,17 @@ pic_macro_identifier_p(pic_state *pic) pic_get_args(pic, "o", &obj); - return pic_bool_value(sc_identifier_p(obj)); + return pic_bool_value(pic_identifier_p(pic, obj)); } static pic_value pic_macro_identifier_eq_p(pic_state *pic) { - pic_value e, x, f, y; + pic_sym x, y; + pic_value e, f; struct pic_senv *e1, *e2; - pic_get_args(pic, "oooo", &e, &x, &f, &y); + pic_get_args(pic, "omom", &e, &x, &f, &y); if (! pic_senv_p(e)) { pic_error(pic, "unexpected type of argument 1"); @@ -738,239 +670,34 @@ pic_macro_identifier_eq_p(pic_state *pic) } e2 = pic_senv_ptr(f); - return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y)); + return pic_bool_value(pic_identifier_eq_p(pic, e1, x, e2, y)); } static pic_value -er_macro_rename(pic_state *pic) +pic_macro_make_identifier(pic_state *pic) { + pic_value obj; pic_sym sym; - struct pic_senv *mac_env; - pic_value assoc_box; - pic_get_args(pic, "m", &sym); + pic_get_args(pic, "mo", &sym, &obj); - mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); + pic_assert_type(pic, obj, senv); - return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); -} - -static pic_value -er_macro_compare(pic_state *pic) -{ - pic_value a, b; - struct pic_senv *use_env; - pic_sym m, n; - pic_value assoc_box; - - pic_get_args(pic, "oo", &a, &b); - - if (! pic_sym_p(a) || ! pic_sym_p(b)) - return pic_false_value(); /* should be an error? */ - - use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - - m = macroexpand_symbol(pic, pic_sym(a), use_env, assoc_box); - n = macroexpand_symbol(pic, pic_sym(b), use_env, assoc_box); - - return pic_bool_value(m == n); -} - -static pic_value -er_macro_call(pic_state *pic) -{ - pic_value expr, use_env, mac_env, box; - struct pic_proc *rename, *compare, *cb; - - pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); - - if (! pic_senv_p(use_env)) { - pic_error(pic, "unexpected type of argument 1"); - } - if (! pic_senv_p(mac_env)) { - pic_error(pic, "unexpected type of argument 3"); - } - - box = pic_box(pic, pic_nil_value()); - - rename = pic_proc_new(pic, er_macro_rename, ""); - pic_proc_cv_init(pic, rename, 3); - pic_proc_cv_set(pic, rename, 0, use_env); - pic_proc_cv_set(pic, rename, 1, mac_env); - pic_proc_cv_set(pic, rename, 2, box); - - compare = pic_proc_new(pic, er_macro_compare, ""); - pic_proc_cv_init(pic, compare, 3); - pic_proc_cv_set(pic, compare, 0, use_env); - pic_proc_cv_set(pic, compare, 1, mac_env); - pic_proc_cv_set(pic, compare, 2, box); - - cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - - return pic_apply3(pic, cb, expr, pic_obj_value(rename), pic_obj_value(compare)); -} - -static pic_value -pic_macro_er_macro_transformer(pic_state *pic) -{ - struct pic_proc *cb, *proc; - - pic_get_args(pic, "l", &cb); - - proc = pic_proc_new(pic, er_macro_call, ""); - pic_proc_cv_init(pic, proc, 1); - pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb)); - - return pic_obj_value(proc); -} - -static pic_value -ir_macro_inject(pic_state *pic) -{ - pic_sym sym; - struct pic_senv *use_env; - pic_value assoc_box; - - pic_get_args(pic, "m", &sym); - - use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - - return pic_sym_value(macroexpand_symbol(pic, sym, use_env, assoc_box)); -} - -static pic_value -ir_macro_compare(pic_state *pic) -{ - pic_value a, b; - struct pic_senv *mac_env; - pic_sym m, n; - pic_value assoc_box; - - pic_get_args(pic, "oo", &a, &b); - - if (! pic_sym_p(a) || ! pic_sym_p(b)) - return pic_false_value(); /* should be an error? */ - - mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); - assoc_box = pic_proc_cv_ref(pic, pic_get_proc(pic), 2); - - m = macroexpand_symbol(pic, pic_sym(a), mac_env, assoc_box); - n = macroexpand_symbol(pic, pic_sym(b), mac_env, assoc_box); - - return pic_bool_value(m == n); -} - -static pic_value -ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_value assoc_box, pic_value *ir) -{ - if (pic_sym_p(expr)) { - pic_value r; - r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box)); - *ir = pic_acons(pic, r, expr, *ir); - return r; - } - else if (pic_pair_p(expr)) { - return pic_cons(pic, - ir_macro_wrap(pic, pic_car(pic, expr), use_env, assoc_box, ir), - ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, assoc_box, ir)); - } - else { - return expr; - } -} - -static pic_value -ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_value assoc_box, pic_value *ir) -{ - if (pic_sym_p(expr)) { - pic_value r; - if (pic_test(r = pic_assq(pic, expr, *ir))) { - return pic_cdr(pic, r); - } - return pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), mac_env, assoc_box)); - } - else if (pic_pair_p(expr)) { - return pic_cons(pic, - ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, assoc_box, ir), - ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, assoc_box, ir)); - } - else { - return expr; - } -} - -static pic_value -ir_macro_call(pic_state *pic) -{ - pic_value expr, use_env, mac_env, box; - struct pic_proc *inject, *compare, *cb; - pic_value ir = pic_nil_value(); - - pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); - - if (! pic_senv_p(use_env)) { - pic_error(pic, "unexpected type of argument 1"); - } - if (! pic_senv_p(mac_env)) { - pic_error(pic, "unexpected type of argument 3"); - } - - box = pic_box(pic, pic_nil_value()); - - inject = pic_proc_new(pic, ir_macro_inject, ""); - pic_proc_cv_init(pic, inject, 3); - pic_proc_cv_set(pic, inject, 0, use_env); - pic_proc_cv_set(pic, inject, 1, mac_env); - pic_proc_cv_set(pic, inject, 2, box); - - compare = pic_proc_new(pic, ir_macro_compare, ""); - pic_proc_cv_init(pic, compare, 3); - pic_proc_cv_set(pic, compare, 0, use_env); - pic_proc_cv_set(pic, compare, 1, mac_env); - pic_proc_cv_set(pic, compare, 2, box); - - cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - - expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), box, &ir); - expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare)); - expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), box, &ir); - - return expr; -} - -static pic_value -pic_macro_ir_macro_transformer(pic_state *pic) -{ - struct pic_proc *cb, *proc; - - pic_get_args(pic, "l", &cb); - - proc = pic_proc_new(pic, ir_macro_call, ""); - pic_proc_cv_init(pic, proc, 1); - pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb)); - - return pic_obj_value(proc); + return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); } void pic_init_macro(pic_state *pic) { - pic_defmacro(pic, "include", pic_proc_new(pic, pic_macro_include, "")); - pic_deflibrary ("(picrin macro)") { /* export define-macro syntax */ - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO); pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); - pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc); pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); - pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer); - pic_defun(pic, "ir-macro-transformer", pic_macro_ir_macro_transformer); + pic_defun(pic, "make-identifier", pic_macro_make_identifier); } } diff --git a/src/number.c b/src/number.c index 593c130a..c0a1e7ec 100644 --- a/src/number.c +++ b/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); diff --git a/src/pair.c b/src/pair.c index 6fe316c1..499b7bb5 100644 --- a/src/pair.c +++ b/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) { diff --git a/src/port.c b/src/port.c index 419b8aee..8a3534bc 100644 --- a/src/port.c +++ b/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); diff --git a/src/proc.c b/src/proc.c index d4c73d7a..84967224 100644 --- a/src/proc.c +++ b/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, ""); - 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); + } } diff --git a/src/read.c b/src/read.c index 6f1d39ba..f8836e44 100644 --- a/src/read.c +++ b/src/read.c @@ -2,84 +2,499 @@ * See Copyright Notice in picrin.h */ +#include +#include #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); + } } diff --git a/src/scan.l b/src/scan.l deleted file mode 100644 index 747f31a7..00000000 --- a/src/scan.l +++ /dev/null @@ -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; -} -"#|" { - yylval.i++; -} -"|#" { - if (yylval.i == 0) - BEGIN(INITIAL); - else - yylval.i--; -} -.|\n { - /* skip block comment */ -} - -{label} { - BEGIN(DATUM_LABEL); - yylval.i = atoi(yytext + 1); -} -= { - BEGIN(INITIAL); - return tLABEL_SET; -} -# { - 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, ""); -} -[^\\"]+ { - 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); -} -\\. { - 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; - } -} -\\[:blank:]*\n[:blank:]* { - /* skip intraline whitespaces */ -} -\" { - BEGIN(INITIAL); - return tSTRING; -} - -#\\ { - BEGIN(CHAR); -} -alarm { yylval.c = '\a'; BEGIN(INITIAL); return tCHAR; } -backspace { yylval.c = '\b'; BEGIN(INITIAL); return tCHAR; } -delete { yylval.c = 0x7f; BEGIN(INITIAL); return tCHAR; } -escape { yylval.c = 0x1b; BEGIN(INITIAL); return tCHAR; } -newline { yylval.c = '\n'; BEGIN(INITIAL); return tCHAR; } -null { yylval.c = '\0'; BEGIN(INITIAL); return tCHAR; } -return { yylval.c = '\r'; BEGIN(INITIAL); return tCHAR; } -space { yylval.c = ' '; BEGIN(INITIAL); return tCHAR; } -tab { yylval.c = '\t'; BEGIN(INITIAL); return tCHAR; } -. { yylval.c = yytext[0]; BEGIN(INITIAL); return tCHAR; } - -"#u8(" { - BEGIN(BYTEVECTOR); - yylval.buf.len = 0; - yylval.buf.dat = NULL; -} -[ \r\n\t] { - /* skip whitespace */ -} -{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; -} -")" { - 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); -} diff --git a/src/state.c b/src/state.c index a9a13ba8..cb01c754 100644 --- a/src/state.c +++ b/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); diff --git a/src/string.c b/src/string.c index edaf1edc..6015688c 100644 --- a/src/string.c +++ b/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); } diff --git a/src/system.c b/src/system.c index efd53f48..73b27262 100644 --- a/src/system.c +++ b/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); diff --git a/src/var.c b/src/var.c index a779ddff..9cbb00e5 100644 --- a/src/var.c +++ b/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, ""); - 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); } } diff --git a/src/vm.c b/src/vm.c index c2d0b1e0..8a2430a0 100644 --- a/src/vm.c +++ b/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 diff --git a/src/write.c b/src/write.c index 952bf436..61551b1a 100644 --- a/src/write.c +++ b/src/write.c @@ -318,11 +318,6 @@ write_core(struct writer_control *p, pic_value obj) case PIC_TT_MACRO: xfprintf(file, "#", pic_ptr(obj)); break; - case PIC_TT_SC: - xfprintf(file, "#expr); - xfprintf(file, ">"); - break; case PIC_TT_LIB: xfprintf(file, "#", pic_ptr(obj)); break; @@ -335,9 +330,6 @@ write_core(struct writer_control *p, pic_value obj) case PIC_TT_DATA: xfprintf(file, "#", pic_ptr(obj)); break; - case PIC_TT_BOX: - xfprintf(file, "#", pic_ptr(obj)); - break; case PIC_TT_DICT: xfprintf(file, "#", 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 diff --git a/t/array.scm b/t/array.scm new file mode 100644 index 00000000..22593546 --- /dev/null +++ b/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) + diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm new file mode 100644 index 00000000..eeac935e --- /dev/null +++ b/t/r7rs-tests.scm @@ -0,0 +1,2289 @@ +;; Copyright (c) 2014 Yuichi Nishiwaki, and other picrin contributers. + +;; Copyright (c) 2009-2012 Alex Shinn +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. 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. +;; 3. The name of the author may not be used to endorse or promote products +;; derived from this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. + +(import (scheme base) +; (scheme char) + (scheme lazy) + (scheme inexact) +; (scheme complex) + (scheme time) + (scheme file) + (scheme read) + (scheme write) +; (scheme eval) + (scheme process-context) + (scheme case-lambda)) + +;; R7RS test suite. Covers all procedures and syntax in the small +;; language except `delete-file'. Currently assumes full-unicode +;; support, the full numeric tower and all standard libraries +;; provided. + +(define test-counter 0) +(define counter 0) +(define failure-counter 0) + +(define fails '()) + +(define (print-statistics) + (newline) + (display "Test Result: ") + (write (- counter failure-counter)) + (display " / ") + (write counter) + (display " (") + (write (* (/ (- counter failure-counter) counter) 100)) + (display "%)") + (display " [PASS/TOTAL]") + (display "") + (newline) + (for-each + (lambda (fail) + (display fail)) + fails)) + +(define (test-begin . o) + (set! test-counter (+ test-counter 1))) + +(define (test-end . o) + (set! test-counter (- test-counter 1)) + (if (= test-counter 0) + (print-statistics))) + +(define-syntax test + (syntax-rules () + ((test expected expr) + (let ((res expr)) + (display "case ") + (write counter) + (cond + ((equal? res expected) + (display " PASS: ") + (write 'expr) + (display " equals ") + (write expected) + (display "") + (newline) + ) + ((not (equal? res expected)) + (set! failure-counter (+ failure-counter 1)) + (let ((out (open-output-string))) + (display " FAIL: " out) + (write 'expr out) + (newline out) + (display " expected " out) + (write expected out) + (display " but got " out) + (write res out) + (display "" out) + (newline out) + (let ((str (get-output-string out))) + (set! fails (cons str fails)) + (display str))))) + (set! counter (+ counter 1)))))) + +(newline) + +(test-begin "R7RS") + +(test-begin "4.1 Primitive expression types") + +(let () + (define x 28) + (test 28 x)) + +(test 'a (quote a)) +(test #(a b c) (quote #(a b c))) +(test '(+ 1 2) (quote (+ 1 2))) + +(test 'a 'a) +(test #(a b c) '#(a b c)) +(test '() '()) +(test '(+ 1 2) '(+ 1 2)) +(test '(quote a) '(quote a)) +(test '(quote a) ''a) + +(test "abc" '"abc") +(test "abc" "abc") +(test 145932 '145932) +(test 145932 145932) +(test #t '#t) +(test #t #t) + +(test 7 (+ 3 4)) +(test 12 ((if #f + *) 3 4)) + +(test 8 ((lambda (x) (+ x x)) 4)) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 (reverse-subtract 7 10)) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 (add4 6)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) +(test '(5 6) ((lambda (x y . z) z) + 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) +(test 'no (if (> 2 3) 'yes 'no)) +(test 1 (if (> 3 2) + (- 3 2) + (+ 3 2))) +(let () + (define x 2) + (test 3 (+ x 1))) + +(test-end) + +(test-begin "4.2 Derived expression types") + +(test 'greater + (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) + +(test 'equal + (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) + +(test 2 + (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) + +(test 'composite + (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) + +(test 'c + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else => (lambda (x) x)))) + +(test '((other . z) (semivowel . y) (other . x) + (semivowel . w) (vowel . u)) + (map (lambda (x) + (case x + ((a e i o u) => (lambda (w) (cons 'vowel w))) + ((w y) (cons 'semivowel x)) + (else => (lambda (w) (cons 'other w))))) + '(z y x w u))) + +(test #t (and (= 2 2) (> 2 1))) +(test #f (and (= 2 2) (< 2 1))) +(test '(f g) (and 1 2 'c '(f g))) +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) +(test #t (or (= 2 2) (< 2 1))) +(test #f (or #f #f #f)) +(test '(b c) (or (memq 'b '(a b c)) + (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) + (* x y))) + +(test 35 (let ((x 2) (y 3)) + (let ((x 7) + (z (+ x y))) + (* z x)))) + +(test 70 (let ((x 2) (y 3)) + (let* ((x 7) + (z (+ x y))) + (* z x)))) + +(test #t + (letrec ((even? + (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 88))) + +(test 5 + (letrec* ((p + (lambda (x) + (+ 1 (q (- x 1))))) + (q + (lambda (y) + (if (zero? y) + 0 + (+ 1 (p (- y 1)))))) + (x (p 5)) + (y x)) + y)) + +;; By Jussi Piitulainen +;; and John Cowan : +;; http://lists.scheme-reports.org/pipermail/scheme-reports/2013-December/003876.html + +(define (means ton) + (letrec* + ((mean + (lambda (f g) + (f (/ (sum g ton) n)))) + (sum + (lambda (g ton) + (if (null? ton) + (+) + (if (number? ton) + (g ton) + (+ (sum g (car ton)) + (sum g (cdr ton))))))) + (n (sum (lambda (x) 1) ton))) + (values (mean values values) + (mean exp log) + (mean / /)))) +(let*-values (((a b c) (means '(8 5 99 1 22)))) + (test 27 a) + (test 9.7280002558226410514 b) + (test (/ 1800 497) c)) + +(let*-values (((root rem) (exact-integer-sqrt 32))) + (test 35 (* root rem))) + +(test '(1073741824 0) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 60)))) + (list root rem))) + +(test '(1518500249 3000631951) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 61)))) + (list root rem))) + +(test '(815238614083298888 443242361398135744) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 119)))) + (list root rem))) + +(test '(1152921504606846976 0) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 120)))) + (list root rem))) + +(test '(1630477228166597776 1772969445592542976) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 121)))) + (list root rem))) + +(test '(31622776601683793319 62545769258890964239) + (let*-values (((root rem) (exact-integer-sqrt (expt 10 39)))) + (list root rem))) + +(let*-values (((root rem) (exact-integer-sqrt (expt 2 140)))) + (test 0 rem) + (test (expt 2 140) (square root))) + +(test '(x y x y) (let ((a 'a) (b 'b) (x 'x) (y 'y)) + (let*-values (((a b) (values x y)) + ((x y) (values a b))) + (list a b x y)))) + +(let () + (define x 0) + (set! x 5) + (test 6 (+ x 1))) + +(test #(0 1 2 3 4) (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg)) + ((< (car numbers) 0) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg)))))) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) + (let ((p (delay (+ 1 2)))) + (list (force p) (force p)))) + +(define integers + (letrec ((next + (lambda (n) + (delay (cons n (next (+ n 1))))))) + (next 0))) +(define head + (lambda (stream) (car (force stream)))) +(define tail + (lambda (stream) (cdr (force stream)))) + +(test 2 (head (tail (tail integers)))) + +(define (stream-filter p? s) + (delay-force + (if (null? (force s)) + (delay '()) + (let ((h (car (force s))) + (t (cdr (force s)))) + (if (p? h) + (delay (cons h (stream-filter p? t))) + (stream-filter p? t)))))) + +(test 5 (head (tail (tail (stream-filter odd? integers))))) + +(let () + (define x 5) + (define count 0) + (define p + (delay (begin (set! count (+ count 1)) + (if (> count x) + count + (force p))))) + (test 6 (force p)) + (test 6 (begin (set! x 10) (force p)))) + +(test #t (promise? (delay (+ 2 2)))) +(test #t (promise? (make-promise (+ 2 2)))) +(test #t + (let ((x (delay (+ 2 2)))) + (force x) + (promise? x))) + +(test #t + (let ((x (make-promise (+ 2 2)))) + (force x) + (promise? x))) + + + + +(define radix + (make-parameter + 10 + (lambda (x) + (if (and (integer? x) (<= 2 x 16)) + x + (error "invalid radix"))))) +(define (f n) (number->string n (radix))) +(test "12" (f 12)) +(test "1100" (parameterize ((radix 2)) + (f 12))) +(test "12" (f 12)) +(test '(list 3 4) `(list ,(+ 1 2) 4)) +(let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test #(10 5 4 16 9 8) + `#(10 5 ,(square 2) ,@(map square '(4 3)) 8)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) ) +(let ((name1 'x) + (name2 'y)) + (test '(a `(b ,x ,'y d) e) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) +(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) + +(define plus + (case-lambda + (() 0) + ((x) x) + ((x y) (+ x y)) + ((x y z) (+ (+ x y) z)) + (args (apply + args)))) + +(test 0 (plus)) +(test 1 (plus 1)) +(test 3 (plus 1 2)) +(test 6 (plus 1 2 3)) +(test 10 (plus 1 2 3 4)) + +(define mult + (case-lambda + (() 1) + ((x) x) + ((x y) (* x y)) + ((x y . z) (apply mult (* x y) z)))) + +(test 1 (mult)) +(test 1 (mult 1)) +(test 2 (mult 1 2)) +(test 6 (mult 1 2 3)) +(test 24 (mult 1 2 3 4)) + +(test-end) + +(test-begin "4.3 Macros") + +(test 'now (let-syntax + ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if))) + +(test 'outer (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m))))) + +(test 7 (letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y)))) + +(define-syntax be-like-begin + (syntax-rules () + ((be-like-begin name) + (define-syntax name + (syntax-rules () + ((name expr (... ...)) + (begin expr (... ...)))))))) +(be-like-begin sequence) +(test 4 (sequence 1 2 3 4)) + +(define-syntax jabberwocky + (syntax-rules () + ((_ hatter) + (begin + (define march-hare 42) + (define-syntax hatter + (syntax-rules () + ((_) march-hare))))))) +(jabberwocky mad-hatter) +(test 42 (mad-hatter)) + +(test 'ok (let ((=> #f)) (cond (#t => 'ok)))) + +(test-end) + +(test-begin "5 Program structure") + +(define add3 + (lambda (x) (+ x 3))) +(test 6 (add3 3)) +(define first car) +(test 1 (first '(1 2))) + +;; (test 45 (let ((x 5)) +;; (define foo (lambda (y) (bar x y))) +;; (define bar (lambda (a b) (+ (* a b) a))) +;; (foo (+ x 3)))) + +(test 'ok + (let () + (define-values () (values)) + 'ok)) +(test 1 + (let () + (define-values (x) (values 1)) + x)) +(test 3 + (let () + (define-values x (values 1 2)) + (apply + x))) +(test 3 + (let () + (define-values (x y) (values 1 2)) + (+ x y))) +(test 6 + (let () + (define-values (x y z) (values 1 2 3)) + (+ x y z))) +(test 10 + (let () + (define-values (x y . z) (values 1 2 3 4)) + (+ x y (car z) (cadr z)))) + +(test '(2 1) (let ((x 1) (y 2)) + (define-syntax swap! + (syntax-rules () + ((swap! a b) + (let ((tmp a)) + (set! a b) + (set! b tmp))))) + (swap! x y) + (list x y))) + +;; Records + +(define-record-type + (kons x y) + pare? + (x kar set-kar!) + (y kdr)) + +(test #t (pare? (kons 1 2))) +(test #f (pare? (cons 1 2))) +(test 1 (kar (kons 1 2))) +(test 2 (kdr (kons 1 2))) +(test 3 (let ((k (kons 1 2))) + (set-kar! k 3) + (kar k))) + +(test-end) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 6 Standard Procedures + +(test-begin "6.1 Equivalence Predicates") + +(test #t (eqv? 'a 'a)) +(test #f (eqv? 'a 'b)) +(test #t (eqv? 2 2)) +(test #t (eqv? '() '())) +(test #t (eqv? 100000000 100000000)) +(test #f (eqv? (cons 1 2) (cons 1 2))) +(test #f (eqv? (lambda () 1) + (lambda () 2))) +(test #f (eqv? #f 'nil)) + +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(test #t + (let ((g (gen-counter))) + (eqv? g g))) +(test #f (eqv? (gen-counter) (gen-counter))) +(define gen-loser + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) 27)))) +(test #t (let ((g (gen-loser))) + (eqv? g g))) + +(test #f +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (eqv? f g))) + +(test #t + (let ((x '(a))) + (eqv? x x))) + +(test #t (eq? 'a 'a)) +(test #f (eq? (list 'a) (list 'a))) +(test #t (eq? '() '())) +(test #t + (let ((x '(a))) + (eq? x x))) +(test #t + (let ((x '#())) + (eq? x x))) +(test #t + (let ((p (lambda (x) x))) + (eq? p p))) + +(test #t (equal? 'a 'a)) +(test #t (equal? '(a) '(a))) +(test #t (equal? '(a (b) c) + '(a (b) c))) +(test #t (equal? "abc" "abc")) +(test #t (equal? 2 2)) +(test #t (equal? (make-vector 5 'a) + (make-vector 5 'a))) + +(test-end) + +(test-begin "6.2 Numbers") + +;; (test #t (complex? 3+4i)) +(test #t (complex? 3)) +(test #t (real? 3)) +;; (test #t (real? -2.5+0i)) +;; (test #f (real? -2.5+0.0i)) +;; (test #t (real? #e1e10)) +(test #t (real? +inf.0)) +(test #f (rational? -inf.0)) +(test #t (rational? 6/10)) +(test #t (rational? 6/3)) +;; (test #t (integer? 3+0i)) +(test #t (integer? 3.0)) +(test #t (integer? 8/4)) + +(test #f (exact? 3.0)) +;; (test #t (exact? #e3.0)) +;; (test #t (inexact? 3.)) + +(test #t (exact-integer? 32)) +(test #f (exact-integer? 32.0)) +(test #f (exact-integer? 32/5)) + +(test #t (finite? 3)) +(test #f (finite? +inf.0)) +;; (test #f (finite? 3.0+inf.0i)) + +(test #f (infinite? 3)) +(test #t (infinite? +inf.0)) +(test #f (infinite? +nan.0)) +;; (test #t (infinite? 3.0+inf.0i)) + +(test #t (nan? +nan.0)) +(test #f (nan? 32)) +;; (test #t (nan? +nan.0+5.0i)) +;; (test #f (nan? 1+2i)) + +;; (test #t (= 1 1.0 1.0+0.0i)) +;; (test #f (= 1.0 1.0+1.0i)) +(test #t (< 1 2 3)) +(test #f (< 1 1 2)) +(test #t (> 3.0 2.0 1.0)) +(test #f (> -3.0 2.0 1.0)) +(test #t (<= 1 1 2)) +(test #f (<= 1 2 1)) +(test #t (>= 2 1 1)) +(test #f (>= 1 2 1)) + +;; From R7RS 6.2.6 Numerical operations: +;; +;; These predicates are required to be transitive. +;; +;; _Note:_ The traditional implementations of these predicates in +;; Lisp-like languages, which involve converting all arguments to inexact +;; numbers if any argument is inexact, are not transitive. + +;; Example from Alan Bawden +(let ((a (- (expt 2 1000) 1)) + (b (inexact (expt 2 1000))) ; assuming > single-float-epsilon + (c (+ (expt 2 1000) 1))) + (test #t (if (and (= a b) (= b c)) + (= a c) + #t))) + +;; From CLtL 12.3. Comparisons on Numbers: +;; +;; Let _a_ be the result of (/ 10.0 single-float-epsilon), and let +;; _j_ be the result of (floor a). ..., all of (<= a j), (< j (+ j +;; 1)), and (<= (+ j 1) a) would be true; transitivity would then +;; imply that (< a a) ought to be true ... + +;; Transliteration from Jussi Piitulainen +(define single-float-epsilon + (do ((eps 1.0 (* eps 2.0))) + ((= eps (+ eps 1.0)) eps))) + +(let* ((a (/ 10.0 single-float-epsilon)) + (j (exact a))) + (test #t (if (and (<= a j) (< j (+ j 1))) + (not (<= (+ j 1) a)) + #t))) + +(test #t (zero? 0)) +(test #t (zero? 0.0)) +;; (test #t (zero? 0.0+0.0i)) +(test #f (zero? 1)) +(test #f (zero? -1)) + +(test #f (positive? 0)) +(test #f (positive? 0.0)) +(test #t (positive? 1)) +(test #t (positive? 1.0)) +(test #f (positive? -1)) +(test #f (positive? -1.0)) +(test #t (positive? +inf.0)) +(test #f (positive? -inf.0)) + +(test #f (negative? 0)) +(test #f (negative? 0.0)) +(test #f (negative? 1)) +(test #f (negative? 1.0)) +(test #t (negative? -1)) +(test #t (negative? -1.0)) +(test #f (negative? +inf.0)) +(test #t (negative? -inf.0)) + +(test #f (odd? 0)) +(test #t (odd? 1)) +(test #t (odd? -1)) +(test #f (odd? 102)) + +(test #t (even? 0)) +(test #f (even? 1)) +(test #t (even? -2)) +(test #t (even? 102)) + +(test 3 (max 3)) +(test 4 (max 3 4)) +(test 4.0 (max 3.9 4)) +(test 5.0 (max 5 3.9 4)) +(test +inf.0 (max 100 +inf.0)) +(test 3 (min 3)) +(test 3 (min 3 4)) +(test 3.0 (min 3 3.1)) +(test -inf.0 (min -inf.0 -100)) + +(test 7 (+ 3 4)) +(test 3 (+ 3)) +(test 0 (+)) +(test 4 (* 4)) +(test 1 (*)) + +(test -1 (- 3 4)) +(test -6 (- 3 4 5)) +(test -3 (- 3)) +(test 3/20 (/ 3 4 5)) +(test 1/3 (/ 3)) + +(test 7 (abs -7)) +(test 7 (abs 7)) + +;; (test-values (values 2 1) (floor/ 5 2)) +;; (test-values (values -3 1) (floor/ -5 2)) +;; (test-values (values -3 -1) (floor/ 5 -2)) +;; (test-values (values 2 -1) (floor/ -5 -2)) +;; (test-values (values 2 1) (truncate/ 5 2)) +;; (test-values (values -2 -1) (truncate/ -5 2)) +;; (test-values (values -2 1) (truncate/ 5 -2)) +;; (test-values (values 2 -1) (truncate/ -5 -2)) +;; (test-values (values 2.0 -1.0) (truncate/ -5.0 -2)) + +(test 1 (modulo 13 4)) +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) +(test -1 (remainder -13 -4)) + +(test -1.0 (remainder -13 -4.0)) + +(test 4 (gcd 32 -36)) +(test 0 (gcd)) +(test 288 (lcm 32 -36)) +(test 288.0 (lcm 32.0 -36)) +(test 1 (lcm)) + +;; (test 3 (numerator (/ 6 4))) +;; (test 2 (denominator (/ 6 4))) +;; (test 2.0 (denominator (inexact (/ 6 4)))) +;; (test 11.0 (numerator 5.5)) +;; (test 2.0 (denominator 5.5)) +;; (test 5.0 (numerator 5.0)) +;; (test 1.0 (denominator 5.0)) + +(test -5.0 (floor -4.3)) +(test -4.0 (ceiling -4.3)) +(test -4.0 (truncate -4.3)) +(test -4.0 (round -4.3)) + +(test 3.0 (floor 3.5)) +(test 4.0 (ceiling 3.5)) +(test 3.0 (truncate 3.5)) +(test 4.0 (round 3.5)) + +(test 4 (round 7/2)) +(test 7 (round 7)) + +;; (test 1/3 (rationalize (exact .3) 1/10)) +;; (test #i1/3 (rationalize .3 1/10)) + +(test 1.0 (inexact (exp 0))) ;; may return exact number +(test 20.0855369231876679236 (exp 3)) + +(test 0.0 (inexact (log 1))) ;; may return exact number +(test 1.0 (log (exp 1))) +(test 42.0 (log (exp 42))) +(test 2.0 (log 100 10)) +(test 12.0 (log 4096 2)) + +(test 0.0 (inexact (sin 0))) ;; may return exact number +(test 1.0 (sin 1.5707963267949)) +(test 1.0 (inexact (cos 0))) ;; may return exact number +(test -1.0 (cos 3.14159265358979)) +(test 0.0 (inexact (tan 0))) ;; may return exact number +(test 1.5574077246549020703 (tan 1)) + +(test 0.0 (asin 0)) +(test 1.5707963267948965580 (asin 1)) +(test 0.0 (acos 1)) +(test 3.1415926535897931160 (acos -1)) + +(test 0.0 (atan 0.0 1.0)) +(test -0.0 (atan -0.0 1.0)) +(test 0.7853981633974482790 (atan 1.0 1.0)) +(test 1.5707963267948965580 (atan 1.0 0.0)) +(test 2.3561944901923448370 (atan 1.0 -1.0)) +(test 3.1415926535897931160 (atan 0.0 -1.0)) +(test -3.1415926535897931160 (atan -0.0 -1.0)) ; +(test -2.3561944901923448370 (atan -1.0 -1.0)) +(test -1.5707963267948965580 (atan -1.0 0.0)) +(test -0.7853981633974482790 (atan -1.0 1.0)) +;; (test undefined (atan 0.0 0.0)) + +(test 1764 (square 42)) +(test 4 (square 2)) + +(test 3.0 (inexact (sqrt 9))) +(test 1.4142135623730951454 (sqrt 2)) +;; (test 0.0+1.0i (inexact (sqrt -1))) + +(test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list)) +(test '(2 1) (call-with-values (lambda () (exact-integer-sqrt 5)) list)) + +(test 27 (expt 3 3)) +(test 1 (expt 0 0)) +(test 0 (expt 0 1)) +(test 1.0 (expt 0.0 0)) +(test 0.0 (expt 0 1.0)) + +;; (test 1+2i (make-rectangular 1 2)) + +;; (test 0.54030230586814+0.841470984807897i (make-polar 1 1)) + +;; (test 1 (real-part 1+2i)) + +;; (test 2 (imag-part 1+2i)) + +;; (test 2.23606797749979 (magnitude 1+2i)) + +;; (test 1.10714871779409 (angle 1+2i)) + +(test 1.0 (inexact 1)) +(test #t (inexact? (inexact 1))) +(test 1 (exact 1.0)) +(test #t (exact? (exact 1.0))) + +(test 100 (string->number "100")) +(test 256 (string->number "100" 16)) +(test 100.0 (string->number "1e2")) + +(test-end) + +(test-begin "6.3 Booleans") + +(test #t #t) +(test #f #f) +(test #f '#f) + +(test #f (not #t)) +(test #f (not 3)) +(test #f (not (list 3))) +(test #t (not #f)) +(test #f (not '())) +(test #f (not (list))) +(test #f (not 'nil)) + +(test #t (boolean? #f)) +(test #f (boolean? 0)) +(test #f (boolean? '())) + +(test #t (boolean=? #t #t)) +(test #t (boolean=? #f #f)) +(test #f (boolean=? #t #f)) +(test #t (boolean=? #f #f #f)) +(test #f (boolean=? #t #t #f)) + +(test-end) + +(test-begin "6.4 Lists") + +(let* ((x (list 'a 'b 'c)) + (y x)) + (test '(a b c) (values y)) + (test #t (list? y)) + (set-cdr! x 4) + (test '(a . 4) (values x)) + (test #t (eqv? x y)) + (test #f (list? y)) + (set-cdr! x x) + (test #f (list? x))) + +(test #t (pair? '(a . b))) +(test #t (pair? '(a b c))) +(test #f (pair? '())) +(test #f (pair? '#(a b))) + +(test '(a) (cons 'a '())) +(test '((a) b c d) (cons '(a) '(b c d))) +(test '("a" b c) (cons "a" '(b c))) +(test '(a . 3) (cons 'a 3)) +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) +(test '(a) (car '((a) b c d))) +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) +(test 2 (cdr '(1 . 2))) +(define (g) '(constant-list)) + +(test #t (list? '(a b c))) +(test #t (list? '())) +(test #f (list? '(a . b))) +(test #f (let ((x (list 'a))) (set-cdr! x x) (list? x))) + +(test '(3 3) (make-list 2 3)) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) +(test '() (list)) + +(test 3 (length '(a b c))) +(test 3 (length '(a (b) (c d e)))) +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) +(test '(a b c d) (append '(a) '(b c d))) +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test '(d e) (list-tail '(a b c d e) 3)) + +(test 'c (list-ref '(a b c d) 2)) +(test 'c (list-ref '(a b c d) + (exact (round 1.8)))) + +(test '(0 ("Sue" "Sue") "Anna") + (let ((lst (list 0 '(2 2 2 2) "Anna"))) + (list-set! lst 1 '("Sue" "Sue")) + lst)) + +(test '(a b c) (memq 'a '(a b c))) +(test '(b c) (memq 'b '(a b c))) +(test #f (memq 'a '(b c d))) +(test #f (memq (list 'a) '(b (a) c))) +(test '((a) c) (member (list 'a) '(b (a) c))) +;; (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?)) +(test '(101 102) (memv 101 '(100 101 102))) + +(let () + (define e '((a 1) (b 2) (c 3))) + (test '(a 1) (assq 'a e)) + (test '(b 2) (assq 'b e)) + (test #f (assq 'd e))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) +(test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =)) +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test '(1 2 3) (list-copy '(1 2 3))) +(test "foo" (list-copy "foo")) +(test '() (list-copy '())) +(test '(3 . 4) (list-copy '(3 . 4))) +(test '(6 7 8 . 9) (list-copy '(6 7 8 . 9))) +(let* ((l1 '((a b) (c d) e)) + (l2 (list-copy l1))) + (test l2 '((a b) (c d) e)) + (test #t (eq? (car l1) (car l2))) + (test #t (eq? (cadr l1) (cadr l2))) + (test #f (eq? (cdr l1) (cdr l2))) + (test #f (eq? (cddr l1) (cddr l2)))) + +(test-end) + +(test-begin "6.5 Symbols") + +(test #t (symbol? 'foo)) +(test #t (symbol? (car '(a b)))) +(test #f (symbol? "bar")) +(test #t (symbol? 'nil)) +(test #f (symbol? '())) +(test #f (symbol? #f)) + +(test #t (symbol=? 'a 'a)) +(test #f (symbol=? 'a 'A)) +(test #t (symbol=? 'a 'a 'a)) +(test #f (symbol=? 'a 'a 'A)) + +(test "flying-fish" +(symbol->string 'flying-fish)) +(test "Martin" (symbol->string 'Martin)) +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test 'mISSISSIppi (string->symbol "mISSISSIppi")) +(test #t (eq? 'bitBlt (string->symbol "bitBlt"))) +(test #t (eq? 'LollyPop (string->symbol (symbol->string 'LollyPop)))) +(test #t (string=? "K. Harper, M.D." + (symbol->string (string->symbol "K. Harper, M.D.")))) + +(test-end) + +(test-begin "6.6 Characters") + +(test #t (char? #\a)) +(test #f (char? "a")) +(test #f (char? 'a)) +(test #f (char? 0)) + +(test #t (char=? #\a #\a #\a)) +(test #f (char=? #\a #\A)) +(test #t (char? #\a #\b)) +(test #f (char>? #\a #\a)) +(test #t (char>? #\c #\b #\a)) +(test #t (char<=? #\a #\b #\b)) +(test #t (char<=? #\a #\a)) +(test #f (char<=? #\b #\a)) +(test #f (char>=? #\a #\b)) +(test #t (char>=? #\a #\a)) +(test #t (char>=? #\b #\b #\a)) + +;; (test #t (char-ci=? #\a #\a)) +;; (test #t (char-ci=? #\a #\A #\a)) +;; (test #f (char-ci=? #\a #\b)) +;; (test #t (char-ci? #\A #\b)) +;; (test #f (char-ci>? #\a #\A)) +;; (test #t (char-ci>? #\c #\B #\a)) +;; (test #t (char-ci<=? #\a #\B #\b)) +;; (test #t (char-ci<=? #\A #\a)) +;; (test #f (char-ci<=? #\b #\A)) +;; (test #f (char-ci>=? #\A #\b)) +;; (test #t (char-ci>=? #\a #\A)) +;; (test #t (char-ci>=? #\b #\B #\a)) + +;; (test #t (char-alphabetic? #\a)) +;; (test #f (char-alphabetic? #\space)) +;; (test #t (char-numeric? #\0)) +;; (test #f (char-numeric? #\.)) +;; (test #f (char-numeric? #\a)) +;; (test #t (char-whitespace? #\space)) +;; (test #t (char-whitespace? #\tab)) +;; (test #t (char-whitespace? #\newline)) +;; (test #f (char-whitespace? #\_)) +;; (test #f (char-whitespace? #\a)) +;; (test #t (char-upper-case? #\A)) +;; (test #f (char-upper-case? #\a)) +;; (test #f (char-upper-case? #\3)) +;; (test #t (char-lower-case? #\a)) +;; (test #f (char-lower-case? #\A)) +;; (test #f (char-lower-case? #\3)) + +;; (test #t (char-alphabetic? #\Λ)) +;; (test #f (char-alphabetic? #\x0E50)) +;; (test #t (char-upper-case? #\Λ)) +;; (test #f (char-upper-case? #\λ)) +;; (test #f (char-lower-case? #\Λ)) +;; (test #t (char-lower-case? #\λ)) +;; (test #f (char-numeric? #\Λ)) +;; (test #t (char-numeric? #\x0E50)) +;; (test #t (char-whitespace? #\x1680)) + +;; (test 0 (digit-value #\0)) +;; (test 3 (digit-value #\3)) +;; (test 9 (digit-value #\9)) +;; (test 4 (digit-value #\x0664)) +;; (test 0 (digit-value #\x0AE6)) +;; (test #f (digit-value #\.)) +;; (test #f (digit-value #\-)) + +(test 97 (char->integer #\a)) +(test #\a (integer->char 97)) + +;; (test #\A (char-upcase #\a)) +;; (test #\A (char-upcase #\A)) +;; (test #\a (char-downcase #\a)) +;; (test #\a (char-downcase #\A)) +;; (test #\a (char-foldcase #\a)) +;; (test #\a (char-foldcase #\A)) + +;; (test #\Λ (char-upcase #\λ)) +;; (test #\Λ (char-upcase #\Λ)) +;; (test #\λ (char-downcase #\λ)) +;; (test #\λ (char-downcase #\Λ)) +;; (test #\λ (char-foldcase #\λ)) +;; (test #\λ (char-foldcase #\Λ)) + +(test-end) + +(test-begin "6.7 Strings") + +(test #t (string? "")) +(test #t (string? " ")) +(test #f (string? 'a)) +(test #f (string? #\a)) + +(test 3 (string-length (make-string 3))) +(test "---" (make-string 3 #\-)) + +(test "" (string)) +(test "---" (string #\- #\- #\-)) +(test "kitten" (string #\k #\i #\t #\t #\e #\n)) + +(test 0 (string-length "")) +(test 1 (string-length "a")) +(test 3 (string-length "abc")) + +(test #\a (string-ref "abc" 0)) +(test #\b (string-ref "abc" 1)) +(test #\c (string-ref "abc" 2)) + +(test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str)) + +;; (test (string #\a #\x1F700 #\c) +;; (let ((s (string #\a #\b #\c))) +;; (string-set! s 1 #\x1F700) +;; s)) + +(test #t (string=? "" "")) +(test #t (string=? "abc" "abc" "abc")) +(test #f (string=? "" "abc")) +(test #f (string=? "abc" "aBc")) + +(test #f (string? "" "")) +(test #f (string>? "abc" "abc")) +(test #f (string>? "abc" "abcd")) +(test #t (string>? "acd" "abcd" "abc")) +(test #f (string>? "abc" "bbc")) + +(test #t (string<=? "" "")) +(test #t (string<=? "abc" "abc")) +(test #t (string<=? "abc" "abcd" "abcd")) +(test #f (string<=? "abcd" "abc")) +(test #t (string<=? "abc" "bbc")) + +(test #t (string>=? "" "")) +(test #t (string>=? "abc" "abc")) +(test #f (string>=? "abc" "abcd")) +(test #t (string>=? "abcd" "abcd" "abc")) +(test #f (string>=? "abc" "bbc")) + +;; (test #t (string-ci=? "" "")) +;; (test #t (string-ci=? "abc" "abc")) +;; (test #f (string-ci=? "" "abc")) +;; (test #t (string-ci=? "abc" "aBc")) +;; (test #f (string-ci=? "abc" "aBcD")) + +;; (test #f (string-ci? "abc" "aBc")) +;; (test #f (string-ci>? "abc" "aBcD")) +;; (test #t (string-ci>? "ABCd" "aBc")) + +;; (test #t (string-ci<=? "abc" "aBc")) +;; (test #t (string-ci<=? "abc" "aBcD")) +;; (test #f (string-ci<=? "ABCd" "aBc")) + +;; (test #t (string-ci>=? "abc" "aBc")) +;; (test #f (string-ci>=? "abc" "aBcD")) +;; (test #t (string-ci>=? "ABCd" "aBc")) + +;; (test #t (string-ci=? "ΑΒΓ" "αβγ" "αβγ")) +;; (test #f (string-ci? "ΑΒΓ" "αβγ")) +;; (test #t (string-ci<=? "ΑΒΓ" "αβγ")) +;; (test #t (string-ci>=? "ΑΒΓ" "αβγ")) + +;; ;; latin +;; (test "ABC" (string-upcase "abc")) +;; (test "ABC" (string-upcase "ABC")) +;; (test "abc" (string-downcase "abc")) +;; (test "abc" (string-downcase "ABC")) +;; (test "abc" (string-foldcase "abc")) +;; (test "abc" (string-foldcase "ABC")) + +;; ;; cyrillic +;; (test "ΑΒΓ" (string-upcase "αβγ")) +;; (test "ΑΒΓ" (string-upcase "ΑΒΓ")) +;; (test "αβγ" (string-downcase "αβγ")) +;; (test "αβγ" (string-downcase "ΑΒΓ")) +;; (test "αβγ" (string-foldcase "αβγ")) +;; (test "αβγ" (string-foldcase "ΑΒΓ")) + +;; ;; special cases +;; (test "SSA" (string-upcase "ßa")) +;; (test "ßa" (string-downcase "ßa")) +;; (test "ssa" (string-downcase "SSA")) +;; (test "İ" (string-upcase "İ")) +;; (test "i\x0307;" (string-downcase "İ")) +;; (test "i\x0307;" (string-foldcase "İ")) +;; (test "J̌" (string-upcase "ǰ")) + +;; ;; context-sensitive (final sigma) +;; (test "ΓΛΏΣΣΑ" (string-upcase "γλώσσα")) +;; (test "γλώσσα" (string-downcase "ΓΛΏΣΣΑ")) +;; (test "γλώσσα" (string-foldcase "ΓΛΏΣΣΑ")) +;; (test "ΜΈΛΟΣ" (string-upcase "μέλος")) +;; (test #t (and (member (string-downcase "ΜΈΛΟΣ") '("μέλος" "μέλοσ")) #t)) +;; (test "μέλοσ" (string-foldcase "ΜΈΛΟΣ")) +;; (test #t (and (member (string-downcase "ΜΈΛΟΣ ΕΝΌΣ") +;; '("μέλος ενός" "μέλοσ ενόσ")) +;; #t)) + +(test "" (substring "" 0 0)) +(test "" (substring "a" 0 0)) +(test "" (substring "abc" 1 1)) +(test "ab" (substring "abc" 0 2)) +(test "bc" (substring "abc" 1 3)) + +(test "" (string-append "")) +(test "" (string-append "" "")) +(test "abc" (string-append "" "abc")) +(test "abc" (string-append "abc" "")) +(test "abcde" (string-append "abc" "de")) +(test "abcdef" (string-append "abc" "de" "f")) + +(test '() (string->list "")) +(test '(#\a) (string->list "a")) +(test '(#\a #\b #\c) (string->list "abc")) +(test '(#\a #\b #\c) (string->list "abc" 0)) +(test '(#\b #\c) (string->list "abc" 1)) +(test '(#\b #\c) (string->list "abc" 1 3)) +(test "" (list->string '())) +(test "abc" (list->string '(#\a #\b #\c))) + +(test "" (string-copy "")) +(test "" (string-copy "" 0)) +(test "" (string-copy "" 0 0)) +(test "abc" (string-copy "abc")) +(test "abc" (string-copy "abc" 0)) +(test "bc" (string-copy "abc" 1)) +(test "b" (string-copy "abc" 1 2)) +(test "bc" (string-copy "abc" 1 3)) + +(test "-----" + (let ((str (make-string 5 #\x))) (string-fill! str #\-) str)) +(test "xx---" + (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str)) +(test "xx-xx" + (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str)) + +(test "a12de" + (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str)) +(test "-----" + (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str)) +(test "---xx" + (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str)) +(test "xx---" + (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str)) +(test "xx-xx" + (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str)) + +;; same source and dest +(test "aabde" + (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str)) +(test "abcab" + (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str)) + +(test-end) + +(test-begin "6.8 Vectors") + +(test #t (vector? #())) +(test #t (vector? #(1 2 3))) +(test #t (vector? '#(1 2 3))) + +(test 0 (vector-length (make-vector 0))) +(test 1000 (vector-length (make-vector 1000))) + +(test #(0 (2 2 2 2) "Anna") '#(0 (2 2 2 2) "Anna")) + +(test #(a b c) (vector 'a 'b 'c)) + +(test 8 (vector-ref '#(1 1 2 3 5 8 13 21) 5)) +(test 13 (vector-ref '#(1 1 2 3 5 8 13 21) + (let ((i (round (* 2 (acos -1))))) + (if (inexact? i) + (exact i) + i)))) + +(test #(0 ("Sue" "Sue") "Anna") (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) +(test '(dah didah) (vector->list '#(dah dah didah) 1)) +(test '(dah) (vector->list '#(dah dah didah) 1 2)) +(test #(dididit dah) (list->vector '(dididit dah))) + +(test #() (string->vector "")) +(test #(#\A #\B #\C) (string->vector "ABC")) +(test #(#\B #\C) (string->vector "ABC" 1)) +(test #(#\B) (string->vector "ABC" 1 2)) + +(test "" (vector->string #())) +(test "123" (vector->string #(#\1 #\2 #\3))) +(test "23" (vector->string #(#\1 #\2 #\3) 1)) +(test "2" (vector->string #(#\1 #\2 #\3) 1 2)) + +(test #() (vector-copy #())) +(test #(a b c) (vector-copy #(a b c))) +(test #(b c) (vector-copy #(a b c) 1)) +(test #(b) (vector-copy #(a b c) 1 2)) + +(test #() (vector-append #())) +(test #() (vector-append #() #())) +(test #(a b c) (vector-append #() #(a b c))) +(test #(a b c) (vector-append #(a b c) #())) +(test #(a b c d e) (vector-append #(a b c) #(d e))) +(test #(a b c d e f) (vector-append #(a b c) #(d e) #(f))) + +(test #(1 2 smash smash 5) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec)) +(test #(x x x x x) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec)) +(test #(1 2 x x x) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec)) +(test #(1 2 x 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec)) + +(test #(1 a b 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 #(a b c d e) 0 2) vec)) +(test #(a b c d e) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e)) vec)) +(test #(c d e 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e) 2) vec)) +(test #(1 2 a b c) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 0 3) vec)) +(test #(1 2 c 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 2 3) vec)) + +;; same source and dest +(test #(1 1 2 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 vec 0 2) vec)) +(test #(1 2 3 1 2) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 3 vec 0 2) vec)) + +(test-end) + +(test-begin "6.9 Bytevectors") + +(test #t (bytevector? #u8())) +(test #t (bytevector? #u8(0 1 2))) +(test #f (bytevector? #())) +(test #f (bytevector? #(0 1 2))) +(test #f (bytevector? '())) +(test #t (bytevector? (make-bytevector 0))) + +(test 0 (bytevector-length (make-bytevector 0))) +(test 1024 (bytevector-length (make-bytevector 1024))) +(test 1024 (bytevector-length (make-bytevector 1024 255))) + +(test 3 (bytevector-length (bytevector 0 1 2))) + +(test 0 (bytevector-u8-ref (bytevector 0 1 2) 0)) +(test 1 (bytevector-u8-ref (bytevector 0 1 2) 1)) +(test 2 (bytevector-u8-ref (bytevector 0 1 2) 2)) + +(test #u8(0 255 2) + (let ((bv (bytevector 0 1 2))) (bytevector-u8-set! bv 1 255) bv)) + +(test #u8() (bytevector-copy #u8())) +(test #u8(0 1 2) (bytevector-copy #u8(0 1 2))) +(test #u8(1 2) (bytevector-copy #u8(0 1 2) 1)) +(test #u8(1) (bytevector-copy #u8(0 1 2) 1 2)) + +(test #u8(1 6 7 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 1 #u8(6 7 8 9 10) 0 2) + bv)) +(test #u8(6 7 8 9 10) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 0 #u8(6 7 8 9 10)) + bv)) +(test #u8(8 9 10 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 0 #u8(6 7 8 9 10) 2) + bv)) +(test #u8(1 2 6 7 8) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 2 #u8(6 7 8 9 10) 0 3) + bv)) +(test #u8(1 2 8 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 2 #u8(6 7 8 9 10) 2 3) + bv)) + +;; same source and dest +(test #u8(1 1 2 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 1 bv 0 2) + bv)) +(test #u8(1 2 3 1 2) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 3 bv 0 2) + bv)) + +(test #u8() (bytevector-append #u8())) +(test #u8() (bytevector-append #u8() #u8())) +(test #u8(0 1 2) (bytevector-append #u8() #u8(0 1 2))) +(test #u8(0 1 2) (bytevector-append #u8(0 1 2) #u8())) +(test #u8(0 1 2 3 4) (bytevector-append #u8(0 1 2) #u8(3 4))) +(test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1 2) #u8(3 4) #u8(5))) + +;; (test "ABC" (utf8->string #u8(#x41 #x42 #x43))) +;; (test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1)) +;; (test "ABC" (utf8->string #u8(0 #x41 #x42 #x43 0) 1 4)) +;; (test "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3)) +;; (test #u8(#x41 #x42 #x43) (string->utf8 "ABC")) +;; (test #u8(#x42 #x43) (string->utf8 "ABC" 1)) +;; (test #u8(#x42) (string->utf8 "ABC" 1 2)) +;; (test #u8(#xCE #xBB) (string->utf8 "λ")) + +(test-end) + +(test-begin "6.10 Control Features") + +(test #t (procedure? car)) +(test #f (procedure? 'car)) +(test #t (procedure? (lambda (x) (* x x)))) +(test #f (procedure? '(lambda (x) (* x x)))) +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) + +(define compose + (lambda (f g) + (lambda args + (f (apply g args))))) +(test '(30 0) + (call-with-values (lambda () ((compose exact-integer-sqrt *) 12 75)) + list)) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6 7))) + +(test #t + (let ((res (let ((count 0)) + (map (lambda (ignored) + (set! count (+ count 1)) + count) + '(a b))))) + (or (equal? res '(1 2)) + (equal? res '(2 1))))) + +(test '(10 200 3000 40 500 6000) + (let ((ls1 (list 10 100 1000)) + (ls2 (list 1 2 3 4 5 6))) + (set-cdr! (cddr ls1) ls1) + (map * ls1 ls2))) + +;; (test "abdegh" (string-map char-foldcase "AbdEgH")) + +(test "IBM" (string-map + (lambda (c) + (integer->char (+ 1 (char->integer c)))) + "HAL")) + +;; (test "StUdLyCaPs" +;; (string-map +;; (lambda (c k) (if (eqv? k #\u) (char-upcase c) (char-downcase c))) +;; "studlycaps xxx" +;; "ululululul")) + +(test #(b e h) (vector-map cadr '#((a b) (d e) (g h)))) + +(test #(1 4 27 256 3125) + (vector-map (lambda (n) (expt n n)) + '#(1 2 3 4 5))) + +(test #(5 7 9) (vector-map + '#(1 2 3) '#(4 5 6 7))) + +(test #t + (let ((res (let ((count 0)) + (vector-map + (lambda (ignored) + (set! count (+ count 1)) + count) + '#(a b))))) + (or (equal? res #(1 2)) + (equal? res #(2 1))))) + +(test #(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each (lambda (i) + (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 9750 + (let ((ls1 (list 10 100 1000)) + (ls2 (list 1 2 3 4 5 6)) + (count 0)) + (set-cdr! (cddr ls1) ls1) + (for-each (lambda (x y) (set! count (+ count (* x y)))) ls2 ls1) + count)) + +(test '(101 100 99 98 97) + (let ((v '())) + (string-for-each + (lambda (c) (set! v (cons (char->integer c) v))) + "abcde") + v)) + +(test '(0 1 4 9 16) (let ((v (make-list 5))) + (vector-for-each + (lambda (i) (list-set! v i (* i i))) + '#(0 1 2 3 4)) + v)) + +(test -3 (call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t))) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r + (lambda (obj) + (cond ((null? obj) 0) + ((pair? obj) + (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) + +(test 4 (list-length '(1 2 3 4))) + +(test #f (list-length '(a b . c))) + +(test 5 + (call-with-values (lambda () (values 4 5)) + (lambda (a b) b))) + +(test -1 (call-with-values * -)) + +#; +(test '(connect talk1 disconnect + connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test-end) + +(test-begin "6.11 Exceptions") + +;; (test 65 +;; (with-exception-handler +;; (lambda (con) 42) +;; (lambda () +;; (+ (raise-continuable "should be a number") +;; 23)))) + +;; (test #t +;; (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +;; (test "BOOM!" +;; (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +;; (test '(1 2 3) +;; (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) + +;; (test #f +;; (file-error? (guard (exn (else exn)) (error "BOOM!")))) +;; (test #t +;; (file-error? (guard (exn (else exn)) (open-input-file " no such file ")))) + +;; (test #f +;; (read-error? (guard (exn (else exn)) (error "BOOM!")))) +;; (test #t +;; (read-error? (guard (exn (else exn)) (read (open-input-string ")"))))) + +(define something-went-wrong #f) +(define (test-exception-handler-1 v) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) + (set! something-went-wrong (list "condition: " x)) + (k 'exception)) + (lambda () + (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))) +(test 106 (test-exception-handler-1 5)) +(test #f something-went-wrong) +(test 'exception (test-exception-handler-1 -1)) +(test '("condition: " an-error) something-went-wrong) + +(set! something-went-wrong #f) +;; (define (test-exception-handler-2 v) +;; (guard (ex (else 'caught-another-exception)) +;; (with-exception-handler +;; (lambda (x) +;; (set! something-went-wrong #t) +;; (list "exception:" x)) +;; (lambda () +;; (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))) +;; (test 106 (test-exception-handler-2 5)) +;; (test #f something-went-wrong) +;; (test 'caught-another-exception (test-exception-handler-2 -1)) +;; (test #t something-went-wrong) + +;; Based on an example from R6RS-lib section 7.1 Exceptions. +;; R7RS section 6.11 Exceptions has a simplified version. +;; (let* ((out (open-output-string)) +;; (value (with-exception-handler +;; (lambda (con) +;; (cond +;; ((not (list? con)) +;; (raise con)) +;; ((list? con) +;; (display (car con) out)) +;; (else +;; (display "a warning has been issued" out))) +;; 42) +;; (lambda () +;; (+ (raise-continuable +;; (list "should be a number")) +;; 23))))) +;; (test "should be a number" (get-output-string out)) +;; (test 65 value)) + +;; From SRFI-34 "Examples" section - #3 +;; (define (test-exception-handler-3 v out) +;; (guard (condition +;; (else +;; (display "condition: " out) +;; (write condition out) +;; (display #\! out) +;; 'exception)) +;; (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v))))) +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-3 0 out))) +;; (test 'exception value) +;; (test "condition: an-error!" (get-output-string out))) + +;; (define (test-exception-handler-4 v out) +;; (call-with-current-continuation +;; (lambda (k) +;; (with-exception-handler +;; (lambda (x) +;; (display "reraised " out) +;; (write x out) (display #\! out) +;; (k 'zero)) +;; (lambda () +;; (guard (condition +;; ((positive? condition) +;; 'positive) +;; ((negative? condition) +;; 'negative)) +;; (raise v))))))) + +;; From SRFI-34 "Examples" section - #5 +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-4 1 out))) +;; (test "" (get-output-string out)) +;; (test 'positive value)) +;; ;; From SRFI-34 "Examples" section - #6 +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-4 -1 out))) +;; (test "" (get-output-string out)) +;; (test 'negative value)) +;; ;; From SRFI-34 "Examples" section - #7 +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-4 0 out))) +;; (test "reraised 0!" (get-output-string out)) +;; (test 'zero value)) + +;; From SRFI-34 "Examples" section - #8 +;; (test 42 +;; (guard (condition +;; ((assq 'a condition) => cdr) +;; ((assq 'b condition))) +;; (raise (list (cons 'a 42))))) + +;; ;; From SRFI-34 "Examples" section - #9 +;; (test '(b . 23) +;; (guard (condition +;; ((assq 'a condition) => cdr) +;; ((assq 'b condition))) +;; (raise (list (cons 'b 23))))) + +;; (test 'caught-d +;; (guard (condition +;; ((assq 'c condition) 'caught-c) +;; ((assq 'd condition) 'caught-d)) +;; (list +;; (sqrt 8) +;; (guard (condition +;; ((assq 'a condition) => cdr) +;; ((assq 'b condition))) +;; (raise (list (cons 'd 24))))))) + +(test-end) + +(test-begin "6.12 Environments and evaluation") + +;; (test 21 (eval '(* 7 3) (scheme-report-environment 5))) + +;; (test 20 +;; (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) +;; (f + 10))) + +;; (test 1024 (eval '(expt 2 10) (environment '(scheme base)))) +;; ;; (sin 0) may return exact number +;; (test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact))))) +;; ;; ditto +;; (test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0))) +;; (environment '(scheme base) '(scheme inexact)))) + +(test-end) + +(test-begin "6.13 Input and output") + +(test #t (port? (current-input-port))) +(test #t (input-port? (current-input-port))) +(test #t (output-port? (current-output-port))) +(test #t (output-port? (current-error-port))) +(test #t (input-port? (open-input-string "abc"))) +(test #t (output-port? (open-output-string))) + +(test #t (textual-port? (open-input-string "abc"))) +(test #t (textual-port? (open-output-string))) +(test #t (binary-port? (open-input-bytevector #u8(0 1 2)))) +(test #t (binary-port? (open-output-bytevector))) + +(test #t (input-port-open? (open-input-string "abc"))) +(test #t (output-port-open? (open-output-string))) + +(test #f + (let ((in (open-input-string "abc"))) + (close-input-port in) + (input-port-open? in))) + +(test #f + (let ((out (open-output-string))) + (close-output-port out) + (output-port-open? out))) + +(test #f + (let ((out (open-output-string))) + (close-port out) + (output-port-open? out))) + +(test #t (eof-object? (eof-object))) +(test #t (eof-object? (read (open-input-string "")))) +(test #t (char-ready? (open-input-string "42"))) +(test 42 (read (open-input-string " 42 "))) + +(test #t (eof-object? (read-char (open-input-string "")))) +(test #\a (read-char (open-input-string "abc"))) + +(test #t (eof-object? (read-line (open-input-string "")))) +(test "abc" (read-line (open-input-string "abc"))) +(test "abc" (read-line (open-input-string "abc\ndef\n"))) + +(test #t (eof-object? (read-string 3 (open-input-string "")))) +(test "abc" (read-string 3 (open-input-string "abcd"))) +(test "abc" (read-string 3 (open-input-string "abc\ndef\n"))) + +;; (let ((in (open-input-string (string #\x10F700 #\x10F701 #\x10F702)))) +;; (let* ((c1 (read-char in)) +;; (c2 (read-char in)) +;; (c3 (read-char in))) +;; (test #\x10F700 c1) +;; (test #\x10F701 c2) +;; (test #\x10F702 c3))) + +;; (test (string #\x10F700) +;; (let ((out (open-output-string))) +;; (write-char #\x10F700 out) +;; (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (write 'abc out) + (get-output-string out))) + +(test "abc def" + (let ((out (open-output-string))) + (display "abc def" out) + (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (display #\a out) + (display "b" out) + (display #\c out) + (get-output-string out))) + +(test #t + (let* ((out (open-output-string)) + (r (begin (newline out) (get-output-string out)))) + (or (equal? r "\n") (equal? r "\r\n")))) + +(test "abc def" + (let ((out (open-output-string))) + (write-string "abc def" out) + (get-output-string out))) + +(test "def" + (let ((out (open-output-string))) + (write-string "abc def" out 4) + (get-output-string out))) + +(test "c d" + (let ((out (open-output-string))) + (write-string "abc def" out 2 5) + (get-output-string out))) + +(test "" + (let ((out (open-output-string))) + (flush-output-port out) + (get-output-string out))) + +(test #t (eof-object? (read-u8 (open-input-bytevector #u8())))) +(test 1 (read-u8 (open-input-bytevector #u8(1 2 3)))) + +(test #t (eof-object? (read-bytevector 3 (open-input-bytevector #u8())))) +(test #t (u8-ready? (open-input-bytevector #u8(1)))) +(test #u8(1) (read-bytevector 3 (open-input-bytevector #u8(1)))) +(test #u8(1 2) (read-bytevector 3 (open-input-bytevector #u8(1 2)))) +(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3)))) +(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3 4)))) + +(test #t + (let ((bv (bytevector 1 2 3 4 5))) + (eof-object? (read-bytevector! bv (open-input-bytevector #u8()))))) + +(test #u8(6 7 8 9 10) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 5) + bv)) + +(test #u8(6 7 8 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 3) + bv)) + +(test #u8(1 2 3 6 5) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 3 4) + bv)) + +(test #u8(1 2 3) + (let ((out (open-output-bytevector))) + (write-u8 1 out) + (write-u8 2 out) + (write-u8 3 out) + (get-output-bytevector out))) + +(test #u8(1 2 3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out) + (get-output-bytevector out))) + +(test #u8(3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2) + (get-output-bytevector out))) + +(test #u8(3 4) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2 4) + (get-output-bytevector out))) + +(test #u8() + (let ((out (open-output-bytevector))) + (flush-output-port out) + (get-output-bytevector out))) + +(test #t + (and (member + (let ((out (open-output-string)) + (x (list 1))) + (set-cdr! x x) + (write x out) + (get-output-string out)) + ;; labels not guaranteed to be 0 indexed, spacing may differ + '("#0=(1 . #0#)" "#1=(1 . #1#)")) + #t)) + +(test "((1 2 3) (1 2 3))" + (let ((out (open-output-string)) + (x (list 1 2 3))) + (write (list x x) out) + (get-output-string out))) + +(test "((1 2 3) (1 2 3))" + (let ((out (open-output-string)) + (x (list 1 2 3))) + (write-simple (list x x) out) + (get-output-string out))) + +(test #t + (and (member (let ((out (open-output-string)) + (x (list 1 2 3))) + (write-shared (list x x) out) + (get-output-string out)) + '("(#0=(1 2 3) #0#)" "(#1=(1 2 3) #1#)")) + #t)) + +(test-begin "Read syntax") + +;; check reading boolean followed by eof +(test #t (read (open-input-string "#t"))) +(test #t (read (open-input-string "#true"))) +(test #f (read (open-input-string "#f"))) +(test #f (read (open-input-string "#false"))) +(define (read2 port) + (let* ((o1 (read port)) (o2 (read port))) + (cons o1 o2))) +;; check reading boolean followed by delimiter +(test '(#t . (5)) (read2 (open-input-string "#t(5)"))) +(test '(#t . 6) (read2 (open-input-string "#true 6 "))) +(test '(#f . 7) (read2 (open-input-string "#f 7"))) +(test '(#f . "8") (read2 (open-input-string "#false\"8\""))) + +(test '() (read (open-input-string "()"))) +(test '(1 2) (read (open-input-string "(1 2)"))) +(test '(1 . 2) (read (open-input-string "(1 . 2)"))) +(test '(1 2) (read (open-input-string "(1 . (2))"))) +(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))"))) +(test '1 (cadr (read (open-input-string "#0=(1 . #0#)")))) +(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)")))) + +(test '(quote (1 2)) (read (open-input-string "'(1 2)"))) +(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)"))) +(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)"))) +(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)"))) + +(test #() (read (open-input-string "#()"))) +(test #(a b) (read (open-input-string "#(a b)"))) + +(test #u8() (read (open-input-string "#u8()"))) +(test #u8(0 1) (read (open-input-string "#u8(0 1)"))) + +(test 'abc (read (open-input-string "abc"))) +(test 'abc (read (open-input-string "abc def"))) +(test 'ABC (read (open-input-string "ABC"))) +(test 'Hello (read (open-input-string "|H\\x65;llo|"))) + +(test 'abc (read (open-input-string "#!fold-case ABC"))) +(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC"))) + +(test 'def (read (open-input-string "#; abc def"))) +(test 'def (read (open-input-string "; abc \ndef"))) +(test 'def (read (open-input-string "#| abc |# def"))) +(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi"))) +(test 'ghi (read (open-input-string "#; ; abc\n def ghi"))) +(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)"))) +(test '(a d) (read (open-input-string "(a #; #;b c d)"))) +(test '(a e) (read (open-input-string "(a #;(b #;c d) e)"))) +(test '(a . c) (read (open-input-string "(a . #;b c)"))) +(test '(a . b) (read (open-input-string "(a . b #;c)"))) + +;; (define (test-read-error str) +;; (test-assert +;; (guard (exn (else #t)) +;; (read (open-input-string str)) +;; #f))) + +;; (test-read-error "(#;a . b)") +;; (test-read-error "(a . #;b)") +;; (test-read-error "(a #;. b)") +;; (test-read-error "(#;x #;y . z)") +;; (test-read-error "(#; #;x #;y . z)") +;; (test-read-error "(#; #;x . z)") + +;; (test #\a (read (open-input-string "#\\a"))) +;; (test #\space (read (open-input-string "#\\space"))) +;; (test 0 (char->integer (read (open-input-string "#\\null")))) +;; (test 7 (char->integer (read (open-input-string "#\\alarm")))) +;; (test 8 (char->integer (read (open-input-string "#\\backspace")))) +;; (test 9 (char->integer (read (open-input-string "#\\tab")))) +;; (test 10 (char->integer (read (open-input-string "#\\newline")))) +;; (test 13 (char->integer (read (open-input-string "#\\return")))) +;; (test #x7F (char->integer (read (open-input-string "#\\delete")))) +;; (test #x1B (char->integer (read (open-input-string "#\\escape")))) +;; (test #x03BB (char->integer (read (open-input-string "#\\λ")))) +;; (test #x03BB (char->integer (read (open-input-string "#\\x03BB")))) + +;; (test "abc" (read (open-input-string "\"abc\""))) +;; (test "abc" (read (open-input-string "\"abc\" \"def\""))) +;; (test "ABC" (read (open-input-string "\"ABC\""))) +;; (test "Hello" (read (open-input-string "\"H\\x65;llo\""))) +;; (test 7 (char->integer (string-ref (read (open-input-string "\"\\a\"")) 0))) +;; (test 8 (char->integer (string-ref (read (open-input-string "\"\\b\"")) 0))) +;; (test 9 (char->integer (string-ref (read (open-input-string "\"\\t\"")) 0))) +;; (test 10 (char->integer (string-ref (read (open-input-string "\"\\n\"")) 0))) +;; (test 13 (char->integer (string-ref (read (open-input-string "\"\\r\"")) 0))) +;; (test #x22 (char->integer (string-ref (read (open-input-string "\"\\\"\"")) 0))) +;; (test #x7C (char->integer (string-ref (read (open-input-string "\"\\|\"")) 0))) +;; (test "line 1\nline 2\n" (read (open-input-string "\"line 1\nline 2\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\\ncontinued\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\ \ncontinued\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\\n continued\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\ \t \n \t continued\n\""))) +;; (test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\""))) +;; (test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0))) + +(test-end) + +(test-begin "Numeric syntax") + +;; Numeric syntax adapted from Peter Bex's tests. +;; +;; These are updated to R7RS, using string ports instead of +;; string->number, and "error" tests removed because implementations +;; are free to provide their own numeric extensions. Currently all +;; tests are run by default - need to cond-expand and test for +;; infinities and -0.0. + +;; (define-syntax test-numeric-syntax +;; (syntax-rules () +;; ((test-numeric-syntax str expect strs ...) +;; (let* ((z (read (open-input-string str))) +;; (out (open-output-string)) +;; (z-str (begin (write z out) (get-output-string out)))) +;; (test expect (values z)) +;; (test #t (and (member z-str '(str strs ...)) #t)))))) + +;; Each test is of the form: +;; +;; (test-numeric-syntax input-str expected-value expected-write-values ...) +;; +;; where the input should be eqv? to the expected-value, and the +;; written output the same as any of the expected-write-values. The +;; form +;; +;; (test-numeric-syntax input-str expected-value) +;; +;; is a shorthand for +;; +;; (test-numeric-syntax input-str expected-value (input-str)) + +;; Simple +;; (test-numeric-syntax "1" 1) +;; (test-numeric-syntax "+1" 1 "1") +;; (test-numeric-syntax "-1" -1) +;; (test-numeric-syntax "#i1" 1.0 "1.0" "1.") +;; (test-numeric-syntax "#I1" 1.0 "1.0" "1.") +;; (test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.") +;; ;; Decimal +;; (test-numeric-syntax "1.0" 1.0 "1.0" "1.") +;; (test-numeric-syntax "1." 1.0 "1.0" "1.") +;; (test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3") +;; (test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3") +;; ;; Some Schemes don't allow negative zero. This is okay with the standard +;; (test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0") +;; (test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0") +;; (test-numeric-syntax "#i1.0" 1.0 "1.0" "1.") +;; (test-numeric-syntax "#e1.0" 1 "1") +;; (test-numeric-syntax "#e-.0" 0 "0") +;; (test-numeric-syntax "#e-0." 0 "0") +;; ;; Decimal notation with suffix +;; (test-numeric-syntax "1e2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1E2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1s2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1S2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1f2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1F2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1d2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1D2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1l2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1L2" 100.0 "100.0" "100.") +;; ;; NaN, Inf +;; (test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0") +;; (test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0") +;; (test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0") +;; (test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0") +;; (test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0") +;; (test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0") +;; (test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0") +;; (test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0") +;; (test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0") +;; ;; Exact ratios +;; (test-numeric-syntax "1/2" (/ 1 2)) +;; (test-numeric-syntax "#e1/2" (/ 1 2) "1/2") +;; (test-numeric-syntax "10/2" 5 "5") +;; (test-numeric-syntax "-1/2" (- (/ 1 2))) +;; (test-numeric-syntax "0/10" 0 "0") +;; (test-numeric-syntax "#e0/10" 0 "0") +;; (test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5") +;; ;; Exact complex +;; (test-numeric-syntax "1+2i" (make-rectangular 1 2)) +;; (test-numeric-syntax "1+2I" (make-rectangular 1 2) "1+2i") +;; (test-numeric-syntax "1-2i" (make-rectangular 1 -2)) +;; (test-numeric-syntax "-1+2i" (make-rectangular -1 2)) +;; (test-numeric-syntax "-1-2i" (make-rectangular -1 -2)) +;; (test-numeric-syntax "+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +;; (test-numeric-syntax "0+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +;; (test-numeric-syntax "0+1i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +;; (test-numeric-syntax "-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +;; (test-numeric-syntax "0-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +;; (test-numeric-syntax "0-1i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +;; (test-numeric-syntax "+2i" (make-rectangular 0 2) "2i" "+2i" "0+2i") +;; (test-numeric-syntax "-2i" (make-rectangular 0 -2) "-2i" "0-2i") +;; ;; Decimal-notation complex numbers (rectangular notation) +;; (test-numeric-syntax "1.0+2i" (make-rectangular 1.0 2) "1.0+2.0i" "1.0+2i" "1.+2i" "1.+2.i") +;; (test-numeric-syntax "1+2.0i" (make-rectangular 1 2.0) "1.0+2.0i" "1+2.0i" "1.+2.i" "1+2.i") +;; (test-numeric-syntax "1e2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i") +;; (test-numeric-syntax "1s2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i") +;; (test-numeric-syntax "1.0+1e2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i") +;; (test-numeric-syntax "1.0+1s2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i") +;; ;; Fractional complex numbers (rectangular notation) +;; (test-numeric-syntax "1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4))) +;; ;; Mixed fractional/decimal notation complex numbers (rectangular notation) +;; (test-numeric-syntax "0.5+3/4i" (make-rectangular 0.5 (/ 3 4)) +;; "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i") +;; ;; Complex NaN, Inf (rectangular notation) +;; ;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i") +;; (test-numeric-syntax "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0) "+Inf.0+Inf.0i") +;; (test-numeric-syntax "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0) "-Inf.0+Inf.0i") +;; (test-numeric-syntax "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0) "-Inf.0-Inf.0i") +;; (test-numeric-syntax "+inf.0-inf.0i" (make-rectangular +inf.0 -inf.0) "+Inf.0-Inf.0i") +;; ;; Complex numbers (polar notation) +;; ;; Need to account for imprecision in write output. +;; ;;(test-numeric-syntax "1@2" -0.416146836547142+0.909297426825682i "-0.416146836547142+0.909297426825682i") +;; ;; Base prefixes +;; (test-numeric-syntax "#x11" 17 "17") +;; (test-numeric-syntax "#X11" 17 "17") +;; (test-numeric-syntax "#d11" 11 "11") +;; (test-numeric-syntax "#D11" 11 "11") +;; (test-numeric-syntax "#o11" 9 "9") +;; (test-numeric-syntax "#O11" 9 "9") +;; (test-numeric-syntax "#b11" 3 "3") +;; (test-numeric-syntax "#B11" 3 "3") +;; (test-numeric-syntax "#o7" 7 "7") +;; (test-numeric-syntax "#xa" 10 "10") +;; (test-numeric-syntax "#xA" 10 "10") +;; (test-numeric-syntax "#xf" 15 "15") +;; (test-numeric-syntax "#x-10" -16 "-16") +;; (test-numeric-syntax "#d-10" -10 "-10") +;; (test-numeric-syntax "#o-10" -8 "-8") +;; (test-numeric-syntax "#b-10" -2 "-2") +;; ;; Combination of prefixes +;; (test-numeric-syntax "#e#x10" 16 "16") +;; (test-numeric-syntax "#i#x10" 16.0 "16.0" "16.") +;; ;; (Attempted) decimal notation with base prefixes +;; (test-numeric-syntax "#d1." 1.0 "1.0" "1.") +;; (test-numeric-syntax "#d.1" 0.1 "0.1" ".1" "100.0e-3") +;; (test-numeric-syntax "#x1e2" 482 "482") +;; (test-numeric-syntax "#d1e2" 100.0 "100.0" "100.") +;; ;; Fractions with prefixes +;; (test-numeric-syntax "#x10/2" 8 "8") +;; (test-numeric-syntax "#x11/2" (/ 17 2) "17/2") +;; (test-numeric-syntax "#d11/2" (/ 11 2) "11/2") +;; (test-numeric-syntax "#o11/2" (/ 9 2) "9/2") +;; (test-numeric-syntax "#b11/10" (/ 3 2) "3/2") +;; ;; Complex numbers with prefixes +;; ;;(test-numeric-syntax "#x10+11i" (make-rectangular 16 17) "16+17i") +;; (test-numeric-syntax "#d1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i") +;; (test-numeric-syntax "#d10+11i" (make-rectangular 10 11) "10+11i") +;; ;;(test-numeric-syntax "#o10+11i" (make-rectangular 8 9) "8+9i") +;; ;;(test-numeric-syntax "#b10+11i" (make-rectangular 2 3) "2+3i") +;; ;;(test-numeric-syntax "#e1.0+1.0i" (make-rectangular 1 1) "1+1i" "1+i") +;; ;;(test-numeric-syntax "#i1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i") + +(test-end) + +(test-end) + +(test-begin "6.14 System interface") + +;; 6.14 System interface + +;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH")) + +(test #t (string? (get-environment-variable "PATH"))) + +;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables)) + +(let ((env (get-environment-variables))) + (define (env-pair? x) + (and (pair? x) (string? (car x)) (string? (cdr x)))) + (define (all? pred ls) + (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls))))) + (test #t (list? env)) + (test #t (all? env-pair? env))) + +(test #t (list? (command-line))) + +(test #t (real? (current-second))) +(test #t (inexact? (current-second))) +(test #t (exact? (current-jiffy))) +(test #t (exact? (jiffies-per-second))) + +(test #t (list? (features))) +(test #t (and (memq 'r7rs (features)) #t)) + +(test #t (file-exists? ".")) +(test #f (file-exists? " no such file ")) + +;; (test #t (file-error? +;; (guard (exn (else exn)) +;; (delete-file " no such file ")))) + +(test-end) + +(test-end) diff --git a/tools/main.c b/tools/main.c index 2d3a8cfd..5e43f2b7 100644 --- a/tools/main.c +++ b/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");