diff --git a/.gitignore b/.gitignore index 6b185c72..d13a2485 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,6 @@ build/* -src/lex.yy.c -src/lex.yy.h src/load_piclib.c +src/init_contrib.c .dir-locals.el GPATH GRTAGS diff --git a/.travis.yml b/.travis.yml index fc6103f9..61058537 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,4 +7,4 @@ before_script: script: - perl --version - cmake .. && make test - - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test + - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test > /dev/null diff --git a/CMakeLists.txt b/CMakeLists.txt index 12347110..b2929567 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -40,16 +40,13 @@ include(tools/CMakeLists.txt) add_custom_target(run bin/picrin DEPENDS repl) # $ make test -add_custom_target(test DEPENDS no-act test-r7rs) - -# $ make no-act -add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl) +add_custom_target(test DEPENDS test-r7rs) # $ make test-r7rs add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl) # $ make tak -add_custom_target(tak bin/picrin etc/tak.scm DEPENDS repl) +add_custom_target(tak bin/picrin ${PROJECT_SOURCE_DIR}/etc/tak.scm DEPENDS repl) # $ make lines add_custom_target(lines find . -name "*.[chyl]" | xargs wc -l WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}) 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 59% rename from contrib/regexp/CMakeLists.txt rename to contrib/10.regexp/CMakeLists.txt index 0e28d430..6ab06aaa 100644 --- a/contrib/regexp/CMakeLists.txt +++ b/contrib/10.regexp/CMakeLists.txt @@ -5,9 +5,9 @@ if (REGEX_FOUND) add_definitions(${REGEX_DEFINITIONS}) include_directories(${REGEX_INCLUDE_DIR}) - file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/regexp/src/*.c) + file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.regexp/src/*.c) - list(APPEND PICRIN_CONTRIB_INITS "void pic_init_regexp(pic_state *)\; pic_init_regexp(pic)\;") + list(APPEND PICRIN_CONTRIB_INITS regexp) list(APPEND PICRIN_CONTRIB_LIBRARIES ${REGEX_LIBRARIES}) list(APPEND PICRIN_CONTRIB_SOURCES ${PICRIN_REGEX_SOURCES}) endif() 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..11050d90 100644 --- a/contrib/CMakeLists.txt +++ b/contrib/CMakeLists.txt @@ -1,6 +1,5 @@ file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt) +list(SORT CONTRIBS) foreach(contrib ${CONTRIBS}) include(${contrib}) endforeach() - -add_definitions("-DPIC_CONTRIB_INITS=${PICRIN_CONTRIB_INITS}") 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/lang.rst b/docs/lang.rst index fe0e60f7..3c3f463b 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,12 +58,12 @@ section status comments 5.3.1 Top level definitions yes 5.3.2 Internal definitions yes TODO: interreferential definitions 5.3.3 Multiple-value definitions yes -5.4 Syntax definitions yes TODO: internal macro definition is not supported. +5.4 Syntax definitions yes 5.5 Recored-type definitions yes 5.6.1 Library Syntax incomplete In picrin, libraries can be reopend and can be nested. 5.6.2 Library example N/A 5.7 The REPL yes -6.1 Equivalence predicates yes TODO: equal? must terminate if circular structure is given +6.1 Equivalence predicates yes 6.2.1 Numerical types yes picrin has only two types of internal representation of numbers: fixnum and double float. It still comforms the R7RS spec. 6.2.2 Exactness yes 6.2.3 Implementation restrictions yes diff --git a/docs/libs.rst b/docs/libs.rst index 9d71963f..b87d7980 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,21 @@ Utility functions and syntaces for macro definition. - define-macro - gensym -- macroexpand expr +- macroexpand +- macroexpand-1 Old-fashioned macro. -- make-syntactic-closure - identifier? - identifier=? +- make-syntactic-closure +- close-syntax +- capture-syntactic-environment + +- sc-macro-transformer +- rsc-macro-transformer + Syntactic closures. - er-macro-transformer @@ -79,6 +98,115 @@ Delimited control operators. - **(reset h)** - **(shift k)** +(picrin control list) +--------------------- + +Monadic list operators. + +The triple of for/in/yield enables you to write a list operation in a very easy and simple code. One of the best examples is list composition:: + + (for (let ((a (in '(1 2 3))) + (b (in '(2 3 4)))) + (yield (+ a b)))) + + ;=> (5 6 7 6 7 8 7 8 9) + +All monadic operations are done in *for* macro. In this example, *in* operators choose an element from the given lists, a and b are bound here, then *yielding* the sum of them. Because a and b are values moving around in the list elements, the expression (+ a b) can become every possible result. *yield* operator is a operator that gathers the possibilities into a list, so *for* macro returns a list of 3 * 3 results in total. Since expression inside *for* macro is a normal expression, you can write everything that you can write elsewhere. The code below has perfectly the same effect to above one:: + + (for (yield (+ (in '(1 2 3)) + (in '(4 5 6))))) + +The second best exmaple is filtering. In the next case, we show that you can do something depending on the condition of chosen elements:: + + (for (let ((x (in (iota 10)))) + (if (even? x) + (yield x) + (null)))) + + ;=> (0 2 4 6 8) + +This expression is equivalent to ``(filter even? (iota 10))`` but it is more procedual and non-magical. + +- **(for expr)** + + [Macro] Executes expr in a list monad context. + +- **(in list)** + + Choose a value from list. *in* function must only appear in *for* macro. The delimited continuation from the position of *in* function to the outside *for* macro is executed for each element in list. If list contains no values, that is ``(in '())``, the continuation is discarded. + +- **(yield value)** + + Yields value from the monad context. The result of *for* will be a list of yielded values. + +- **(null . value)** + + Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class. + + +(picrin array) +-------------- + +Resizable random-access list. + +Technically, picrin's array is implemented as a ring-buffer, effective double-ended queue data structure (deque) that can operate pushing and poping from both of front and back in constant time. In addition to the deque interface, array provides standard sequence interface similar to functions specified by R7RS. + +- **(make-array [capacity])** + + Returns a newly allocated array object. If capacity is given, internal data chunk of the array object will be initialized by capacity size. + +- **(array . objs)** + + Returns an array initialized with objs. + +- **(array? . obj)** + + Returns #t if obj is an array. + +- **(array-length ary)** + + Returns the length of ary. + +- **(array-ref ary i)** + + Like ``list-ref``, return the object pointed by the index i. + +- **(array-set! ary i obj)** + + Like ``list-set!``, substitutes the object pointed by the index i with given obj. + +- **(array-push! ary obj)** + + Adds obj to the end of ary. + +- **(array-pop! ary)** + + Removes the last element of ary, and returns it. + +- **(array-unshift! ary obj)** + + Adds obj to the front of ary. + +- **(array-shift! ary)** + + Removes the first element of ary, and returns it. + +- **(array-map proc ary)** + + Performs mapping operation on ary. + +- **(array-for-each proc ary)** + + Performs mapping operation on ary, but discards the result. + +- **(array->list ary)** + + Converts ary into list. + +- **(list->array list)** + + Converts list into array. + (picrin dictionary) ------------------- @@ -87,9 +215,9 @@ Symbol to Object table. Internally it is implemented on hash-table. Note that dictionary is not a weak map; if you are going to make a highly memory-consuming program with dictionaries, you should know that dictionaries keep their bound objects and never let them free until you explicitly deletes bindings. -- **(dictionary)** +- **(dictionary . plist)** - Returns a newly allocated empty dictionary. In the future, it is planned to extend this function to take optional arguments for initial key/values. + Returns a newly allocated empty dictionary. The dictionary is initialized with the content of plist. - **(dictionary? obj)** @@ -111,6 +239,31 @@ Note that dictionary is not a weak map; if you are going to make a highly memory Returns the number of registered elements in dict. +- **(dicitonary-map proc dict)** + + Perform mapping action onto dictionary object. ``proc`` is called by a sequence ``(proc key val)``. + +- **(dictionary-for-each proc dict)** + + Similar to ``dictionary-map``, but discards the result. + +- **(dictionary->plist dict)** +- **(plist->dictionary plist)** +- **(dictionary->alist dict)** +- **(alist->dictionary alist)** + + Conversion between dictionary and alist/plist. + + +(picrin pretty-print) +--------------------- + +Pretty-printer. + +- **(pretty-print obj)** + + Prints obj with human-readable indention to current-output-port. + (picrin user) ------------- diff --git a/etc/mkinit.pl b/etc/mkinit.pl new file mode 100755 index 00000000..d559db27 --- /dev/null +++ b/etc/mkinit.pl @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use strict; + +print <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/picrin/macro.scm b/piclib/picrin/macro.scm new file mode 100644 index 00000000..2f9fe7e0 --- /dev/null +++ b/piclib/picrin/macro.scm @@ -0,0 +1,148 @@ +;;; Hygienic Macros + +(define-library (picrin macro) + (import (scheme base) + (picrin dictionary)) + + ;; assumes no derived expressions are provided yet + + (define (list->vector list) + (define vector (make-vector (length list))) + (define (go list i) + (if (null? list) + vector + (begin + (vector-set! vector i (car list)) + (go (cdr list) (+ i 1))))) + (go list 0)) + + (define (vector->list vector) + (define (go i) + (if (= i (vector-length vector)) + '() + (cons (vector-ref vector i) + (go (+ i 1))))) + (go 0)) + + (define (walk proc expr) + "walk on symbols" + (if (null? expr) + '() + (if (pair? expr) + (cons (walk proc (car expr)) + (walk proc (cdr expr))) + (if (vector? expr) + (list->vector (walk proc (vector->list expr))) + (if (symbol? expr) + (proc expr) + expr))))) + + (define (memoize f) + "memoize on a symbol" + (define cache (make-dictionary)) + (lambda (sym) + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define val (f sym)) + (dictionary-set! cache sym val) + val)))) + + (define (make-syntactic-closure env free form) + + (define resolve + (memoize + (lambda (sym) + (make-identifier sym env)))) + + (walk + (lambda (sym) + (if (memq sym free) + sym + (resolve sym))) + form)) + + (define (close-syntax form env) + (make-syntactic-closure env '() form)) + + (define-syntax capture-syntactic-environment + (lambda (form use-env mac-env) + (list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))) + + (define (sc-macro-transformer f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env)))) + + (define (rsc-macro-transformer f) + (lambda (expr use-env mac-env) + (make-syntactic-closure use-env '() (f expr mac-env)))) + + (define (er-macro-transformer f) + (lambda (expr use-env mac-env) + + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) + + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? use-env x use-env y)))) + + (f expr rename compare))) + + (define (ir-macro-transformer f) + (lambda (expr use-env mac-env) + + (define icache* (make-dictionary)) + + (define inject + (memoize + (lambda (sym) + (define id (make-identifier sym use-env)) + (dictionary-set! icache* id sym) + id))) + + (define rename + (memoize + (lambda (sym) + (make-identifier sym mac-env)))) + + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? mac-env x mac-env y)))) + + (walk (lambda (sym) + (if (dictionary-has? icache* sym) + (dictionary-ref icache* sym) + (rename sym))) + (f (walk inject expr) inject compare)))) + + (define-syntax define-macro + (er-macro-transformer + (lambda (expr r c) + (define formal (car (cdr expr))) + (define body (cdr (cdr expr))) + (if (symbol? formal) + (list (r 'define-syntax) formal + (list (r 'lambda) (list (r 'form) '_ '_) + (list (r 'apply) (car body) (list (r 'cdr) (r 'form))))) + (list (r 'define-macro) (car formal) + (cons (r 'lambda) + (cons (cdr formal) + body))))))) + + (export make-syntactic-closure + close-syntax + capture-syntactic-environment + sc-macro-transformer + rsc-macro-transformer + er-macro-transformer + ir-macro-transformer + define-macro)) diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm new file mode 100644 index 00000000..f786ba58 --- /dev/null +++ b/piclib/picrin/test.scm @@ -0,0 +1,103 @@ +(define-library (picrin test) + (import (scheme base) + (scheme write) + (scheme read) + (scheme process-context)) + (define test-counter 0) + (define counter 0) + (define failure-counter 0) + + (define fails '()) + + (define (print-statistics) + (newline) + (display "Test Result: ") + (write (- counter failure-counter)) + (display " / ") + (write counter) + (display " (") + (write (* (/ (- counter failure-counter) counter) 100)) + (display "%)") + (display " [PASS/TOTAL]") + (display "") + (newline) + (for-each + (lambda (fail) + (display fail)) + fails)) + + (define (test-begin . o) + (set! test-counter (+ test-counter 1))) + + (define (test-end . o) + (set! test-counter (- test-counter 1)) + (if (= test-counter 0) + (print-statistics))) + + (define-syntax test + (syntax-rules () + ((test expected expr) + (let ((res expr)) + (display "case ") + (write counter) + (cond + ((equal? res expected) + (display " PASS: ") + (write 'expr) + (display " equals ") + (write expected) + (display "") + (newline) + ) + ((not (equal? res expected)) + (set! failure-counter (+ failure-counter 1)) + (let ((out (open-output-string))) + (display " FAIL: " out) + (write 'expr out) + (newline out) + (display " expected " out) + (write expected out) + (display " but got " out) + (write res out) + (display "" out) + (newline out) + (let ((str (get-output-string out))) + (set! fails (cons str fails)) + (display str))))) + (set! counter (+ counter 1)))))) + + (define-syntax test-values + (syntax-rules () + ((_ expect expr) + (test-values #f expect expr)) + ((_ name expect expr) + (test name (call-with-values (lambda () expect) (lambda results results)) + (call-with-values (lambda () expr) (lambda results results)))))) + + + (define (test-failure-count) + (length fails)) + + (define (test-exit) + (exit (zero? (test-failure-count)))) + + (define-syntax test-syntax-error + (syntax-rules () + ((_) (syntax-error "invalid use of test-syntax-error")))) + + (define-syntax test-numeric-syntax + (syntax-rules () + ((test-numeric-syntax str expect strs ...) + (let* ((z (read (open-input-string str))) + (out (open-output-string)) + (z-str (begin (write z out) (get-output-string out)))) + (test expect (values z)) + (test #t (and (member z-str '(str strs ...)) #t)))))) + + ;; (define (test-read-error str) + ;; (test-assert + ;; (guard (exn (else #t)) + ;; (read (open-input-string str)) + ;; #f))) + (export test test-begin test-end test-values test-exit test-syntax-error test-numeric-syntax) + ) diff --git a/piclib/built-in.scm b/piclib/prelude.scm similarity index 75% rename from piclib/built-in.scm rename to piclib/prelude.scm index 64e2ee10..7049c2f0 100644 --- a/piclib/built-in.scm +++ b/piclib/prelude.scm @@ -1,68 +1,35 @@ -;;; Appendix A. Standard Libraries CxR -(define-library (scheme cxr) - (import (scheme base)) - - (define (caaar p) (car (caar p))) - (define (caadr p) (car (cadr p))) - (define (cadar p) (car (cdar p))) - (define (caddr p) (car (cddr p))) - (define (cdaar p) (cdr (caar p))) - (define (cdadr p) (cdr (cadr p))) - (define (cddar p) (cdr (cdar p))) - (define (cdddr p) (cdr (cddr p))) - (define (caaaar p) (caar (caar p))) - (define (caaadr p) (caar (cadr p))) - (define (caadar p) (caar (cdar p))) - (define (caaddr p) (caar (cddr p))) - (define (cadaar p) (cadr (caar p))) - (define (cadadr p) (cadr (cadr p))) - (define (caddar p) (cadr (cdar p))) - (define (cadddr p) (cadr (cddr p))) - (define (cdaaar p) (cdar (caar p))) - (define (cdaadr p) (cdar (cadr p))) - (define (cdadar p) (cdar (cdar p))) - (define (cdaddr p) (cdar (cddr p))) - (define (cddaar p) (cddr (caar p))) - (define (cddadr p) (cddr (cadr p))) - (define (cdddar p) (cddr (cdar p))) - (define (cddddr p) (cddr (cddr p))) - - (export caaar caadr cadar caddr - cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr - cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr - cddaar cddadr cdddar cddddr)) - -;;; hygienic macros -(define-library (picrin macro) - (import (scheme base)) - - (define (sc-macro-transformer f) - (lambda (expr use-env mac-env) - (make-syntactic-closure mac-env '() (f expr use-env)))) - - (define (rsc-macro-transformer f) - (lambda (expr use-env mac-env) - (make-syntactic-closure use-env '() (f expr mac-env)))) - - (export sc-macro-transformer - rsc-macro-transformer)) - ;;; core syntaces (define-library (picrin core-syntax) (import (scheme base) - (scheme cxr) (picrin macro)) + (define-syntax syntax-error + (er-macro-transformer + (lambda (expr rename compare) + (apply error (cdr expr))))) + + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax else) + (define-auxiliary-syntax =>) + (define-auxiliary-syntax _) + (define-auxiliary-syntax ...) + (define-auxiliary-syntax unquote) + (define-auxiliary-syntax unquote-splicing) + (define-syntax let (er-macro-transformer (lambda (expr r compare) (if (symbol? (cadr expr)) (begin - (define name (cadr expr)) - (define bindings (caddr expr)) - (define body (cdddr expr)) + (define name (car (cdr expr))) + (define bindings (car (cdr (cdr expr)))) + (define body (cdr (cdr (cdr expr)))) (list (r 'let) '() (list (r 'define) name (cons (r 'lambda) (cons (map car bindings) body))) @@ -79,23 +46,20 @@ (let ((clauses (cdr expr))) (if (null? clauses) #f - (if (compare (r 'else) (caar clauses)) - (cons (r 'begin) (cdar clauses)) - (if (if (>= (length (car clauses)) 2) - (compare (r '=>) (cadar clauses)) - #f) - (list (r 'let) (list (list 'x (caar clauses))) - (list (r 'if) 'x - (list (caddar clauses) 'x) - (cons (r 'cond) (cdr clauses)))) - (list (r 'if) (caar clauses) - (cons (r 'begin) (cdar clauses)) - (cons (r 'cond) (cdr clauses)))))))))) - - (define (single? list) - (if (pair? list) - (null? (cdr list)) - #f)) + (begin + (define clause (car clauses)) + (if (compare (r 'else) (car clause)) + (cons (r 'begin) (cdr clause)) + (if (if (>= (length clause) 2) + (compare (r '=>) (list-ref clause 1)) + #f) + (list (r 'let) (list (list (r 'x) (car clause))) + (list (r 'if) (r 'x) + (list (list-ref clause 2) (r 'x)) + (cons (r 'cond) (cdr clauses)))) + (list (r 'if) (car clause) + (cons (r 'begin) (cdr clause)) + (cons (r 'cond) (cdr clauses))))))))))) (define-syntax and (er-macro-transformer @@ -104,7 +68,7 @@ (cond ((null? exprs) #t) - ((single? exprs) + ((= (length exprs) 1) (car exprs)) (else (list (r 'let) (list (list (r 'it) (car exprs))) @@ -119,7 +83,7 @@ (cond ((null? exprs) #t) - ((single? exprs) + ((= (length exprs) 1) (car exprs)) (else (list (r 'let) (list (list (r 'it) (car exprs))) @@ -127,30 +91,47 @@ (r 'it) (cons (r 'or) (cdr exprs)))))))))) - (define (quasiquote? form compare?) - (and (pair? form) (compare? (car form) 'quasiquote))) + (define (list->vector list) + (let ((vector (make-vector (length list)))) + (let loop ((list list) (i 0)) + (if (null? list) + vector + (begin + (vector-set! vector i (car list)) + (loop (cdr list) (+ i 1))))))) - (define (unquote? form compare?) - (and (pair? form) (compare? (car form) 'unquote))) - - (define (unquote-splicing? form compare?) - (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing))) + (define (vector->list vector) + (let ((length (vector-length vector))) + (let loop ((list '()) (i 0)) + (if (= i length) + (reverse list) + (loop (cons (vector-ref vector i) list) (+ i 1)))))) (define-syntax quasiquote (ir-macro-transformer (lambda (form inject compare) + (define (quasiquote? form) + (and (pair? form) (compare (car form) 'quasiquote))) + + (define (unquote? form) + (and (pair? form) (compare (car form) 'unquote))) + + (define (unquote-splicing? form) + (and (pair? form) (pair? (car form)) + (compare (car (car form)) 'unquote-splicing))) + (define (qq depth expr) (cond ;; unquote - ((unquote? expr compare) + ((unquote? expr) (if (= depth 1) (car (cdr expr)) (list 'list (list 'quote (inject 'unquote)) (qq (- depth 1) (car (cdr expr)))))) ;; unquote-splicing - ((unquote-splicing? expr compare) + ((unquote-splicing? expr) (if (= depth 1) (list 'append (car (cdr (car expr))) @@ -161,7 +142,7 @@ (qq (- depth 1) (car (cdr (car expr))))) (qq depth (cdr expr))))) ;; quasiquote - ((quasiquote? expr compare) + ((quasiquote? expr) (list 'list (list 'quote (inject 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) @@ -170,6 +151,9 @@ (list 'cons (qq depth (car expr)) (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list 'list->vector (qq depth (vector->list expr)))) ;; simple datum (else (list 'quote expr)))) @@ -221,9 +205,9 @@ (define-syntax do (er-macro-transformer (lambda (form r compare) - (let ((bindings (cadr form)) - (finish (caddr form)) - (body (cdddr form))) + (let ((bindings (car (cdr form))) + (finish (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) `(,(r 'let) ,(r 'loop) ,(map (lambda (x) (list (car x) (cadr x))) bindings) @@ -263,50 +247,57 @@ ,(let loop ((clauses clauses)) (if (null? clauses) #f - `(,(r 'if) ,(if (compare (r 'else) (caar clauses)) - '#t - `(,(r 'or) - ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) - (caar clauses)))) - ,(if (compare (r '=>) (cadar clauses)) - `(,(caddar clauses) ,(r 'key)) - `(,(r 'begin) ,@(cdar clauses))) - ,(loop (cdr clauses)))))))))) + (begin + (define clause (car clauses)) + `(,(r 'if) ,(if (compare (r 'else) (car clause)) + '#t + `(,(r 'or) + ,@(map (lambda (x) + `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) + (car clause)))) + ,(if (compare (r '=>) (list-ref clause 1)) + `(,(list-ref clause 2) ,(r 'key)) + `(,(r 'begin) ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) - (define-syntax syntax-error + (define-syntax letrec-syntax (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) - (define-syntax define-auxiliary-syntax + (define-syntax let-syntax (er-macro-transformer - (lambda (expr r c) - `(,(r 'define-syntax) ,(cadr expr) - (,(r 'sc-macro-transformer) - (,(r 'lambda) (expr env) - (,(r 'error) "invalid use of auxiliary syntax"))))))) - - (define-auxiliary-syntax else) - (define-auxiliary-syntax =>) - (define-auxiliary-syntax _) - (define-auxiliary-syntax ...) - (define-auxiliary-syntax unquote) - (define-auxiliary-syntax unquote-splicing) + (lambda (form r c) + `(,(r 'letrec-syntax) ,@(cdr form))))) (export let let* letrec letrec* quasiquote unquote unquote-splicing and or cond case else => do when unless + let-syntax letrec-syntax _ ... syntax-error)) +(import (picrin core-syntax)) + +(export let let* letrec letrec* + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + let-syntax letrec-syntax + _ ... syntax-error) ;;; multiple value -(define-library (picrin multiple-value) +(define-library (picrin values) (import (scheme base) - (scheme cxr) - (picrin macro) - (picrin core-syntax)) + (picrin macro)) (define-syntax let*-values (er-macro-transformer @@ -324,24 +315,56 @@ (lambda (form r c) `(,(r 'let*-values) ,@(cdr form))))) + (define (vector-map proc vect) + (do ((i 0 (+ i 1)) + (u (make-vector (vector-length vect)))) + ((= i (vector-length vect)) + u) + (vector-set! u i (proc (vector-ref vect i))))) + + (define (walk proc expr) + (cond + ((null? expr) + '()) + ((pair? expr) + (cons (proc (car expr)) + (walk proc (cdr expr)))) + ((vector? expr) + (vector-map proc expr)) + (else + (proc expr)))) + + (define (flatten expr) + (let ((list '())) + (walk + (lambda (x) + (set! list (cons x list))) + expr) + (reverse list))) + + (define uniq + (let ((counter 0)) + (lambda (x) + (let ((sym (string->symbol (string-append "var$" (number->string counter))))) + (set! counter (+ counter 1)) + sym)))) + (define-syntax define-values - (er-macro-transformer - (lambda (form r c) - (let ((formals (cadr form))) - `(,(r 'begin) - ,@(do ((vars formals (cdr vars)) - (defs '())) - ((null? vars) - defs) - (set! defs (cons `(,(r 'define) ,(car vars) #f) defs))) - (,(r 'call-with-values) - (,(r 'lambda) () ,@(cddr form)) - (,(r 'lambda) (,@(map r formals)) - ,@(do ((vars formals (cdr vars)) - (assn '())) - ((null? vars) - assn) - (set! assn (cons `(,(r 'set!) ,(car vars) ,(r (car vars))) assn)))))))))) + (ir-macro-transformer + (lambda (form inject compare) + (let* ((formal (cadr form)) + (formal* (walk uniq formal)) + (exprs (cddr form))) + `(begin + ,@(map + (lambda (var) `(define ,var #f)) + (flatten formal)) + (call-with-values (lambda () ,@exprs) + (lambda ,formal* + ,@(map + (lambda (var val) `(set! ,var ,val)) + (flatten formal) + (flatten formal*))))))))) (export let-values let*-values @@ -350,42 +373,75 @@ ;;; parameter (define-library (picrin parameter) (import (scheme base) - (scheme cxr) (picrin macro) - (picrin core-syntax)) + (picrin var) + (picrin attribute) + (picrin dictionary)) - ;; reopen (pircin parameter) - ;; see src/var.c + (define (single? x) + (and (list? x) (= (length x) 1))) + + (define (double? x) + (and (list? x) (= (length x) 2))) + + (define (%make-parameter init conv) + (let ((var (make-var (conv init)))) + (define (parameter . args) + (cond + ((null? args) + (var-ref var)) + ((single? args) + (var-set! var (conv (car args)))) + ((double? args) + (var-set! var ((cadr args) (car args)))) + (else + (error "invalid arguments for parameter")))) + + (dictionary-set! (attribute parameter) '@@var var) + + parameter)) + + (define (make-parameter init . conv) + (let ((conv + (if (null? conv) + (lambda (x) x) + (car conv)))) + (%make-parameter init conv))) + + (define-syntax with + (ir-macro-transformer + (lambda (form inject compare) + (let ((before (car (cdr form))) + (after (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + `(begin + (,before) + (let ((result (begin ,@body))) + (,after) + result)))))) + + (define (var-of parameter) + (dictionary-ref (attribute parameter) '@@var)) (define-syntax parameterize - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (let ((vars (map car bindings)) - (gensym (lambda (var) - (string->symbol - (string-append - "parameterize-" - (symbol->string var)))))) - `(,(r 'let) (,@(map (lambda (var) - `(,(r (gensym var)) (,var))) - vars)) - ,@bindings - (,(r 'let) ((,(r 'result) (begin ,@body))) - ,@(map (lambda (var) - `(,(r 'parameter-set!) ,var ,(r (gensym var)))) - vars) - ,(r 'result)))))))) + (ir-macro-transformer + (lambda (form inject compare) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + (let ((vars (map car formal)) + (vals (map cadr formal))) + `(with + (lambda () ,@(map (lambda (var val) `(var-push! (var-of ,var) ,val)) vars vals)) + (lambda () ,@(map (lambda (var) `(var-pop! (var-of ,var))) vars)) + ,@body)))))) - (export parameterize)) + (export make-parameter + parameterize)) ;;; Record Type (define-library (picrin record) (import (scheme base) - (scheme cxr) - (picrin macro) - (picrin core-syntax)) + (picrin macro)) (define record-marker (list 'record-marker)) @@ -490,9 +546,9 @@ (define-syntax define-record-field (ir-macro-transformer (lambda (form inject compare?) - (let ((type (cadr form)) - (field-tag (caddr form)) - (acc-mod (cdddr form))) + (let ((type (car (cdr form))) + (field-tag (car (cdr (cdr form)))) + (acc-mod (cdr (cdr (cdr form))))) (if (= 1 (length acc-mod)) `(define ,(car acc-mod) (record-accessor ,type ',field-tag)) @@ -506,9 +562,9 @@ (ir-macro-transformer (lambda (form inject compare?) (let ((type (cadr form)) - (constructor (caddr form)) - (predicate (cadddr form)) - (field-tag (cddddr form))) + (constructor (car (cdr (cdr form)))) + (predicate (car (cdr (cdr (cdr form))))) + (field-tag (cdr (cdr (cdr (cdr form)))))) `(begin (define ,type (make-record-type ',type ',(cdr constructor))) @@ -521,21 +577,13 @@ `(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x))) field-tag)))))) - (export define-record-type vector?)) + (export define-record-type)) (import (picrin macro) - (picrin core-syntax) - (picrin multiple-value) + (picrin values) (picrin parameter) (picrin record)) -(export let let* letrec letrec* - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - _ ... syntax-error) - (export let-values let*-values define-values) @@ -543,8 +591,7 @@ (export make-parameter parameterize) -(export vector? ; override definition - define-record-type) +(export define-record-type) (define (every pred list) (if (null? list) @@ -588,34 +635,6 @@ ;;; 6.4 Pairs and lists -(define (memq obj list) - (if (null? list) - #f - (if (eq? obj (car list)) - list - (memq obj (cdr list))))) - -(define (memv obj list) - (if (null? list) - #f - (if (eqv? obj (car list)) - list - (memq obj (cdr list))))) - -(define (assq obj list) - (if (null? list) - #f - (if (eq? obj (caar list)) - (car list) - (assq obj (cdr list))))) - -(define (assv obj list) - (if (null? list) - #f - (if (eqv? obj (caar list)) - (car list) - (assq obj (cdr list))))) - (define (member obj list . opts) (let ((compare (if (null? opts) equal? (car opts)))) (if (null? list) @@ -632,8 +651,7 @@ (car list) (assoc obj (cdr list) compare))))) -(export memq memv member - assq assv assoc) +(export member assoc) ;;; 6.5. Symbols @@ -719,14 +737,20 @@ (apply vector list)) (define (vector-copy! to at from . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (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 +802,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 +910,16 @@ ;;; 6.13. Input and output +(import (picrin port)) + +(define current-input-port (make-parameter standard-input-port)) +(define current-output-port (make-parameter standard-output-port)) +(define current-error-port (make-parameter standard-error-port)) + +(export current-input-port + current-output-port + current-error-port) + (define (call-with-port port proc) (dynamic-wind (lambda () #f) @@ -888,53 +928,32 @@ (export call-with-port) -;;; Appendix A. Standard Libraries Lazy -(define-library (scheme lazy) - (import (scheme base) - (picrin macro)) +;;; include syntax - (define-record-type promise - (make-promise% done obj) - promise? - (done promise-done? promise-done!) - (obj promise-value promise-value!)) +(import (scheme read) + (scheme file)) - (define-syntax delay-force - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(make-promise% #f (lambda () ,expr)))))) +(define (read-many filename) + (call-with-port (open-input-file filename) + (lambda (port) + (let loop ((expr (read port)) (exprs '())) + (if (eof-object? expr) + (reverse exprs) + (loop (read port) (cons expr exprs))))))) - (define-syntax delay - (ir-macro-transformer - (lambda (form rename compare?) - (let ((expr (cadr form))) - `(delay-force (make-promise% #t ,expr)))))) +(define-syntax include + (er-macro-transformer + (lambda (form rename compare) + (let ((filenames (cdr form))) + (let ((exprs (apply append (map read-many filenames)))) + `(,(rename 'begin) ,@exprs)))))) - (define (promise-update! new old) - (promise-done! old (promise-done? new)) - (promise-value! old (promise-value new))) - - (define (force promise) - (if (promise-done? promise) - (promise-value promise) - (let ((promise* ((promise-value promise)))) - (unless (promise-done? promise) - (promise-update! promise* promise)) - (force promise)))) - - (define (make-promise obj) - (if (promise? obj) - obj - (make-promise% #f obj))) - - (export delay-force delay force make-promise promise?)) +(export include) ;;; syntax-rules (define-library (picrin syntax-rules) (import (scheme base) - (scheme cxr) - (picrin macro)) + (picrin macro)) ;;; utility functions (define (reverse* l) @@ -1063,7 +1082,7 @@ (let-values (((match1 vars1) (compile-match-base (car pattern)))) (loop (cdr pattern) (cons `(,_if (,_pair? ,accessor) - (,_let ((expr (,_car,accessor))) + (,_let ((expr (,_car ,accessor))) ,match1) (exit #f)) matches) @@ -1125,7 +1144,7 @@ (define (compile-expand ellipsis reserved template) (letrec ((compile-expand-base (lambda (template ellipsis-valid) - (cond ((member template reserved compare) + (cond ((member template reserved eq?) (values (var->sym template) (list template))) ((symbol? template) (values `(rename ',template) '())) @@ -1207,9 +1226,9 @@ ((compare (car clauses) 'mismatch) `(,_syntax-error "invalid rule")) (else - (let ((vars (car (car clauses))) - (match (cadr (car clauses))) - (expand (caddr (car clauses)))) + (let ((vars (list-ref (car clauses) 0)) + (match (list-ref (car clauses) 1)) + (expand (list-ref (car clauses) 2))) `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) (,_let ((result (,_call/cc (,_lambda (exit) ,match)))) (,_if result @@ -1240,9 +1259,9 @@ (let ((form (normalize-form form))) (if form - (let ((ellipsis (cadr form)) - (literals (caddr form)) - (rules (cdddr form))) + (let ((ellipsis (list-ref form 1)) + (literals (list-ref form 2)) + (rules (list-tail form 3))) (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) rules))) `(,_er-macro-transformer @@ -1255,3 +1274,4 @@ (import (picrin syntax-rules)) (export syntax-rules) + diff --git a/piclib/scheme/case-lambda.scm b/piclib/scheme/case-lambda.scm new file mode 100644 index 00000000..fff2b26c --- /dev/null +++ b/piclib/scheme/case-lambda.scm @@ -0,0 +1,29 @@ +(define-library (scheme case-lambda) + (import (scheme base)) + + (define-syntax case-lambda + (syntax-rules () + ((case-lambda (params body0 ...) ...) + (lambda args + (let ((len (length args))) + (letrec-syntax + ((cl (syntax-rules ::: () + ((cl) + (error "no matching clause")) + ((cl ((p :::) . body) . rest) + (if (= len (length '(p :::))) + (apply (lambda (p :::) + . body) + args) + (cl . rest))) + ((cl ((p ::: . tail) . body) + . rest) + (if (>= len (length '(p :::))) + (apply + (lambda (p ::: . tail) + . body) + args) + (cl . rest)))))) + (cl (params body0 ...) ...))))))) + + (export case-lambda)) diff --git a/piclib/scheme/cxr.scm b/piclib/scheme/cxr.scm new file mode 100644 index 00000000..e92c536f --- /dev/null +++ b/piclib/scheme/cxr.scm @@ -0,0 +1,36 @@ +;;; Appendix A. Standard Libraries CxR + +(define-library (scheme cxr) + (import (scheme base)) + + (define (caaar p) (car (caar p))) + (define (caadr p) (car (cadr p))) + (define (cadar p) (car (cdar p))) + (define (caddr p) (car (cddr p))) + (define (cdaar p) (cdr (caar p))) + (define (cdadr p) (cdr (cadr p))) + (define (cddar p) (cdr (cdar p))) + (define (cdddr p) (cdr (cddr p))) + (define (caaaar p) (caar (caar p))) + (define (caaadr p) (caar (cadr p))) + (define (caadar p) (caar (cdar p))) + (define (caaddr p) (caar (cddr p))) + (define (cadaar p) (cadr (caar p))) + (define (cadadr p) (cadr (cadr p))) + (define (caddar p) (cadr (cdar p))) + (define (cadddr p) (cadr (cddr p))) + (define (cdaaar p) (cdar (caar p))) + (define (cdaadr p) (cdar (cadr p))) + (define (cdadar p) (cdar (cdar p))) + (define (cdaddr p) (cdar (cddr p))) + (define (cddaar p) (cddr (caar p))) + (define (cddadr p) (cddr (cadr p))) + (define (cdddar p) (cddr (cdar p))) + (define (cddddr p) (cddr (cddr p))) + + (export caaar caadr cadar caddr + cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr + cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr + cddaar cddadr cdddar cddddr)) diff --git a/piclib/scheme/file.scm b/piclib/scheme/file.scm new file mode 100644 index 00000000..75c8bdd9 --- /dev/null +++ b/piclib/scheme/file.scm @@ -0,0 +1,11 @@ +(define-library (scheme file) + (import (scheme base)) + + (define (call-with-input-file filename callback) + (call-with-port (open-input-file filename) callback)) + + (define (call-with-output-file filename callback) + (call-with-port (open-output-file filename) callback)) + + (export call-with-input-file + call-with-output-file)) diff --git a/piclib/scheme/lazy.scm b/piclib/scheme/lazy.scm new file mode 100644 index 00000000..444dda40 --- /dev/null +++ b/piclib/scheme/lazy.scm @@ -0,0 +1,42 @@ +;;; Appendix A. Standard Libraries Lazy + +(define-library (scheme lazy) + (import (scheme base) + (picrin macro)) + + (define-record-type promise + (make-promise% done obj) + promise? + (done promise-done? promise-done!) + (obj promise-value promise-value!)) + + (define-syntax delay-force + (ir-macro-transformer + (lambda (form rename compare?) + (let ((expr (cadr form))) + `(make-promise% #f (lambda () ,expr)))))) + + (define-syntax delay + (ir-macro-transformer + (lambda (form rename compare?) + (let ((expr (cadr form))) + `(delay-force (make-promise% #t ,expr)))))) + + (define (promise-update! new old) + (promise-done! old (promise-done? new)) + (promise-value! old (promise-value new))) + + (define (force promise) + (if (promise-done? promise) + (promise-value promise) + (let ((promise* ((promise-value promise)))) + (unless (promise-done? promise) + (promise-update! promise* promise)) + (force promise)))) + + (define (make-promise obj) + (if (promise? obj) + obj + (make-promise% #t obj))) + + (export delay-force delay force make-promise promise?)) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 2eafdf0d..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,47 +356,47 @@ (define (pair-for-each f clist . clists) (if (null? clist) - (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))))))) + (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) (let recur ((l (apply map f clist clists))) (cond ((null? l) '()) - ((car l) (cons (car l) (recur (cdr l)))) - (else (recur (cdr 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 @@ -415,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 @@ -455,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) @@ -519,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 @@ -550,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 @@ -590,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 @@ -602,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 index a30757e6..88ebc083 100644 --- a/piclib/srfi/43.scm +++ b/piclib/srfi/43.scm @@ -50,7 +50,7 @@ ; for the symmetry, this should be rather 'vector=?' than 'vector='. (define (vector= elt=? . vects) - (letrec ((2vector= + (letrec ((vector2= (lambda (v1 v2) (let ((ln1 (vector-length v1))) (and (= ln1 (vector-length v2)) @@ -67,7 +67,7 @@ (others (cdr others))) (if (eq? vect1 vect2) (rec1 vect1 others) - (and (2vector= vect1 vect2) + (and (vector2= vect1 vect2) (rec1 vect2 others))))))))) 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 9318f442..f3e51499 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,8 +1,9 @@ +find_package(Perl REQUIRED) + # xfile set(XFILE_SOURCES extlib/xfile/xfile.c) # piclib -find_package(Perl REQUIRED) set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c) add_custom_command( OUTPUT ${PICLIB_SOURCE} @@ -11,9 +12,18 @@ add_custom_command( WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} ) +# contrib +set(CONTRIB_INIT ${PROJECT_SOURCE_DIR}/src/init_contrib.c) +add_custom_command( + OUTPUT ${CONTRIB_INIT} + COMMAND ${PERL_EXECUTABLE} etc/mkinit.pl ${PICRIN_CONTRIB_INITS} > ${CONTRIB_INIT} + DEPENDS ${PICRIN_CONTRIB_SOURCES} + WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} + ) + # build! file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c) -add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES}) +add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT}) target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES}) # install diff --git a/src/bool.c b/src/bool.c index fa56fa31..a985c625 100644 --- a/src/bool.c +++ b/src/bool.c @@ -6,27 +6,119 @@ #include "picrin.h" #include "picrin/pair.h" +#include "picrin/vector.h" +#include "picrin/blob.h" +#include "picrin/string.h" -bool -pic_equal_p(pic_state *pic, pic_value x, pic_value y) +static bool +str_equal_p(struct pic_string *str1, struct pic_string *str2) { - enum pic_tt type; + return pic_strcmp(str1, str2) == 0; +} + +static bool +blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2) +{ + size_t i; + + if (blob1->len != blob2->len) { + return false; + } + for (i = 0; i < blob1->len; ++i) { + if (blob1->data[i] != blob2->data[i]) + return false; + } + return true; +} + +static bool +internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht) +{ + pic_value local = pic_nil_value(); + size_t c; + + if (depth > 10) { + if (depth > 200) { + pic_errorf(pic, "Stack overflow in equal\n"); + } + if (pic_pair_p(x) || pic_vec_p(x)) { + if (xh_get(ht, pic_obj_ptr(x)) != NULL) { + return true; /* `x' was seen already. */ + } else { + xh_put(ht, pic_obj_ptr(x), NULL); + } + } + } + + c = 0; + + LOOP: if (pic_eqv_p(x, y)) return true; - type = pic_type(x); - if (type != pic_type(y)) + if (pic_type(x) != pic_type(y)) return false; - switch (type) { - case PIC_TT_PAIR: - return pic_equal_p(pic, pic_car(pic, x), pic_car(pic, y)) - && pic_equal_p(pic, pic_cdr(pic, x), pic_cdr(pic, y)); + + switch (pic_type(x)) { + case PIC_TT_STRING: + return str_equal_p(pic_str_ptr(x), pic_str_ptr(y)); + + case PIC_TT_BLOB: + return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y)); + + case PIC_TT_PAIR: { + if (pic_nil_p(local)) { + local = x; + } + if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) { + x = pic_cdr(pic, x); + y = pic_cdr(pic, y); + + c++; + + if (c == 2) { + c = 0; + local = pic_cdr(pic, local); + if (pic_eq_p(local, x)) { + return true; + } + } + goto LOOP; + } else { + return false; + } + } + case PIC_TT_VECTOR: { + size_t i; + struct pic_vector *u, *v; + + u = pic_vec_ptr(x); + v = pic_vec_ptr(y); + + if (u->len != v->len) { + return false; + } + for (i = 0; i < u->len; ++i) { + if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht)) + return false; + } + return true; + } default: return false; } } +bool +pic_equal_p(pic_state *pic, pic_value x, pic_value y){ + xhash ht; + + xh_init_ptr(&ht, 0); + + return internal_equal_p(pic, x, y, 0, &ht); +} + static pic_value pic_bool_eq_p(pic_state *pic) { 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 d097896f..a5c35eb8 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -51,7 +51,7 @@ static void pop_scope(analyze_state *); #define register_renamed_symbol(pic, state, slot, lib, id) do { \ pic_sym sym, gsym; \ sym = pic_intern_cstr(pic, id); \ - if (! pic_find_rename(pic, lib->senv, sym, &gsym)) { \ + if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ pic_error(pic, "internal error! native VM procedure not found"); \ } \ state->slot = gsym; \ @@ -366,7 +366,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v : pic_false_value(); /* To know what kind of local variables are defined, analyze body at first. */ - body = analyze(state, pic_cons(pic, pic_sym_value(pic->sBEGIN), body_exprs), true); + body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true); locals = pic_nil_value(); for (i = scope->locals.size; i > 0; --i) { @@ -420,14 +420,11 @@ analyze_define(analyze_state *state, pic_value obj) pic_value var, val; pic_sym sym; - if (pic_length(pic, obj) < 2) { + if (pic_length(pic, obj) != 3) { pic_error(pic, "syntax error"); } var = pic_list_ref(pic, obj, 1); - if (pic_pair_p(var)) { - var = pic_list_ref(pic, var, 0); - } if (! pic_sym_p(var)) { pic_error(pic, "syntax error"); } else { @@ -435,11 +432,13 @@ analyze_define(analyze_state *state, pic_value obj) } var = analyze_declare(state, sym); - if (pic_pair_p(pic_list_ref(pic, obj, 1))) { + if (pic_pair_p(pic_list_ref(pic, obj, 2)) + && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) + && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { pic_value formals, body_exprs; - formals = pic_list_tail(pic, pic_list_ref(pic, obj, 1), 1); - body_exprs = pic_list_tail(pic, obj, 2); + formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); + body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); val = analyze_procedure(state, pic_sym_value(sym), formals, body_exprs); } else { @@ -535,7 +534,7 @@ analyze_quote(analyze_state *state, pic_value obj) if (pic_length(pic, obj) != 2) { pic_error(pic, "syntax error"); } - return obj; + return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); } #define ARGC_ASSERT_GE(n) do { \ @@ -690,6 +689,12 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) } \ } while (0) +#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ + if (pic_length(pic, obj) != (n) + 1) { \ + goto fallback; \ + } \ + } while (0) + #define CONSTRUCT_OP1(op) \ pic_list2(pic, \ pic_symbol_value(op), \ @@ -721,22 +726,22 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) if (pic_sym_p(proc)) { pic_sym sym = pic_sym(proc); - if (sym == pic->sDEFINE) { + if (sym == pic->rDEFINE) { return analyze_define(state, obj); } - else if (sym == pic->sLAMBDA) { + else if (sym == pic->rLAMBDA) { return analyze_lambda(state, obj); } - else if (sym == pic->sIF) { + else if (sym == pic->rIF) { return analyze_if(state, obj, tailpos); } - else if (sym == pic->sBEGIN) { + else if (sym == pic->rBEGIN) { return analyze_begin(state, obj, tailpos); } - else if (sym == pic->sSETBANG) { + else if (sym == pic->rSETBANG) { return analyze_set(state, obj); } - else if (sym == pic->sQUOTE) { + else if (sym == pic->rQUOTE) { return analyze_quote(state, obj); } else if (sym == state->rCONS) { @@ -768,23 +773,23 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) return analyze_div(state, obj); } else if (sym == state->rEQ) { - ARGC_ASSERT(2); + ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sEQ); } else if (sym == state->rLT) { - ARGC_ASSERT(2); + ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLT); } else if (sym == state->rLE) { - ARGC_ASSERT(2); + ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLE); } else if (sym == state->rGT) { - ARGC_ASSERT(2); + ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGT); } else if (sym == state->rGE) { - ARGC_ASSERT(2); + ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGE); } else if (sym == state->rNOT) { @@ -798,6 +803,8 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) return analyze_call_with_values(state, obj, tailpos); } } + fallback: + return analyze_call(state, obj, tailpos); } case PIC_TT_BOOL: @@ -819,12 +826,10 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) case PIC_TT_ERROR: case PIC_TT_SENV: case PIC_TT_MACRO: - case PIC_TT_SC: case PIC_TT_LIB: case PIC_TT_VAR: case PIC_TT_IREP: case PIC_TT_DATA: - case PIC_TT_BOX: case PIC_TT_DICT: pic_errorf(pic, "invalid expression given: ~s", obj); } 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..e673f045 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,24 +460,15 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } break; } - case PIC_TT_SC: { - struct pic_sc *sc = (struct pic_sc *)obj; - gc_mark(pic, sc->expr); - gc_mark_object(pic, (struct pic_object *)sc->senv); - break; - } case PIC_TT_LIB: { struct pic_lib *lib = (struct pic_lib *)obj; gc_mark(pic, lib->name); - gc_mark_object(pic, (struct pic_object *)lib->senv); + gc_mark_object(pic, (struct pic_object *)lib->env); break; } case PIC_TT_VAR: { struct pic_var *var = (struct pic_var *)obj; - gc_mark(pic, var->value); - if (var->conv) { - gc_mark_object(pic, (struct pic_object *)var->conv); - } + gc_mark(pic, var->stack); break; } case PIC_TT_IREP: { @@ -500,11 +493,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } break; } - case PIC_TT_BOX: { - struct pic_box *box = (struct pic_box *)obj; - gc_mark(pic, box->value); - break; - } case PIC_TT_DICT: { struct pic_dict *dict = (struct pic_dict *)obj; xh_iter it; @@ -635,15 +623,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_SENV: { struct pic_senv *senv = (struct pic_senv *)obj; - xh_destroy(&senv->renames); + xh_destroy(&senv->map); break; } case PIC_TT_MACRO: { break; } - case PIC_TT_SC: { - break; - } case PIC_TT_LIB: { struct pic_lib *lib = (struct pic_lib *)obj; xh_destroy(&lib->exports); @@ -665,9 +650,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) xh_destroy(&data->storage); break; } - case PIC_TT_BOX: { - break; - } case PIC_TT_DICT: { struct pic_dict *dict = (struct pic_dict *)obj; xh_destroy(&dict->hash); diff --git a/src/init.c b/src/init.c index 5770d819..3bb10991 100644 --- a/src/init.c +++ b/src/init.c @@ -31,15 +31,10 @@ void pic_init_load(pic_state *); void pic_init_write(pic_state *); void pic_init_read(pic_state *); void pic_init_dict(pic_state *); +void pic_init_contrib(pic_state *); void pic_load_piclib(pic_state *); -void -pic_init_contrib(pic_state *pic) -{ - PIC_CONTRIB_INITS -} - #define push_sym(pic, name, list) \ pic_push(pic, pic_symbol_value(pic_intern_cstr(pic, name)), list) @@ -67,14 +62,14 @@ pic_init_core(pic_state *pic) pic_deflibrary ("(scheme base)") { /* load core syntaces */ - pic->lib->senv = pic_null_syntactic_environment(pic); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX); + pic->lib->env = pic_null_syntactic_environment(pic); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/lib.c b/src/lib.c index b12e8c9b..5ac5336a 100644 --- a/src/lib.c +++ b/src/lib.c @@ -27,7 +27,7 @@ pic_make_library(pic_state *pic, pic_value name) senv = pic_null_syntactic_environment(pic); lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); - lib->senv = senv; + lib->env = senv; lib->name = name; xh_init_int(&lib->exports, sizeof(pic_sym)); @@ -78,7 +78,7 @@ pic_import(pic_state *pic, pic_value spec) printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym))); #endif - pic_put_rename(pic, pic->lib->senv, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym)); + pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym)); } } @@ -87,7 +87,7 @@ pic_export(pic_state *pic, pic_sym sym) { pic_sym rename; - if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) { + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym)); } @@ -103,7 +103,7 @@ pic_export_as(pic_state *pic, pic_sym sym, pic_sym as) { pic_sym rename; - if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) { + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym)); } diff --git a/src/macro.c b/src/macro.c index 7783c0e4..597eb57f 100644 --- a/src/macro.c +++ b/src/macro.c @@ -9,33 +9,8 @@ #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" +#include "picrin/cont.h" pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) @@ -52,7 +27,7 @@ pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym renam { UNUSED(pic); - xh_put_int(&senv->renames, sym, &rename); + xh_put_int(&senv->map, sym, &rename); } bool @@ -62,7 +37,7 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren UNUSED(pic); - if ((e = xh_get_int(&senv->renames, sym)) == NULL) { + if ((e = xh_get_int(&senv->map, sym)) == NULL) { return false; } if (rename != NULL) { @@ -94,112 +69,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 +82,26 @@ 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; + if (! pic_interned_p(pic, sym)) { + return sym; + } + else { + return pic_gensym(pic, sym); } } +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); + static pic_value -macroexpand_deflibrary(pic_state *pic, pic_value expr) +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) { - struct pic_lib *prev = pic->lib; - pic_value v; + return pic_sym_value(make_identifier(pic, sym, senv)); +} - 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(); +static pic_value +macroexpand_quote(pic_state *pic, pic_value expr) +{ + return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -301,7 +153,124 @@ 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 = pic_senv_new(pic, senv); + + for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value v = pic_car(pic, a); + + if (! pic_sym_p(v)) { + pic_error(pic, "syntax error"); + } + pic_add_rename(pic, in, pic_sym(v)); + } + if (pic_sym_p(a)) { + pic_add_rename(pic, in, pic_sym(a)); + } + else if (! pic_nil_p(a)) { + pic_error(pic, "syntax error"); + } + + formal = macroexpand_list(pic, pic_cadr(pic, expr), in); + body = macroexpand_list(pic, pic_cddr(pic, expr), in); + + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); +} + +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) +{ + pic_sym sym; + 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)) { + 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; @@ -311,9 +280,6 @@ 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); - } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); } @@ -327,7 +293,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic pic_try { val = pic_eval(pic, val); } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); } if (! pic_proc_p(val)) { @@ -340,120 +306,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic } static pic_value -macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - pic_value var, val; - pic_sym sym, rename; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - var = pic_car(pic, pic_cdr(pic, expr)); - if (pic_pair_p(var)) { - /* FIXME: unhygienic */ - val = pic_cons(pic, pic_sym_value(pic->sLAMBDA), - pic_cons(pic, pic_cdr(pic, var), - pic_cdr(pic, pic_cdr(pic, expr)))); - var = pic_car(pic, var); - } - else { - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax_error"); - } - val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr))); - } - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } - - pic_try { - val = pic_eval(pic, val); - } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - define_macro(pic, rename, pic_proc_ptr(val), NULL); - - return pic_none_value(); -} - -static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) -{ - pic_sym sym; - pic_value formals; - - 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); - } - if (! pic_sym_p(a)) { - 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); - } - - /* 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))); - } - - 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)); -} - -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; @@ -473,7 +326,7 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_try { v = pic_apply(pic, mac->proc, args); } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); } #if DEBUG @@ -482,11 +335,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 +348,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 +359,38 @@ 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) { - return macroexpand_defmacro(pic, expr, senv); + else if (tag == pic->rLAMBDA) { + return macroexpand_lambda(pic, expr, senv); } - else if (tag == pic->sLAMBDA) { - return macroexpand_lambda(pic, expr, senv, assoc_box); + else if (tag == pic->rDEFINE) { + return macroexpand_define(pic, expr, senv); } - else if (tag == pic->sDEFINE) { - return macroexpand_define(pic, expr, senv, assoc_box); - } - else if (tag == pic->sQUOTE) { + 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 +415,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 +445,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->env); #if DEBUG puts("after expand:"); @@ -599,37 +456,110 @@ 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) +macroexpand_one(pic_state *pic, pic_value expr, struct pic_senv *senv) { - size_t argc, i; - pic_value *argv, exprs, body; - FILE *file; + struct pic_macro *mac; + pic_value v, args; - pic_get_args(pic, "*", &argc, &argv); + if (pic_sym_p(expr)) { + pic_sym sym; - /* FIXME unhygienic */ - body = pic_list1(pic, pic_sym_value(pic->sBEGIN)); + sym = pic_sym(expr); - for (i = 0; i < argc; ++i) { - const char *filename; - if (! pic_str_p(argv[i])) { - pic_error(pic, "expected string"); + if (pic_interned_p(pic, sym)) { + return pic_sym_value(make_identifier(pic, pic_sym(expr), senv)); } - filename = pic_str_cstr(pic_str_ptr(argv[i])); - file = fopen(filename, "r"); - if (file == NULL) { - pic_error(pic, "could not open file"); + } + if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) { + pic_sym sym; + + sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv); + + if ((mac = find_macro(pic, sym)) != NULL) { + if (mac->senv == NULL) { /* legacy macro */ + args = pic_cdr(pic, expr); + } + else { + args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); + } + + return v; } - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - pic_error(pic, "parse error"); - } - body = pic_append(pic, body, exprs); } - return body; + return pic_undef_value(); /* no expansion occurred */ +} + +struct pic_senv * +pic_senv_new(pic_state *pic, struct pic_senv *up) +{ + struct pic_senv *senv; + + senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + senv->up = up; + xh_init_int(&senv->map, sizeof(pic_sym)); + + return senv; +} + +struct pic_senv * +pic_null_syntactic_environment(pic_state *pic) +{ + struct pic_senv *senv; + + senv = pic_senv_new(pic, NULL); + + pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); + pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT); + pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT); + + return senv; +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) +{ + pic_put_rename(pic, senv, sym, rsym); + + if (pic->lib && pic->lib->env == senv) { + pic_export(pic, sym); + } +} + +void +pic_defmacro(pic_state *pic, 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->env, 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,61 +584,20 @@ 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_macro_macroexpand_1(pic_state *pic) { - pic_value senv, free_vars, expr; - struct pic_sc *sc; + pic_value expr, val; - pic_get_args(pic, "ooo", &senv, &free_vars, &expr); + pic_get_args(pic, "o", &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); + val = macroexpand_one(pic, expr, pic->lib->env); + if (pic_undef_p(val)) { + return pic_values2(pic, expr, pic_false_value()); + } + else { + return pic_values2(pic, val, pic_true_value()); + } } static pic_value @@ -718,16 +607,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 +628,31 @@ 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_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, "macroexpand-1", pic_macro_macroexpand_1); pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); - pic_defun(pic, "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..be3eabce 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])) \ @@ -739,7 +744,7 @@ pic_init_number(pic_state *pic) pic_defun(pic, "number?", pic_number_real_p); pic_defun(pic, "complex?", pic_number_real_p); pic_defun(pic, "real?", pic_number_real_p); - pic_defun(pic, "rational?", pic_number_integer_p); + pic_defun(pic, "rational?", pic_number_real_p); pic_defun(pic, "integer?", pic_number_integer_p); pic_gc_arena_restore(pic, ai); @@ -777,6 +782,9 @@ pic_init_number(pic_state *pic) pic_defun(pic, "floor-remainder", pic_number_floor_remainder); pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient); pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); + pic_defun(pic, "modulo", pic_number_floor_remainder); + pic_defun(pic, "quotient", pic_number_trunc_quotient); + pic_defun(pic, "remainder", pic_number_trunc_remainder); pic_gc_arena_restore(pic, ai); pic_defun(pic, "gcd", pic_number_gcd); diff --git a/src/pair.c b/src/pair.c index bb4ef0bb..2c80f363 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) { @@ -235,6 +261,36 @@ pic_append(pic_state *pic, pic_value xs, pic_value ys) return ys; } +pic_value +pic_memq(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eq_p(key, pic_car(pic, list))) + return list; + + list = pic_cdr(pic, list); + goto enter; +} + +pic_value +pic_memv(pic_state *pic, pic_value key, pic_value list) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (pic_eqv_p(key, pic_car(pic, list))) + return list; + + list = pic_cdr(pic, list); + goto enter; +} + pic_value pic_assq(pic_state *pic, pic_value key, pic_value assoc) { @@ -253,6 +309,24 @@ pic_assq(pic_state *pic, pic_value key, pic_value assoc) goto enter; } +pic_value +pic_assv(pic_state *pic, pic_value key, pic_value assoc) +{ + pic_value cell; + + enter: + + if (pic_nil_p(assoc)) + return pic_false_value(); + + cell = pic_car(pic, assoc); + if (pic_eqv_p(key, pic_car(pic, cell))) + return cell; + + assoc = pic_cdr(pic, assoc); + goto enter; +} + pic_value pic_assoc(pic_state *pic, pic_value key, pic_value assoc) { @@ -568,6 +642,46 @@ pic_pair_list_copy(pic_state *pic) return pic_list_copy(pic, obj); } +static pic_value +pic_pair_memq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memq(pic, key, list); +} + +static pic_value +pic_pair_memv(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_memv(pic, key, list); +} + +static pic_value +pic_pair_assq(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assq(pic, key, list); +} + +static pic_value +pic_pair_assv(pic_state *pic) +{ + pic_value key, list; + + pic_get_args(pic, "oo", &key, &list); + + return pic_assv(pic, key, list); +} + void pic_init_pair(pic_state *pic) { @@ -592,4 +706,8 @@ pic_init_pair(pic_state *pic) pic_defun(pic, "list-ref", pic_pair_list_ref); pic_defun(pic, "list-set!", pic_pair_list_set); pic_defun(pic, "list-copy", pic_pair_list_copy); + pic_defun(pic, "memq", pic_pair_memq); + pic_defun(pic, "memv", pic_pair_memv); + pic_defun(pic, "assq", pic_pair_assq); + pic_defun(pic, "assv", pic_pair_assv); } diff --git a/src/port.c b/src/port.c index 168b5cce..8a3534bc 100644 --- a/src/port.c +++ b/src/port.c @@ -306,7 +306,7 @@ pic_port_open_output_string(pic_state *pic) static pic_value pic_port_get_output_string(pic_state *pic) { - struct pic_port *port = pic_stdout(pic);; + struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "|p", &port); @@ -329,6 +329,8 @@ pic_port_open_input_blob(pic_state *pic) port->status = PIC_PORT_OPEN; xfwrite(blob->data, 1, blob->len, port->file); + xfflush(port->file); + xrewind(port->file); return pic_obj_value(port); } @@ -351,7 +353,7 @@ pic_port_open_output_bytevector(pic_state *pic) static pic_value pic_port_get_output_bytevector(pic_state *pic) { - struct pic_port *port = pic_stdout(pic);; + struct pic_port *port = pic_stdout(pic); long endpos; char *buf; @@ -682,9 +684,11 @@ pic_port_flush(pic_state *pic) void pic_init_port(pic_state *pic) { - pic_defvar(pic, "current-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN)); - pic_defvar(pic, "current-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT)); - pic_defvar(pic, "current-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT)); + pic_deflibrary ("(picrin port)") { + pic_define(pic, "standard-input-port", port_new_stdport(pic, xstdin, PIC_PORT_IN)); + pic_define(pic, "standard-output-port", port_new_stdport(pic, xstdout, PIC_PORT_OUT)); + pic_define(pic, "standard-error-port", port_new_stdport(pic, xstderr, PIC_PORT_OUT)); + } pic_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); 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 95158fbd..62467ece 100644 --- a/src/read.c +++ b/src/read.c @@ -4,6 +4,7 @@ #include #include +#include #include "picrin.h" #include "picrin/error.h" #include "picrin/pair.h" @@ -15,11 +16,12 @@ typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, char); static pic_value read(pic_state *pic, struct pic_port *port, char c); +static pic_value read_nullable(pic_state *pic, struct pic_port *port, char c); static noreturn void read_error(pic_state *pic, const char *msg) { - pic_error(pic, msg); + pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value()); } static char @@ -47,6 +49,26 @@ peek(struct pic_port *port) return c; } +static bool +expect(struct pic_port *port, const char *str) +{ + char c; + + while ((c = *str++) != 0) { + if (c != peek(port)) + return false; + next(port); + } + + return true; +} + +static bool +isdelim(char c) +{ + return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ +} + static pic_value read_comment(pic_state *pic, struct pic_port *port, char c) { @@ -63,24 +85,22 @@ static pic_value read_block_comment(pic_state *pic, struct pic_port *port, char c) { char x, y; - int i; + int i = 1; UNUSED(pic); UNUSED(c); - x = next(port); y = next(port); - i = 1; - while (x != EOF && y != EOF && i > 0) { + while (y != EOF && i > 0) { + x = y; + y = next(port); if (x == '|' && y == '#') { i--; } if (x == '#' && y == '|') { i++; } - x = y; - y = next(port); } return pic_undef_value(); @@ -96,6 +116,27 @@ read_datum_comment(pic_state *pic, struct pic_port *port, char c) return pic_undef_value(); } +static pic_value +read_directive(pic_state *pic, struct pic_port *port, char c) +{ + switch (peek(port)) { + case 'n': + if (expect(port, "no-fold-case")) { + /* :FIXME: set no-fold-case flag */ + return pic_undef_value(); + } + break; + case 'f': + if (expect(port, "fold-case")) { + /* :FIXME: set fold-case flag */ + return pic_undef_value(); + } + break; + } + + return read_comment(pic, port, c); +} + static pic_value read_quote(pic_state *pic, struct pic_port *port, char c) { @@ -127,7 +168,6 @@ read_comma(pic_state *pic, struct pic_port *port, char c) static pic_value read_symbol(pic_state *pic, struct pic_port *port, char c) { - static const char TRAIL_SYMBOL[] = "+/*!$%&:@^~?<=>_.-"; size_t len; char *buf; pic_sym sym; @@ -140,9 +180,9 @@ read_symbol(pic_state *pic, struct pic_port *port, char c) c = next(port); } len += 1; - buf = pic_realloc(pic, buf, len); + buf = pic_realloc(pic, buf, len + 1); buf[len - 1] = c; - } while (isalnum(peek(port)) || strchr(TRAIL_SYMBOL, peek(port))); + } while (! isdelim(peek(port))); buf[len] = '\0'; sym = pic_intern_cstr(pic, buf); @@ -151,42 +191,55 @@ read_symbol(pic_state *pic, struct pic_port *port, char c) return pic_sym_value(sym); } -static int64_t -read_uinteger(pic_state *pic, struct pic_port *port, char c) +static size_t +read_uinteger(pic_state *pic, struct pic_port *port, char c, char buf[]) { - int64_t n; - - c = skip(port, c); + size_t i = 0; if (! isdigit(c)) { read_error(pic, "expected one or more digits"); } - n = c - '0'; + buf[i++] = c; while (isdigit(c = peek(port))) { - next(port); - n = n * 10 + c - '0'; + buf[i++] = next(port); } - return n; + buf[i] = '\0'; + + return i; } static pic_value read_number(pic_state *pic, struct pic_port *port, char c) { - int64_t i, j; + char buf[256]; + size_t i; + long n; - i = read_uinteger(pic, port, c); + i = read_uinteger(pic, port, c, buf); - if (peek(port) == '.') { + switch (peek(port)) { + case '.': + do { + buf[i++] = next(port); + } while (isdigit(peek(port))); + buf[i] = '\0'; + return pic_float_value(atof(buf)); + + case '/': + n = atoi(buf); next(port); - j = read_uinteger(pic, port, next(port)); - return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%lld", j))); - } - else { - return pic_int_value(i); - } + read_uinteger(pic, port, next(port), buf); + if (n == n / atoi(buf) * atoi(buf)) { + return pic_int_value(n / atoi(buf)); /* exact */ + } else { + return pic_float_value(n / (double)atoi(buf)); + } + default: + return pic_int_value(atoi(buf)); + } } static pic_value @@ -202,29 +255,39 @@ negate(pic_value n) static pic_value read_minus(pic_state *pic, struct pic_port *port, char c) { - static const char DIGITS[] = "0123456789"; + pic_value sym; - /* TODO: -inf.0, -nan.0 */ - - if (strchr(DIGITS, peek(port))) { - return negate(read_number(pic, port, c)); + if (isdigit(peek(port))) { + return negate(read_number(pic, port, next(port))); } else { - return read_symbol(pic, port, c); + sym = read_symbol(pic, port, c); + if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-inf.0")))) { + return pic_float_value(-INFINITY); + } + if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "-nan.0")))) { + return pic_float_value(-NAN); + } + return sym; } } static pic_value read_plus(pic_state *pic, struct pic_port *port, char c) { - static const char DIGITS[] = "0123456789"; + pic_value sym; - /* TODO: +inf.0, +nan.0 */ - - if (strchr(DIGITS, peek(port))) { - return read_number(pic, port, c); + if (isdigit(peek(port))) { + return read_number(pic, port, next(port)); } else { + sym = read_symbol(pic, port, c); + if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+inf.0")))) { + return pic_float_value(INFINITY); + } + if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+nan.0")))) { + return pic_float_value(NAN); + } return read_symbol(pic, port, c); } } @@ -235,24 +298,61 @@ read_boolean(pic_state *pic, struct pic_port *port, char c) UNUSED(pic); UNUSED(port); - /* TODO: support #true and #false */ + if (! isdelim(peek(port))) { + if (c == 't') { + if (! expect(port, "rue")) { + goto fail; + } + } else { + if (! expect(port, "alse")) { + goto fail; + } + } + } if (c == 't') { return pic_true_value(); } else { return pic_false_value(); } + + fail: + read_error(pic, "illegal character during reading boolean literal"); } static pic_value read_char(pic_state *pic, struct pic_port *port, char c) { - UNUSED(pic); - UNUSED(c); + c = next(port); - /* TODO: #\alart, #\space, so on and so on */ + if (! isdelim(peek(port))) { + switch (c) { + default: read_error(pic, "unexpected character after char literal"); + case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break; + case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break; + case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break; + case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break; + case 'n': + if ((c = peek(port)) == 'e') { + c = '\n'; + if (! expect(port, "ewline")) + goto fail; + } else { + c = '\0'; + if (! expect(port, "ull")) + goto fail; + } + break; + case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break; + case 's': c = ' '; if (! expect(port, "pace")) goto fail; break; + case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break; + } + } - return pic_char_value(next(port)); + return pic_char_value(c); + + fail: + read_error(pic, "unexpected character while reading character literal"); } static pic_value @@ -285,17 +385,61 @@ read_string(pic_state *pic, struct pic_port *port, char c) } buf[cnt] = '\0'; - str = pic_str_new(pic, buf, size); + str = pic_str_new(pic, buf, cnt); pic_free(pic, buf); return pic_obj_value(str); } +static pic_value +read_pipe(pic_state *pic, struct pic_port *port, char c) +{ + char *buf; + size_t size, cnt; + pic_sym sym; + /* Currently supports only ascii chars */ + char HEX_BUF[3]; + size_t i = 0; + + size = 256; + buf = pic_alloc(pic, size); + cnt = 0; + while ((c = next(port)) != '|') { + if (c == '\\') { + switch (c = next(port)) { + case 'a': c = '\a'; break; + case 'b': c = '\b'; break; + case 't': c = '\t'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + case 'x': + i = 0; + while ((HEX_BUF[i++] = next(port)) != ';') { + if (i >= sizeof HEX_BUF) + read_error(pic, "expected ';'"); + } + c = (char)strtol(HEX_BUF, NULL, 16); + break; + } + } + buf[cnt++] = c; + if (cnt >= size) { + buf = pic_realloc(pic, buf, size *= 2); + } + } + buf[cnt] = '\0'; + + sym = pic_intern_cstr(pic, buf); + pic_free(pic, buf); + + return pic_sym_value(sym); +} + static pic_value read_unsigned_blob(pic_state *pic, struct pic_port *port, char c) { int nbits, n; size_t len; - char *buf; + char *dat, buf[256]; pic_blob *blob; nbits = 0; @@ -313,21 +457,22 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c) } len = 0; - buf = NULL; + dat = NULL; c = next(port); while ((c = skip(port, c)) != ')') { - n = read_uinteger(pic, port, c); + read_uinteger(pic, port, c, buf); + n = atoi(buf); if (n < 0 || (1 << nbits) <= n) { read_error(pic, "invalid element in bytevector literal"); } len += 1; - buf = pic_realloc(pic, buf, len); - buf[len - 1] = n; + dat = pic_realloc(pic, dat, len); + dat[len - 1] = n; c = next(port); } - blob = pic_blob_new(pic, buf, len); - pic_free(pic, buf); + blob = pic_blob_new(pic, dat, len); + pic_free(pic, dat); return pic_obj_value(blob); } @@ -337,21 +482,32 @@ read_pair(pic_state *pic, struct pic_port *port, char c) char tOPEN = c, tCLOSE = (tOPEN == '(') ? ')' : ']'; pic_value car, cdr; + retry: + c = skip(port, ' '); if (c == tCLOSE) { return pic_nil_value(); } - if (c == '.' && strchr("()#;,|'\" \t\n\r", peek(port)) != NULL) { + if (c == '.' && isdelim(peek(port))) { cdr = read(pic, port, next(port)); + closing: if ((c = skip(port, ' ')) != tCLOSE) { + if (pic_undef_p(read_nullable(pic, port, c))) { + goto closing; + } read_error(pic, "unmatched parenthesis"); } return cdr; } else { - car = read(pic, port, c); + car = read_nullable(pic, port, c); + + if (pic_undef_p(car)) { + goto retry; + } + cdr = read_pair(pic, port, tOPEN); /* FIXME: don't use recursion */ return pic_cons(pic, car, cdr); } @@ -360,16 +516,11 @@ read_pair(pic_state *pic, struct pic_port *port, char c) static pic_value read_vector(pic_state *pic, struct pic_port *port, char c) { - pic_value val; + pic_value list; - c = next(port); + list = read(pic, port, c); - val = pic_nil_value(); - while ((c = skip(port, c)) != ')') { - val = pic_cons(pic, read(pic, port, c), val); - c = next(port); - } - return pic_obj_value(pic_vec_new_from_list(pic, pic_reverse(pic, val))); + return pic_obj_value(pic_vec_new_from_list(pic, list)); } static pic_value @@ -470,7 +621,7 @@ read_dispatch(pic_state *pic, struct pic_port *port, char c) switch (c) { case '!': - return read_comment(pic, port, c); + return read_directive(pic, port, c); case '|': return read_block_comment(pic, port, c); case ';': @@ -513,6 +664,8 @@ read_nullable(pic_state *pic, struct pic_port *port, char c) return read_comma(pic, port, c); case '"': return read_string(pic, port, c); + case '|': + return read_pipe(pic, port, c); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': return read_number(pic, port, c); diff --git a/src/state.c b/src/state.c index 63a25254..758bae9c 100644 --- a/src/state.c +++ b/src/state.c @@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sUNQUOTE, "unquote"); register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); - register_core_symbol(pic, sDEFINE_MACRO, "define-macro"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sIMPORT, "import"); register_core_symbol(pic, sEXPORT, "export"); @@ -116,6 +115,23 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sNOT, "not"); pic_gc_arena_restore(pic, ai); +#define register_renamed_symbol(pic,slot,name) do { \ + pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \ + } while (0) + + ai = pic_gc_arena_preserve(pic); + register_renamed_symbol(pic, rDEFINE, "define"); + register_renamed_symbol(pic, rLAMBDA, "lambda"); + register_renamed_symbol(pic, rIF, "if"); + register_renamed_symbol(pic, rBEGIN, "begin"); + register_renamed_symbol(pic, rSETBANG, "set!"); + register_renamed_symbol(pic, rQUOTE, "quote"); + register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax"); + register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); + register_renamed_symbol(pic, rIMPORT, "import"); + register_renamed_symbol(pic, rEXPORT, "export"); + pic_gc_arena_restore(pic, ai); + pic_init_core(pic); /* set library */ diff --git a/src/string.c b/src/string.c index edaf1edc..73dba061 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 @@ -349,6 +350,9 @@ pic_str_string_copy_ip(pic_state *pic) case 4: end = pic_strlen(from); } + if (to == from) { + from = pic_substr(pic, from, 0, end); + } while (start < end) { pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); @@ -385,9 +389,9 @@ pic_str_string_fill_ip(pic_state *pic) n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); switch (n) { - case 1: - start = 0; case 2: + start = 0; + case 3: end = pic_strlen(str); } 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 9e4509f4..7dc788cc 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++; } @@ -376,7 +376,7 @@ global_ref(pic_state *pic, const char *name) pic_sym sym, rename; sym = pic_intern_cstr(pic, name); - if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) { + if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { return SIZE_MAX; } if (! (e = xh_get_int(&pic->global_tbl, rename))) { @@ -398,7 +398,7 @@ global_def(pic_state *pic, const char *name) } /* register to the senv */ - rename = pic_add_rename(pic, pic->lib->senv, sym); + rename = pic_add_rename(pic, pic->lib->env, sym); /* register to the global table */ gidx = pic->glen++; @@ -427,7 +427,7 @@ pic_ref(pic_state *pic, const char *name) gid = global_ref(pic, name); if (gid == SIZE_MAX) { - pic_error(pic, "symbol not defined"); + pic_errorf(pic, "symbol \"%s\" not defined", name); } return pic->globals[gid]; } @@ -444,6 +444,18 @@ pic_set(pic_state *pic, const char *name, pic_value value) pic->globals[gid] = value; } +pic_value +pic_funcall(pic_state *pic, const char *name, pic_list args) +{ + pic_value proc; + + proc = pic_ref(pic, name); + + pic_assert_type(pic, proc, proc); + + return pic_apply(pic, pic_proc_ptr(proc), args); +} + void pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) { @@ -453,15 +465,6 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) pic_define(pic, name, pic_obj_value(proc)); } -void -pic_defvar(pic_state *pic, const char *name, pic_value init) -{ - struct pic_var *var; - - var = pic_var_new(pic, init, NULL); - pic_define(pic, name, pic_obj_value(pic_wrap_var(pic, var))); -} - static void vm_push_env(pic_state *pic) { diff --git a/src/write.c b/src/write.c index 4aae7e44..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; 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 index e5ce8af7..1cf0cb0a 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -32,52 +32,18 @@ ; (scheme complex) (scheme time) (scheme file) -; (scheme read) + (scheme read) (scheme write) ; (scheme eval) (scheme process-context) -; (scheme case-lambda) - ) + (scheme case-lambda) + (picrin test)) ;; R7RS test suite. Covers all procedures and syntax in the small ;; language except `delete-file'. Currently assumes full-unicode ;; support, the full numeric tower and all standard libraries ;; provided. -(define (test-begin . o) #f) - -(define (test-end . o) #f) - -(define counter 1) - -(define-syntax test - (syntax-rules () - ((test expected expr) - (let ((res expr)) - (display "case ") - (write counter) - (cond - ((equal? res expected) - (display " PASS: ") - (write 'expr) - (display " equals ") - (write expected) - (display "") - (newline) - ) - ((not (equal? res expected)) - (display " FAIL: ") - (write 'expr) - (newline) - (display " expected ") - (write expected) - (display " but got ") - (write res) - (display "") - (newline))) - (set! counter (+ counter 1)))))) - -(newline) (test-begin "R7RS") @@ -240,7 +206,7 @@ (mean / /)))) (let*-values (((a b c) (means '(8 5 99 1 22)))) (test 27 a) - (test 9.728 b) + (test 9.7280002558226410514 b) (test (/ 1800 497) c)) (let*-values (((root rem) (exact-integer-sqrt 32))) @@ -310,7 +276,7 @@ (test 3 (force (delay (+ 1 2)))) -(test '(3 3) +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) @@ -328,7 +294,7 @@ (define (stream-filter p? s) (delay-force - (if (null? (force s)) + (if (null? (force s)) (delay '()) (let ((h (car (force s))) (t (cdr (force s)))) @@ -364,18 +330,18 @@ -;; (define radix -;; (make-parameter -;; 10 -;; (lambda (x) -;; (if (and (integer? x) (<= 2 x 16)) -;; x -;; (error "invalid radix"))))) -;; (define (f n) (number->string n (radix))) -;; (test "12" (f 12)) -;; (test "1100" (parameterize ((radix 2)) -;; (f 12))) -;; (test "12" (f 12)) +(define radix + (make-parameter + 10 + (lambda (x) + (if (and (integer? x) (<= 2 x 16)) + x + (error "invalid radix"))))) +(define (f n) (number->string n (radix))) +(test "12" (f 12)) +(test "1100" (parameterize ((radix 2)) + (f 12))) +(test "12" (f 12)) (test '(list 3 4) `(list ,(+ 1 2) 4)) (let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name))) (test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) @@ -389,70 +355,70 @@ (test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) -;; (define plus -;; (case-lambda -;; (() 0) -;; ((x) x) -;; ((x y) (+ x y)) -;; ((x y z) (+ (+ x y) z)) -;; (args (apply + args)))) +(define plus + (case-lambda + (() 0) + ((x) x) + ((x y) (+ x y)) + ((x y z) (+ (+ x y) z)) + (args (apply + args)))) -;; (test 0 (plus)) -;; (test 1 (plus 1)) -;; (test 3 (plus 1 2)) -;; (test 6 (plus 1 2 3)) -;; (test 10 (plus 1 2 3 4)) +(test 0 (plus)) +(test 1 (plus 1)) +(test 3 (plus 1 2)) +(test 6 (plus 1 2 3)) +(test 10 (plus 1 2 3 4)) -;; (define mult -;; (case-lambda -;; (() 1) -;; ((x) x) -;; ((x y) (* x y)) -;; ((x y . z) (apply mult (* x y) z)))) +(define mult + (case-lambda + (() 1) + ((x) x) + ((x y) (* x y)) + ((x y . z) (apply mult (* x y) z)))) -;; (test 1 (mult)) -;; (test 1 (mult 1)) -;; (test 2 (mult 1 2)) -;; (test 6 (mult 1 2 3)) -;; (test 24 (mult 1 2 3 4)) +(test 1 (mult)) +(test 1 (mult 1)) +(test 2 (mult 1 2)) +(test 6 (mult 1 2 3)) +(test 24 (mult 1 2 3 4)) (test-end) (test-begin "4.3 Macros") -;; (test 'now (let-syntax -;; ((when (syntax-rules () -;; ((when test stmt1 stmt2 ...) -;; (if test -;; (begin stmt1 -;; stmt2 ...)))))) -;; (let ((if #t)) -;; (when if (set! if 'now)) -;; if))) +(test 'now (let-syntax + ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if))) -;; (test 'outer (let ((x 'outer)) -;; (let-syntax ((m (syntax-rules () ((m) x)))) -;; (let ((x 'inner)) -;; (m))))) +(test 'outer (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m))))) -;; (test 7 (letrec-syntax -;; ((my-or (syntax-rules () -;; ((my-or) #f) -;; ((my-or e) e) -;; ((my-or e1 e2 ...) -;; (let ((temp e1)) -;; (if temp -;; temp -;; (my-or e2 ...))))))) -;; (let ((x #f) -;; (y 7) -;; (temp 8) -;; (let odd?) -;; (if even?)) -;; (my-or x -;; (let temp) -;; (if y) -;; y)))) +(test 7 (letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y)))) (define-syntax be-like-begin (syntax-rules () @@ -500,10 +466,10 @@ (let () (define-values (x) (values 1)) x)) -;; (test 3 -;; (let () -;; (define-values x (values 1 2)) -;; (apply + x))) +(test 3 + (let () + (define-values x (values 1 2)) + (apply + x))) (test 3 (let () (define-values (x y) (values 1 2)) @@ -512,10 +478,10 @@ (let () (define-values (x y z) (values 1 2 3)) (+ x y z))) -;; (test 10 -;; (let () -;; (define-values (x y . z) (values 1 2 3 4)) -;; (+ x y (car z) (cadr z)))) +(test 10 + (let () + (define-values (x y . z) (values 1 2 3 4)) + (+ x y (car z) (cadr z)))) (test '(2 1) (let ((x 1) (y 2)) (define-syntax swap! @@ -606,6 +572,53 @@ (test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) +;; circular objects +(let ((l '(1 . 2)) + (m '(1 . 2))) + (set-cdr! l l) + (set-cdr! m m) + (test #t (equal? l m))) + +(let ((l '(1 . 2)) + (m '(2 . 1))) + (set-cdr! l l) + (set-cdr! m m) + (test #f (equal? l m))) + + +(let ((v (make-vector 2 1)) + (w (make-vector 2 1))) + (vector-set! v 1 v) + (vector-set! w 1 w) + (test #t (equal? v w))) + + +(let ((v (make-vector 2 1)) + (w (make-vector 2 2))) + (vector-set! v 1 v) + (vector-set! w 1 w) + (test #f (equal? v w))) + +(let ((v (make-vector 2 1)) + (w (make-vector 2 1)) + (l '(1 . 2)) + (m '(1 . 2))) + (vector-set! v 1 l) + (vector-set! w 1 m) + (set-cdr! l v) + (set-cdr! m w) + (test #t (equal? v w))) + +(let ((v (make-vector 2 2)) + (w (make-vector 2 1)) + (l '(1 . 2)) + (m '(1 . 2))) + (vector-set! v 1 l) + (vector-set! w 1 m) + (set-cdr! l v) + (set-cdr! m w) + (test #f (equal? v w))) + (test-end) (test-begin "6.2 Numbers") @@ -618,11 +631,11 @@ ;; (test #t (real? #e1e10)) (test #t (real? +inf.0)) (test #f (rational? -inf.0)) -;; (test #t (rational? 6/10)) -;; (test #t (rational? 6/3)) +(test #t (rational? 6/10)) +(test #t (rational? 6/3)) ;; (test #t (integer? 3+0i)) (test #t (integer? 3.0)) -;; (test #t (integer? 8/4)) +(test #t (integer? 8/4)) (test #f (exact? 3.0)) ;; (test #t (exact? #e3.0)) @@ -630,7 +643,7 @@ (test #t (exact-integer? 32)) (test #f (exact-integer? 32.0)) -;; (test #f (exact-integer? 32/5)) +(test #f (exact-integer? 32/5)) (test #t (finite? 3)) (test #f (finite? +inf.0)) @@ -648,14 +661,14 @@ ;; (test #t (= 1 1.0 1.0+0.0i)) ;; (test #f (= 1.0 1.0+1.0i)) -;; (test #t (< 1 2 3)) -;; (test #f (< 1 1 2)) -;; (test #t (> 3.0 2.0 1.0)) -;; (test #f (> -3.0 2.0 1.0)) -;; (test #t (<= 1 1 2)) -;; (test #f (<= 1 2 1)) -;; (test #t (>= 2 1 1)) -;; (test #f (>= 1 2 1)) +(test #t (< 1 2 3)) +(test #f (< 1 1 2)) +(test #t (> 3.0 2.0 1.0)) +(test #f (> -3.0 2.0 1.0)) +(test #t (<= 1 1 2)) +(test #f (<= 1 2 1)) +(test #t (>= 2 1 1)) +(test #f (>= 1 2 1)) ;; From R7RS 6.2.6 Numerical operations: ;; @@ -744,8 +757,8 @@ (test -1 (- 3 4)) (test -6 (- 3 4 5)) (test -3 (- 3)) -;; (test 3/20 (/ 3 4 5)) -;; (test 1/3 (/ 3)) +(test 3/20 (/ 3 4 5)) +(test 1/3 (/ 3)) (test 7 (abs -7)) (test 7 (abs 7)) @@ -798,14 +811,14 @@ (test 3.0 (truncate 3.5)) (test 4.0 (round 3.5)) -;; (test 4 (round 7/2)) +(test 4 (exact (round 7/2))) (test 7 (round 7)) ;; (test 1/3 (rationalize (exact .3) 1/10)) ;; (test #i1/3 (rationalize .3 1/10)) (test 1.0 (inexact (exp 0))) ;; may return exact number -(test 20.0855369231877 (exp 3)) +(test 20.0855369231876679236 (exp 3)) (test 0.0 (inexact (log 1))) ;; may return exact number (test 1.0 (log (exp 1))) @@ -818,30 +831,30 @@ (test 1.0 (inexact (cos 0))) ;; may return exact number (test -1.0 (cos 3.14159265358979)) (test 0.0 (inexact (tan 0))) ;; may return exact number -(test 1.5574077246549 (tan 1)) +(test 1.5574077246549020703 (tan 1)) (test 0.0 (asin 0)) -(test 1.5707963267949 (asin 1)) +(test 1.5707963267948965580 (asin 1)) (test 0.0 (acos 1)) -(test 3.14159265358979 (acos -1)) +(test 3.1415926535897931160 (acos -1)) (test 0.0 (atan 0.0 1.0)) (test -0.0 (atan -0.0 1.0)) -(test 0.785398163397448 (atan 1.0 1.0)) -(test 1.5707963267949 (atan 1.0 0.0)) -(test 2.35619449019234 (atan 1.0 -1.0)) -(test 3.14159265358979 (atan 0.0 -1.0)) -(test -3.14159265358979 (atan -0.0 -1.0)) ; -(test -2.35619449019234 (atan -1.0 -1.0)) -(test -1.5707963267949 (atan -1.0 0.0)) -(test -0.785398163397448 (atan -1.0 1.0)) +(test 0.7853981633974482790 (atan 1.0 1.0)) +(test 1.5707963267948965580 (atan 1.0 0.0)) +(test 2.3561944901923448370 (atan 1.0 -1.0)) +(test 3.1415926535897931160 (atan 0.0 -1.0)) +(test -3.1415926535897931160 (atan -0.0 -1.0)) ; +(test -2.3561944901923448370 (atan -1.0 -1.0)) +(test -1.5707963267948965580 (atan -1.0 0.0)) +(test -0.7853981633974482790 (atan -1.0 1.0)) ;; (test undefined (atan 0.0 0.0)) (test 1764 (square 42)) (test 4 (square 2)) (test 3.0 (inexact (sqrt 9))) -(test 1.4142135623731 (sqrt 2)) +(test 1.4142135623730951454 (sqrt 2)) ;; (test 0.0+1.0i (inexact (sqrt -1))) (test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list)) @@ -1017,7 +1030,7 @@ (test #t (symbol=? 'a 'a 'a)) (test #f (symbol=? 'a 'a 'A)) -(test "flying-fish" +(test "flying-fish" (symbol->string 'flying-fish)) (test "Martin" (symbol->string 'Martin)) (test "Malvina" (symbol->string (string->symbol "Malvina"))) @@ -1151,7 +1164,7 @@ ;; (string-set! s 1 #\x1F700) ;; s)) -#;(test #t (string=? "" "")) +(test #t (string=? "" "")) (test #t (string=? "abc" "abc" "abc")) (test #f (string=? "" "abc")) (test #f (string=? "abc" "aBc")) @@ -1275,29 +1288,29 @@ (test "b" (string-copy "abc" 1 2)) (test "bc" (string-copy "abc" 1 3)) -;; (test "-----" -;; (let ((str (make-string 5 #\x))) (string-fill! str #\-) str)) -;; (test "xx---" -;; (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str)) -;; (test "xx-xx" -;; (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str)) +(test "-----" + (let ((str (make-string 5 #\x))) (string-fill! str #\-) str)) +(test "xx---" + (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str)) +(test "xx-xx" + (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str)) -;; (test "a12de" -;; (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str)) -;; (test "-----" -;; (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str)) -;; (test "---xx" -;; (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str)) -;; (test "xx---" -;; (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str)) -;; (test "xx-xx" -;; (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str)) +(test "a12de" + (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str)) +(test "-----" + (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str)) +(test "---xx" + (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str)) +(test "xx---" + (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str)) +(test "xx-xx" + (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str)) ;; same source and dest -;; (test "aabde" -;; (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str)) -;; (test "abcab" -;; (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str)) +(test "aabde" + (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str)) +(test "abcab" + (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str)) (test-end) @@ -1802,9 +1815,9 @@ (output-port-open? out))) (test #t (eof-object? (eof-object))) -;; (test #t (eof-object? (read (open-input-string "")))) +(test #t (eof-object? (read (open-input-string "")))) (test #t (char-ready? (open-input-string "42"))) -;; (test 42 (read (open-input-string " 42 "))) +(test 42 (read (open-input-string " 42 "))) (test #t (eof-object? (read-char (open-input-string "")))) (test #\a (read-char (open-input-string "abc"))) @@ -1962,62 +1975,56 @@ (test-begin "Read syntax") ;; check reading boolean followed by eof -;; (test #t (read (open-input-string "#t"))) -;; (test #t (read (open-input-string "#true"))) -;; (test #f (read (open-input-string "#f"))) -;; (test #f (read (open-input-string "#false"))) -;; (define (read2 port) -;; (let* ((o1 (read port)) (o2 (read port))) -;; (cons o1 o2))) -;; ;; check reading boolean followed by delimiter -;; (test '(#t . (5)) (read2 (open-input-string "#t(5)"))) -;; (test '(#t . 6) (read2 (open-input-string "#true 6 "))) -;; (test '(#f . 7) (read2 (open-input-string "#f 7"))) -;; (test '(#f . "8") (read2 (open-input-string "#false\"8\""))) +(test #t (read (open-input-string "#t"))) +(test #t (read (open-input-string "#true"))) +(test #f (read (open-input-string "#f"))) +(test #f (read (open-input-string "#false"))) +(define (read2 port) + (let* ((o1 (read port)) (o2 (read port))) + (cons o1 o2))) +;; check reading boolean followed by delimiter +(test '(#t . (5)) (read2 (open-input-string "#t(5)"))) +(test '(#t . 6) (read2 (open-input-string "#true 6 "))) +(test '(#f . 7) (read2 (open-input-string "#f 7"))) +(test '(#f . "8") (read2 (open-input-string "#false\"8\""))) -;; (test '() (read (open-input-string "()"))) -;; (test '(1 2) (read (open-input-string "(1 2)"))) -;; (test '(1 . 2) (read (open-input-string "(1 . 2)"))) -;; (test '(1 2) (read (open-input-string "(1 . (2))"))) -;; (test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))"))) -;; (test '1 (cadr (read (open-input-string "#0=(1 . #0#)")))) -;; (test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)")))) +(test '() (read (open-input-string "()"))) +(test '(1 2) (read (open-input-string "(1 2)"))) +(test '(1 . 2) (read (open-input-string "(1 . 2)"))) +(test '(1 2) (read (open-input-string "(1 . (2))"))) +(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))"))) +(test '1 (cadr (read (open-input-string "#0=(1 . #0#)")))) +(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)")))) -;; (test '(quote (1 2)) (read (open-input-string "'(1 2)"))) -;; (test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)"))) -;; (test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)"))) -;; (test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)"))) +(test '(quote (1 2)) (read (open-input-string "'(1 2)"))) +(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)"))) +(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)"))) +(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)"))) -;; (test #() (read (open-input-string "#()"))) -;; (test #(a b) (read (open-input-string "#(a b)"))) +(test #() (read (open-input-string "#()"))) +(test #(a b) (read (open-input-string "#(a b)"))) -;; (test #u8() (read (open-input-string "#u8()"))) -;; (test #u8(0 1) (read (open-input-string "#u8(0 1)"))) +(test #u8() (read (open-input-string "#u8()"))) +(test #u8(0 1) (read (open-input-string "#u8(0 1)"))) -;; (test 'abc (read (open-input-string "abc"))) -;; (test 'abc (read (open-input-string "abc def"))) -;; (test 'ABC (read (open-input-string "ABC"))) -;; (test 'Hello (read (open-input-string "|H\\x65;llo|"))) +(test 'abc (read (open-input-string "abc"))) +(test 'abc (read (open-input-string "abc def"))) +(test 'ABC (read (open-input-string "ABC"))) +(test 'Hello (read (open-input-string "|H\\x65;llo|"))) -;; (test 'abc (read (open-input-string "#!fold-case ABC"))) -;; (test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC"))) +(test 'abc (read (open-input-string "#!fold-case ABC"))) +(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC"))) -;; (test 'def (read (open-input-string "#; abc def"))) -;; (test 'def (read (open-input-string "; abc \ndef"))) -;; (test 'def (read (open-input-string "#| abc |# def"))) -;; (test 'ghi (read (open-input-string "#| abc #| def |# |# ghi"))) -;; (test 'ghi (read (open-input-string "#; ; abc\n def ghi"))) -;; (test '(abs -16) (read (open-input-string "(#;sqrt abs -16)"))) -;; (test '(a d) (read (open-input-string "(a #; #;b c d)"))) -;; (test '(a e) (read (open-input-string "(a #;(b #;c d) e)"))) -;; (test '(a . c) (read (open-input-string "(a . #;b c)"))) -;; (test '(a . b) (read (open-input-string "(a . b #;c)"))) - -;; (define (test-read-error str) -;; (test-assert -;; (guard (exn (else #t)) -;; (read (open-input-string str)) -;; #f))) +(test 'def (read (open-input-string "#; abc def"))) +(test 'def (read (open-input-string "; abc \ndef"))) +(test 'def (read (open-input-string "#| abc |# def"))) +(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi"))) +(test 'ghi (read (open-input-string "#; ; abc\n def ghi"))) +(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)"))) +(test '(a d) (read (open-input-string "(a #; #;b c d)"))) +(test '(a e) (read (open-input-string "(a #;(b #;c d) e)"))) +(test '(a . c) (read (open-input-string "(a . #;b c)"))) +(test '(a . b) (read (open-input-string "(a . b #;c)"))) ;; (test-read-error "(#;a . b)") ;; (test-read-error "(a . #;b)") @@ -2058,56 +2065,25 @@ ;; (test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\""))) ;; (test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0))) -;; (test-end) +(test-end) (test-begin "Numeric syntax") -;; Numeric syntax adapted from Peter Bex's tests. -;; -;; These are updated to R7RS, using string ports instead of -;; string->number, and "error" tests removed because implementations -;; are free to provide their own numeric extensions. Currently all -;; tests are run by default - need to cond-expand and test for -;; infinities and -0.0. - -;; (define-syntax test-numeric-syntax -;; (syntax-rules () -;; ((test-numeric-syntax str expect strs ...) -;; (let* ((z (read (open-input-string str))) -;; (out (open-output-string)) -;; (z-str (begin (write z out) (get-output-string out)))) -;; (test expect (values z)) -;; (test #t (and (member z-str '(str strs ...)) #t)))))) - -;; Each test is of the form: -;; -;; (test-numeric-syntax input-str expected-value expected-write-values ...) -;; -;; where the input should be eqv? to the expected-value, and the -;; written output the same as any of the expected-write-values. The -;; form -;; -;; (test-numeric-syntax input-str expected-value) -;; -;; is a shorthand for -;; -;; (test-numeric-syntax input-str expected-value (input-str)) - ;; Simple -;; (test-numeric-syntax "1" 1) +(test-numeric-syntax "1" 1) ;; (test-numeric-syntax "+1" 1 "1") -;; (test-numeric-syntax "-1" -1) +(test-numeric-syntax "-1" -1) ;; (test-numeric-syntax "#i1" 1.0 "1.0" "1.") ;; (test-numeric-syntax "#I1" 1.0 "1.0" "1.") ;; (test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.") ;; ;; Decimal -;; (test-numeric-syntax "1.0" 1.0 "1.0" "1.") -;; (test-numeric-syntax "1." 1.0 "1.0" "1.") -;; (test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3") -;; (test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3") +(test-numeric-syntax "1.0" 1.0 "1.0" "1.") +(test-numeric-syntax "1." 1.0 "1.0" "1.") +(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3") +(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3") ;; ;; Some Schemes don't allow negative zero. This is okay with the standard -;; (test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0") -;; (test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0") +(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0") +(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0") ;; (test-numeric-syntax "#i1.0" 1.0 "1.0" "1.") ;; (test-numeric-syntax "#e1.0" 1 "1") ;; (test-numeric-syntax "#e-.0" 0 "0") @@ -2124,21 +2100,21 @@ ;; (test-numeric-syntax "1l2" 100.0 "100.0" "100.") ;; (test-numeric-syntax "1L2" 100.0 "100.0" "100.") ;; ;; NaN, Inf -;; (test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0") -;; (test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0") -;; (test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0") -;; (test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0") -;; (test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0") -;; (test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0") +(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0") +(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0") +(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0") +(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0") +(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0") +(test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0") ;; (test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0") ;; (test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0") ;; (test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0") ;; ;; Exact ratios -;; (test-numeric-syntax "1/2" (/ 1 2)) +(test-numeric-syntax "1/2" (/ 1 2)) ;; (test-numeric-syntax "#e1/2" (/ 1 2) "1/2") -;; (test-numeric-syntax "10/2" 5 "5") -;; (test-numeric-syntax "-1/2" (- (/ 1 2))) -;; (test-numeric-syntax "0/10" 0 "0") +(test-numeric-syntax "10/2" 5 "5") +(test-numeric-syntax "-1/2" (- (/ 1 2))) +(test-numeric-syntax "0/10" 0 "0") ;; (test-numeric-syntax "#e0/10" 0 "0") ;; (test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5") ;; ;; Exact complex @@ -2168,7 +2144,7 @@ ;; (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 "+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") @@ -2226,17 +2202,17 @@ ;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH")) -;; (test #t (string? (get-environment-variable "PATH"))) +(test #t (string? (get-environment-variable "PATH"))) ;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables)) -;; (let ((env (get-environment-variables))) -;; (define (env-pair? x) -;; (and (pair? x) (string? (car x)) (string? (cdr x)))) -;; (define (all? pred ls) -;; (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls))))) -;; (test #t (list? env)) -;; (test #t (all? env-pair? env))) +(let ((env (get-environment-variables))) + (define (env-pair? x) + (and (pair? x) (string? (car x)) (string? (cdr x)))) + (define (all? pred ls) + (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls))))) + (test #t (list? env)) + (test #t (all? env-pair? env))) (test #t (list? (command-line)))