From 86a27e95b7de358b8b9f43c707f191b9ca159457 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Wed, 28 May 2014 22:49:53 +0900 Subject: [PATCH 001/200] add alias of `modulo`, `remainder`, `quotient` --- src/number.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/number.c b/src/number.c index fb9a4c1f..45fd54f1 100644 --- a/src/number.c +++ b/src/number.c @@ -777,6 +777,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); From a9c4cefe882968e61f663a81c8ce5e1946ec51e4 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Thu, 29 May 2014 01:22:19 +0900 Subject: [PATCH 002/200] `quotient` is defined in base --- piclib/srfi/95.scm | 3 --- 1 file changed, 3 deletions(-) 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)) From 2ce361a7bcf165f9dfd52db7c8aa173a27e73d53 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 18 Jun 2014 09:53:53 +0900 Subject: [PATCH 003/200] notice on the auto-generated file load_piclib.c --- etc/mkloader.pl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/etc/mkloader.pl b/etc/mkloader.pl index ff60c784..1702414c 100755 --- a/etc/mkloader.pl +++ b/etc/mkloader.pl @@ -3,6 +3,13 @@ use strict; print < Date: Wed, 18 Jun 2014 22:00:24 +0900 Subject: [PATCH 004/200] correct `pair-for-each` --- piclib/srfi/1.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index e1b2a4f1..259c0c5a 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -358,10 +358,10 @@ (if (null? clist) (let rec ((clist clist)) (if (pair? clist) - (begin (f (car clist)) (rec (cdr clist))))) + (begin (f clist) (rec (cdr clist))))) (let rec ((clists (cons clist clists))) (if (every pair? clists) - (begin (apply f (map car clists)) (rec (map cdr clists))))))) + (begin (apply f clists) (rec (map cdr clists))))))) (define (map! f list . lists) (if (null? lists) From 5f4dcd331c3bf74be591df607908d8a582974fef Mon Sep 17 00:00:00 2001 From: stibear Date: Thu, 19 Jun 2014 03:21:53 +0900 Subject: [PATCH 005/200] implements (srfi 8) --- piclib/srfi/8.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 piclib/srfi/8.scm diff --git a/piclib/srfi/8.scm b/piclib/srfi/8.scm new file mode 100644 index 00000000..082abe68 --- /dev/null +++ b/piclib/srfi/8.scm @@ -0,0 +1,10 @@ +(define-library (srfi 8) + (import (scheme base)) + + (define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...))))) + + (export receive)) From d765d803cbfe3b4b79e78ca6bea01b3162a5f4a5 Mon Sep 17 00:00:00 2001 From: stibear Date: Thu, 19 Jun 2014 03:23:47 +0900 Subject: [PATCH 006/200] implements (srfi 43) --- piclib/srfi/43.scm | 247 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 247 insertions(+) create mode 100644 piclib/srfi/43.scm diff --git a/piclib/srfi/43.scm b/piclib/srfi/43.scm new file mode 100644 index 00000000..a30757e6 --- /dev/null +++ b/piclib/srfi/43.scm @@ -0,0 +1,247 @@ +(define-library (srfi 43) + (import (scheme base) + (srfi 8)) + + ;; # Constructors + (define (vector-unfold f length . seeds) + (let ((seeds (if (null? seeds) '(0) seeds)) + (vect (make-vector length))) + (letrec ((tabulate + (lambda (count . args) + (if (= length count) + vect + (receive lst (apply f count args) + (vector-set! vect count (car lst)) + (apply tabulate (+ 1 count) (cdr lst))))))) + (apply tabulate 0 seeds)))) + + (define (vector-unfold-right f length . seeds) + (let ((seeds (if (null? seeds) '(0) seeds)) + (vect (make-vector length))) + (letrec ((tabulate + (lambda (count . args) + (if (< count 0) + vect + (receive lst (apply f count args) + (vector-set! vect count (car lst)) + (apply tabulate (- count 1) (cdr lst))))))) + (apply tabulate (- length 1) seeds)))) + + (define (vector-reverse-copy vec . rst) + (let* ((start (if (null? rst) 0 (car rst))) + (end (if (or (null? rst) (null? (cdr rst))) + (vector-length vec) + (cadr rst))) + (new-vect (make-vector (- end start)))) + (let loop ((i (- end 1)) (count 0)) + (if (< i start) + new-vect + (begin + (vector-set! new-vect count (vector-ref vec i)) + (loop (- i 1) (+ 1 count))))))) + + (define (vector-concatenate list-of-vectors) + (apply vector-append list-of-vectors)) + + + ;; # Predicates + (define (vector-empty? vec) + (zero? (vector-length vec))) + + ; for the symmetry, this should be rather 'vector=?' than 'vector='. + (define (vector= elt=? . vects) + (letrec ((2vector= + (lambda (v1 v2) + (let ((ln1 (vector-length v1))) + (and (= ln1 (vector-length v2)) + (let loop ((count 0)) + (if (= ln1 count) + #t + (and (elt=? (vector-ref v1 count) + (vector-ref v2 count)) + (loop (+ 1 count)))))))))) + (or (null? vects) + (let rec1 ((vect1 (car vects)) (others (cdr vects))) + (or (null? others) + (let ((vect2 (car others)) + (others (cdr others))) + (if (eq? vect1 vect2) + (rec1 vect1 others) + (and (2vector= vect1 vect2) + (rec1 vect2 others))))))))) + + + ;; # Iteration + (define (vector-fold kons knil vec . vects) + (let* ((vects (cons vec vects)) + (veclen (apply min (map vector-length vects)))) + (let rec ((acc knil) (count 0)) + (if (= count veclen) + acc + (rec (apply kons count acc + (map (lambda (v) (vector-ref v count)) vects)) + (+ 1 count)))))) + + (define (vector-fold-right kons knil vec . vects) + (let* ((vects (cons vec vects)) + (veclen (apply min (map vector-length vects)))) + (let rec ((acc knil) (count (- veclen 1))) + (if (< count 0) + acc + (rec (apply kons count acc + (map (lambda (v) (vector-ref v count)) vects)) + (- count 1)))))) + + (define (vector-map! f vec . vects) + (let* ((vects (cons vec vects)) + (veclen (apply min (map vector-length vects))) + (new-vect (make-vector veclen))) + (let rec ((count 0)) + (if (< count veclen) + (begin + (vector-set! vec count + (apply f (map (lambda (v) (vector-ref v count)) + vects))) + (rec (+ 1 count))))))) + + (define (vector-count pred? vec . vects) + (let* ((vects (cons vec vects)) + (veclen (apply min (map vector-length vects)))) + (let rec ((i 0) (count 0)) + (if (= i veclen) + count + (if (apply pred? count (map (lambda (v) (vector-ref v count)) vects)) + (rec (+ 1 i) (+ 1 count)) + (rec (+ 1 i) count)))))) + + ;; # Searching + (define (vector-index pred? vec . vects) + (let* ((vects (cons vec vects)) + (veclen (apply min (map vector-length vects)))) + (let rec ((count 0)) + (cond + ((= count veclen) #f) + ((apply pred? (map (lambda (v) (vector-ref v count)) vects)) + count) + (else (rec (+ 1 count))))))) + + (define (vector-index-right pred? vec . vects) + (let ((vects (cons vec vects)) + (veclen (vector-length vec))) + (let rec ((count (- veclen 1))) + (cond + ((< count 0) #f) + ((apply pred? (map (lambda (v) (vector-ref v count)) vects)) + count) + (else (rec (- count 1))))))) + + (define (vector-skip pred? vec . vects) + (apply vector-index (lambda args (not (apply pred? args))) vec vects)) + + (define (vector-skip-right pred? vec . vects) + (apply vector-index-right (lambda args (not (apply pred? args))) vec vects)) + + (define (vector-binary-search vec value cmp) + (let rec ((start 0) (end (vector-length vec)) (n -1)) + (let ((count (floor/ (+ start end) 2))) + (if (or (= start end) (= count n)) + #f + (let ((comparison (cmp (vector-ref vec count) value))) + (cond + ((zero? comparison) count) + ((positive? comparison) (rec start count count)) + (else (rec count end count)))))))) + + (define (vector-any pred? vec . vects) + (let* ((vects (cons vec vects)) + (veclen (vector-length vec))) + (let rec ((count 0)) + (if (= count veclen) + #f + (or (apply pred? (map (lambda (v) (vector-ref v count)) vects)) + (rec (+ 1 count))))))) + + (define (vector-every pred? vec . vects) + (let* ((vects (cons vec vects)) + (veclen (vector-length vec))) + (let rec ((count 0)) + (if (= count veclen) + #t + (and (apply pred? (map (lambda (v) (vector-ref v count)) vects)) + (rec (+ 1 count))))))) + + ;; # Mutators + (define (vector-swap! vec i j) + (let ((tmp (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j tmp))) + + (define (vector-reverse! vec . rst) + (let ((start (if (null? rst) 0 (car rst))) + (end (if (or (null? rst) (cdr rst)) + (vector-length vec) + (cadr rst)))) + (let rec ((i start) (j (- end 1))) + (if (< i j) + (begin + (vector-swap! vec i j) + (rec (+ 1 i) (- j 1))))))) + + (define (vector-reverse-copy! target tstart source . rst) + (let ((sstart (if (null? rst) 0 (car rst))) + (send (if (or (null? rst) (cdr rst)) + (vector-length source) + (cadr rst)))) + (let rec ((i tstart) (j (- send 1))) + (if (>= j sstart) + (begin + (vector-set! target i (vector-ref source j)) + (rec (+ 1 i) (- j 1))))))) + + ;; # Conversion + (define (reverse-vector->list vec . rst) + (let ((start (if (null? rst) 0 (car rst))) + (end (if (or (null? rst) (cdr rst)) + (vector-length vec) + (cadr rst)))) + (let rec ((i start) (acc '())) + (if (= i end) + acc + (rec (+ 1 i) (cons (vector-ref vec i) acc)))))) + + (define (reverse-list->vector proper-list) + (apply vector (reverse proper-list))) + + (export vector? + make-vector + vector + vector-length + vector-ref + vector-set! + vector->list + list->vector + vector-fill! + vector-copy! + + vector-unfold + vector-unfold-right + vector-reverse-copy + vector-concatenate + vector-empty? + vector= + vector-fold + vector-fold-right + vector-map! + vector-count + vector-index + vector-index-right + vector-skip + vector-skip-right + vector-binary-search + vector-any + vector-every + vector-swap! + vector-reverse! + vector-reverse-copy! + reverse-vector->list + reverse-list->vector)) From 7ce095b7ae78f4386585dfd03ecefc2aa56914f9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 21 Jun 2014 11:07:48 +0900 Subject: [PATCH 007/200] update deploy.rst --- README.md | 2 ++ docs/deploy.rst | 2 ++ 2 files changed, 4 insertions(+) diff --git a/README.md b/README.md index 9c61e195..9828c113 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,8 @@ Change directory to `build` then run `ccmake` to create Makefile. Once `Makefile Actually you don't necessarily need to move to `build` directory before running `ccmake` (in that case `$ ccmake .`), but I strongly recommend to follow above instruction. +Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled. + ### Build A built executable binary will be under bin/ directory and shared libraries under lib/. diff --git a/docs/deploy.rst b/docs/deploy.rst index 2268ad01..3c8b9ceb 100644 --- a/docs/deploy.rst +++ b/docs/deploy.rst @@ -25,6 +25,8 @@ Change directory to `build` then run `ccmake` to create Makefile. Once `Makefile Actually you don't necessarily need to move to `build` directory before running `ccmake` (in that case `$ ccmake .`), but I strongly recommend to follow above instruction. +Before generating Makefile, you can change some compilation switches to enable or disable optional features. Take *NAN_BOXING* for example, when you turn on "Use C11 feature" flag and the platform supports addresses of 48bit length, it is enabled. + Build ^^^^^ From 447a05f7c3f5bd451dd553003d99a354ed4e2867 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 21 Jun 2014 12:00:50 +0900 Subject: [PATCH 008/200] add C API documentation --- docs/capi.rst | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++ docs/index.rst | 1 + 2 files changed, 97 insertions(+) create mode 100644 docs/capi.rst diff --git a/docs/capi.rst b/docs/capi.rst new file mode 100644 index 00000000..b2e3ad0f --- /dev/null +++ b/docs/capi.rst @@ -0,0 +1,96 @@ +C API +===== + +You can write Picrin's extension by yourself from both sides of C and Scheme. This page describes the way to control the interpreter from the C world. + +Extension Library +----------------- + +If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library. + +* contrib/add/CMakeLists.txt:: + + list(APPEND PICRIN_CONTRIB_INITS "void pic_init_add(pic_state *)\; pic_init_add(pic)\;") + list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c) + +* contrib/add/add.c:: + + #include "picrin.h" + + static pic_value + pic_add(pic_state *pic) + { + double a, b; + + pic_get_args(pic, "ff", &a, &b); + + return pic_float_value(a + b); + } + + void + pic_init_add(pic_state *pic) + { + pic_deflibrary ("(picrin add)") { + pic_defun(pic, "add", pic_add); + } + } + +After recompiling the interpreter, the library "(picrin add)" is available in the REPL, which library provides a funciton "add". + +User-data vs GC +^^^^^^^^^^^^^^^ + +When you use dynamic memory allocation inside C APIs, you must be caseful about Picrin's GC. Fortunately, we provides a set of wrapper functions for complete abstraction of GC. In the case below, the memory (de)allocators *create_foo* and *finalize_foo* are wrapped in pic_data object, so that when an instance of foo losts all references from others to it picrin can automatically finalize the orphan object:: + + /** foo.c **/ + #include + #include "picrin.h" + #include "picrin/data.h" + + /* + * C-side API + */ + + struct foo { + // blah blah blah + }; + + struct foo * + create_foo () + { + return malloc(sizeof(struct foo)); + } + + void + finalize_foo (void *foo) { + struct foo *f = foo; + free(f); + } + + + /* + * picrin-side FFI interface + */ + + static const pic_data_type foo_type = { "foo", finalize_foo }; + + static pic_value + pic_create_foo(pic_state *pic) + { + struct foo *f; + struct pic_data *dat; + + pic_get_args(pic, ""); // no args here + + f = create_foo(); + + data = pic_data_alloc(pic, &f, md); + + return pic_obj_value(data); + } + + void + pic_init_my_data(pic_state *pic) + { + pic_defun(pic, "create-my-data", pic_create_foo); // (create-foo) + } diff --git a/docs/index.rst b/docs/index.rst index 0b1a4491..5c620a0d 100644 --- a/docs/index.rst +++ b/docs/index.rst @@ -15,6 +15,7 @@ Contents: deploy.rst lang.rst libs.rst + capi.rst Indices and tables ================== From fa1da645c83058aba833570938bcf12ebda25668 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 21 Jun 2014 12:03:40 +0900 Subject: [PATCH 009/200] use sourcecode directive --- docs/capi.rst | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/docs/capi.rst b/docs/capi.rst index b2e3ad0f..3f932938 100644 --- a/docs/capi.rst +++ b/docs/capi.rst @@ -8,12 +8,16 @@ Extension Library If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library. -* contrib/add/CMakeLists.txt:: +* contrib/add/CMakeLists.txt + +.. sourcecode:: cmake list(APPEND PICRIN_CONTRIB_INITS "void pic_init_add(pic_state *)\; pic_init_add(pic)\;") list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c) -* contrib/add/add.c:: +* contrib/add/add.c + +.. sourcecode:: c #include "picrin.h" @@ -40,7 +44,9 @@ After recompiling the interpreter, the library "(picrin add)" is available in th User-data vs GC ^^^^^^^^^^^^^^^ -When you use dynamic memory allocation inside C APIs, you must be caseful about Picrin's GC. Fortunately, we provides a set of wrapper functions for complete abstraction of GC. In the case below, the memory (de)allocators *create_foo* and *finalize_foo* are wrapped in pic_data object, so that when an instance of foo losts all references from others to it picrin can automatically finalize the orphan object:: +When you use dynamic memory allocation inside C APIs, you must be caseful about Picrin's GC. Fortunately, we provides a set of wrapper functions for complete abstraction of GC. In the case below, the memory (de)allocators *create_foo* and *finalize_foo* are wrapped in pic_data object, so that when an instance of foo losts all references from others to it picrin can automatically finalize the orphan object. + +.. sourcecode:: c /** foo.c **/ #include @@ -94,3 +100,4 @@ When you use dynamic memory allocation inside C APIs, you must be caseful about { pic_defun(pic, "create-my-data", pic_create_foo); // (create-foo) } + From 17520df61c63626269337d70bba4c2a085f922be Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 21 Jun 2014 12:05:48 +0900 Subject: [PATCH 010/200] fix a bug in sample code --- docs/capi.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/capi.rst b/docs/capi.rst index 3f932938..f25a7f05 100644 --- a/docs/capi.rst +++ b/docs/capi.rst @@ -90,7 +90,7 @@ When you use dynamic memory allocation inside C APIs, you must be caseful about f = create_foo(); - data = pic_data_alloc(pic, &f, md); + data = pic_data_alloc(pic, &foo_type, md); return pic_obj_value(data); } From 4c38383d9bf95a9d451ac14431da5bcd16a9101d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 21 Jun 2014 12:06:28 +0900 Subject: [PATCH 011/200] renames were incomplete --- docs/capi.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/capi.rst b/docs/capi.rst index f25a7f05..c8840573 100644 --- a/docs/capi.rst +++ b/docs/capi.rst @@ -96,8 +96,8 @@ When you use dynamic memory allocation inside C APIs, you must be caseful about } void - pic_init_my_data(pic_state *pic) + pic_init_foo(pic_state *pic) { - pic_defun(pic, "create-my-data", pic_create_foo); // (create-foo) + pic_defun(pic, "create-foo", pic_create_foo); // (create-foo) } From 04d080ac733e7aa5205193199ebaa7ceb2e25e1e Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Sun, 22 Jun 2014 16:49:59 +0900 Subject: [PATCH 012/200] import chibi scheme's test --- t/r7rs-tests.scm | 2242 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2242 insertions(+) create mode 100644 t/r7rs-tests.scm diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm new file mode 100644 index 00000000..be54d4aa --- /dev/null +++ b/t/r7rs-tests.scm @@ -0,0 +1,2242 @@ +;; -*- coding: utf-8 -*- + +(import (scheme base) +; (scheme char) + (scheme lazy) + (scheme inexact) +; (scheme complex) + (scheme time) + (scheme file) +; (scheme read) + (scheme write) +; (scheme eval) + (scheme process-context) +; (scheme case-lambda) + ) + +;; R7RS test suite. Covers all procedures and syntax in the small +;; language except `delete-file'. Currently assumes full-unicode +;; support, the full numeric tower and all standard libraries +;; provided. +;; +;; Uses the (chibi test) library which is written in portable R7RS. +;; This is mostly a subset of SRFI-64, providing test-begin, test-end +;; and test, which could be defined as something like: +;; +(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)))))) +;; +;; however (chibi test) provides nicer output, timings, and +;; approximate equivalence for floating point numbers. + +(newline) + +(test-begin "R7RS") + +(test-begin "4.1 Primitive expression types") + +(let () + (define x 28) + (test 28 x)) + +(test 'a (quote a)) +(test #(a b c) (quote #(a b c))) +(test '(+ 1 2) (quote (+ 1 2))) + +(test 'a 'a) +(test #(a b c) '#(a b c)) +(test '() '()) +(test '(+ 1 2) '(+ 1 2)) +(test '(quote a) '(quote a)) +(test '(quote a) ''a) + +(test "abc" '"abc") +(test "abc" "abc") +(test 145932 '145932) +(test 145932 145932) +(test #t '#t) +(test #t #t) + +(test 7 (+ 3 4)) +(test 12 ((if #f + *) 3 4)) + +(test 8 ((lambda (x) (+ x x)) 4)) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 (reverse-subtract 7 10)) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 (add4 6)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) +(test '(5 6) ((lambda (x y . z) z) + 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) +(test 'no (if (> 2 3) 'yes 'no)) +(test 1 (if (> 3 2) + (- 3 2) + (+ 3 2))) +(let () + (define x 2) + (test 3 (+ x 1))) + +(test-end) + +(test-begin "4.2 Derived expression types") + +(test 'greater + (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) + +(test 'equal + (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) + +(test 2 + (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) + +(test 'composite + (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) + +(test 'c + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else => (lambda (x) x)))) + +(test '((other . z) (semivowel . y) (other . x) + (semivowel . w) (vowel . u)) + (map (lambda (x) + (case x + ((a e i o u) => (lambda (w) (cons 'vowel w))) + ((w y) (cons 'semivowel x)) + (else => (lambda (w) (cons 'other w))))) + '(z y x w u))) + +(test #t (and (= 2 2) (> 2 1))) +(test #f (and (= 2 2) (< 2 1))) +(test '(f g) (and 1 2 'c '(f g))) +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) +(test #t (or (= 2 2) (< 2 1))) +(test #f (or #f #f #f)) +(test '(b c) (or (memq 'b '(a b c)) + (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) + (* x y))) + +(test 35 (let ((x 2) (y 3)) + (let ((x 7) + (z (+ x y))) + (* z x)))) + +(test 70 (let ((x 2) (y 3)) + (let* ((x 7) + (z (+ x y))) + (* z x)))) + +(test #t + (letrec ((even? + (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 88))) + +(test 5 + (letrec* ((p + (lambda (x) + (+ 1 (q (- x 1))))) + (q + (lambda (y) + (if (zero? y) + 0 + (+ 1 (p (- y 1)))))) + (x (p 5)) + (y x)) + y)) + +;; By Jussi Piitulainen +;; and John Cowan : +;; http://lists.scheme-reports.org/pipermail/scheme-reports/2013-December/003876.html + +(define (means ton) + (letrec* + ((mean + (lambda (f g) + (f (/ (sum g ton) n)))) + (sum + (lambda (g ton) + (if (null? ton) + (+) + (if (number? ton) + (g ton) + (+ (sum g (car ton)) + (sum g (cdr ton))))))) + (n (sum (lambda (x) 1) ton))) + (values (mean values values) + (mean exp log) + (mean / /)))) +(let*-values (((a b c) (means '(8 5 99 1 22)))) + (test 27 a) + (test 9.728 b) + (test (/ 1800 497) c)) + +(let*-values (((root rem) (exact-integer-sqrt 32))) + (test 35 (* root rem))) + +(test '(1073741824 0) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 60)))) + (list root rem))) + +(test '(1518500249 3000631951) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 61)))) + (list root rem))) + +(test '(815238614083298888 443242361398135744) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 119)))) + (list root rem))) + +(test '(1152921504606846976 0) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 120)))) + (list root rem))) + +(test '(1630477228166597776 1772969445592542976) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 121)))) + (list root rem))) + +(test '(31622776601683793319 62545769258890964239) + (let*-values (((root rem) (exact-integer-sqrt (expt 10 39)))) + (list root rem))) + +(let*-values (((root rem) (exact-integer-sqrt (expt 2 140)))) + (test 0 rem) + (test (expt 2 140) (square root))) + +(test '(x y x y) (let ((a 'a) (b 'b) (x 'x) (y 'y)) + (let*-values (((a b) (values x y)) + ((x y) (values a b))) + (list a b x y)))) + +(let () + (define x 0) + (set! x 5) + (test 6 (+ x 1))) + +(test #(0 1 2 3 4) (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg)) + ((< (car numbers) 0) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg)))))) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) + (let ((p (delay (+ 1 2)))) + (list (force p) (force p)))) + +(define integers + (letrec ((next + (lambda (n) + (delay (cons n (next (+ n 1))))))) + (next 0))) +(define head + (lambda (stream) (car (force stream)))) +(define tail + (lambda (stream) (cdr (force stream)))) + +(test 2 (head (tail (tail integers)))) + +(define (stream-filter p? s) + (delay-force + (if (null? (force s)) + (delay '()) + (let ((h (car (force s))) + (t (cdr (force s)))) + (if (p? h) + (delay (cons h (stream-filter p? t))) + (stream-filter p? t)))))) + +(test 5 (head (tail (tail (stream-filter odd? integers))))) + +(let () + (define x 5) + (define count 0) + (define p + (delay (begin (set! count (+ count 1)) + (if (> count x) + count + (force p))))) + (test 6 (force p)) + (test 6 (begin (set! x 10) (force p)))) + +(test #t (promise? (delay (+ 2 2)))) +(test #t (promise? (make-promise (+ 2 2)))) +(test #t + (let ((x (delay (+ 2 2)))) + (force x) + (promise? x))) + +(test #t + (let ((x (make-promise (+ 2 2)))) + (force x) + (promise? x))) + + + + +;; (define radix +;; (make-parameter +;; 10 +;; (lambda (x) +;; (if (and (integer? x) (<= 2 x 16)) +;; x +;; (error "invalid radix"))))) +;; (define (f n) (number->string n (radix))) +;; (test "12" (f 12)) +;; (test "1100" (parameterize ((radix 2)) +;; (f 12))) +;; (test "12" (f 12)) +(test '(list 3 4) `(list ,(+ 1 2) 4)) +(let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test #(10 5 4 16 9 8) + `#(10 5 ,(square 2) ,@(map square '(4 3)) 8)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) ) +(let ((name1 'x) + (name2 'y)) + (test '(a `(b ,x ,'y d) e) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) +(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) + +;; (define plus +;; (case-lambda +;; (() 0) +;; ((x) x) +;; ((x y) (+ x y)) +;; ((x y z) (+ (+ x y) z)) +;; (args (apply + args)))) + +;; (test 0 (plus)) +;; (test 1 (plus 1)) +;; (test 3 (plus 1 2)) +;; (test 6 (plus 1 2 3)) +;; (test 10 (plus 1 2 3 4)) + +;; (define mult +;; (case-lambda +;; (() 1) +;; ((x) x) +;; ((x y) (* x y)) +;; ((x y . z) (apply mult (* x y) z)))) + +;; (test 1 (mult)) +;; (test 1 (mult 1)) +;; (test 2 (mult 1 2)) +;; (test 6 (mult 1 2 3)) +;; (test 24 (mult 1 2 3 4)) + +(test-end) + +(test-begin "4.3 Macros") + +;; (test 'now (let-syntax +;; ((when (syntax-rules () +;; ((when test stmt1 stmt2 ...) +;; (if test +;; (begin stmt1 +;; stmt2 ...)))))) +;; (let ((if #t)) +;; (when if (set! if 'now)) +;; if))) + +;; (test 'outer (let ((x 'outer)) +;; (let-syntax ((m (syntax-rules () ((m) x)))) +;; (let ((x 'inner)) +;; (m))))) + +;; (test 7 (letrec-syntax +;; ((my-or (syntax-rules () +;; ((my-or) #f) +;; ((my-or e) e) +;; ((my-or e1 e2 ...) +;; (let ((temp e1)) +;; (if temp +;; temp +;; (my-or e2 ...))))))) +;; (let ((x #f) +;; (y 7) +;; (temp 8) +;; (let odd?) +;; (if even?)) +;; (my-or x +;; (let temp) +;; (if y) +;; y)))) + +(define-syntax be-like-begin + (syntax-rules () + ((be-like-begin name) + (define-syntax name + (syntax-rules () + ((name expr (... ...)) + (begin expr (... ...)))))))) +(be-like-begin sequence) +(test 4 (sequence 1 2 3 4)) + +(define-syntax jabberwocky + (syntax-rules () + ((_ hatter) + (begin + (define march-hare 42) + (define-syntax hatter + (syntax-rules () + ((_) march-hare))))))) +(jabberwocky mad-hatter) +(test 42 (mad-hatter)) + +(test 'ok (let ((=> #f)) (cond (#t => 'ok)))) + +(test-end) + +(test-begin "5 Program structure") + +(define add3 + (lambda (x) (+ x 3))) +(test 6 (add3 3)) +(define first car) +(test 1 (first '(1 2))) + +;; (test 45 (let ((x 5)) +;; (define foo (lambda (y) (bar x y))) +;; (define bar (lambda (a b) (+ (* a b) a))) +;; (foo (+ x 3)))) + +(test 'ok + (let () + (define-values () (values)) + 'ok)) +(test 1 + (let () + (define-values (x) (values 1)) + x)) +;; (test 3 +;; (let () +;; (define-values x (values 1 2)) +;; (apply + x))) +(test 3 + (let () + (define-values (x y) (values 1 2)) + (+ x y))) +(test 6 + (let () + (define-values (x y z) (values 1 2 3)) + (+ x y z))) +;; (test 10 +;; (let () +;; (define-values (x y . z) (values 1 2 3 4)) +;; (+ x y (car z) (cadr z)))) + +(test '(2 1) (let ((x 1) (y 2)) + (define-syntax swap! + (syntax-rules () + ((swap! a b) + (let ((tmp a)) + (set! a b) + (set! b tmp))))) + (swap! x y) + (list x y))) + +;; Records + +(define-record-type + (kons x y) + pare? + (x kar set-kar!) + (y kdr)) + +(test #t (pare? (kons 1 2))) +(test #f (pare? (cons 1 2))) +(test 1 (kar (kons 1 2))) +(test 2 (kdr (kons 1 2))) +(test 3 (let ((k (kons 1 2))) + (set-kar! k 3) + (kar k))) + +(test-end) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 6 Standard Procedures + +(test-begin "6.1 Equivalence Predicates") + +(test #t (eqv? 'a 'a)) +(test #f (eqv? 'a 'b)) +(test #t (eqv? 2 2)) +(test #t (eqv? '() '())) +(test #t (eqv? 100000000 100000000)) +(test #f (eqv? (cons 1 2) (cons 1 2))) +(test #f (eqv? (lambda () 1) + (lambda () 2))) +(test #f (eqv? #f 'nil)) + +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(test #t + (let ((g (gen-counter))) + (eqv? g g))) +(test #f (eqv? (gen-counter) (gen-counter))) +(define gen-loser + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) 27)))) +(test #t (let ((g (gen-loser))) + (eqv? g g))) + +(test #f +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (eqv? f g))) + +(test #t + (let ((x '(a))) + (eqv? x x))) + +(test #t (eq? 'a 'a)) +(test #f (eq? (list 'a) (list 'a))) +(test #t (eq? '() '())) +(test #t + (let ((x '(a))) + (eq? x x))) +(test #t + (let ((x '#())) + (eq? x x))) +(test #t + (let ((p (lambda (x) x))) + (eq? p p))) + +(test #t (equal? 'a 'a)) +(test #t (equal? '(a) '(a))) +(test #t (equal? '(a (b) c) + '(a (b) c))) +(test #t (equal? "abc" "abc")) +(test #t (equal? 2 2)) +(test #t (equal? (make-vector 5 'a) + (make-vector 5 'a))) + +(test-end) + +(test-begin "6.2 Numbers") + +;; (test #t (complex? 3+4i)) +(test #t (complex? 3)) +(test #t (real? 3)) +;; (test #t (real? -2.5+0i)) +;; (test #f (real? -2.5+0.0i)) +;; (test #t (real? #e1e10)) +(test #t (real? +inf.0)) +(test #f (rational? -inf.0)) +;; (test #t (rational? 6/10)) +;; (test #t (rational? 6/3)) +;; (test #t (integer? 3+0i)) +(test #t (integer? 3.0)) +;; (test #t (integer? 8/4)) + +(test #f (exact? 3.0)) +;; (test #t (exact? #e3.0)) +;; (test #t (inexact? 3.)) + +(test #t (exact-integer? 32)) +(test #f (exact-integer? 32.0)) +;; (test #f (exact-integer? 32/5)) + +(test #t (finite? 3)) +(test #f (finite? +inf.0)) +;; (test #f (finite? 3.0+inf.0i)) + +(test #f (infinite? 3)) +(test #t (infinite? +inf.0)) +(test #f (infinite? +nan.0)) +;; (test #t (infinite? 3.0+inf.0i)) + +(test #t (nan? +nan.0)) +(test #f (nan? 32)) +;; (test #t (nan? +nan.0+5.0i)) +;; (test #f (nan? 1+2i)) + +;; (test #t (= 1 1.0 1.0+0.0i)) +;; (test #f (= 1.0 1.0+1.0i)) +;; (test #t (< 1 2 3)) +;; (test #f (< 1 1 2)) +;; (test #t (> 3.0 2.0 1.0)) +;; (test #f (> -3.0 2.0 1.0)) +;; (test #t (<= 1 1 2)) +;; (test #f (<= 1 2 1)) +;; (test #t (>= 2 1 1)) +;; (test #f (>= 1 2 1)) + +;; From R7RS 6.2.6 Numerical operations: +;; +;; These predicates are required to be transitive. +;; +;; _Note:_ The traditional implementations of these predicates in +;; Lisp-like languages, which involve converting all arguments to inexact +;; numbers if any argument is inexact, are not transitive. + +;; Example from Alan Bawden +(let ((a (- (expt 2 1000) 1)) + (b (inexact (expt 2 1000))) ; assuming > single-float-epsilon + (c (+ (expt 2 1000) 1))) + (test #t (if (and (= a b) (= b c)) + (= a c) + #t))) + +;; From CLtL 12.3. Comparisons on Numbers: +;; +;; Let _a_ be the result of (/ 10.0 single-float-epsilon), and let +;; _j_ be the result of (floor a). ..., all of (<= a j), (< j (+ j +;; 1)), and (<= (+ j 1) a) would be true; transitivity would then +;; imply that (< a a) ought to be true ... + +;; Transliteration from Jussi Piitulainen +(define single-float-epsilon + (do ((eps 1.0 (* eps 2.0))) + ((= eps (+ eps 1.0)) eps))) + +(let* ((a (/ 10.0 single-float-epsilon)) + (j (exact a))) + (test #t (if (and (<= a j) (< j (+ j 1))) + (not (<= (+ j 1) a)) + #t))) + +(test #t (zero? 0)) +(test #t (zero? 0.0)) +;; (test #t (zero? 0.0+0.0i)) +(test #f (zero? 1)) +(test #f (zero? -1)) + +(test #f (positive? 0)) +(test #f (positive? 0.0)) +(test #t (positive? 1)) +(test #t (positive? 1.0)) +(test #f (positive? -1)) +(test #f (positive? -1.0)) +(test #t (positive? +inf.0)) +(test #f (positive? -inf.0)) + +(test #f (negative? 0)) +(test #f (negative? 0.0)) +(test #f (negative? 1)) +(test #f (negative? 1.0)) +(test #t (negative? -1)) +(test #t (negative? -1.0)) +(test #f (negative? +inf.0)) +(test #t (negative? -inf.0)) + +(test #f (odd? 0)) +(test #t (odd? 1)) +(test #t (odd? -1)) +(test #f (odd? 102)) + +(test #t (even? 0)) +(test #f (even? 1)) +(test #t (even? -2)) +(test #t (even? 102)) + +(test 3 (max 3)) +(test 4 (max 3 4)) +(test 4.0 (max 3.9 4)) +(test 5.0 (max 5 3.9 4)) +(test +inf.0 (max 100 +inf.0)) +(test 3 (min 3)) +(test 3 (min 3 4)) +(test 3.0 (min 3 3.1)) +(test -inf.0 (min -inf.0 -100)) + +(test 7 (+ 3 4)) +(test 3 (+ 3)) +(test 0 (+)) +(test 4 (* 4)) +(test 1 (*)) + +(test -1 (- 3 4)) +(test -6 (- 3 4 5)) +(test -3 (- 3)) +;; (test 3/20 (/ 3 4 5)) +;; (test 1/3 (/ 3)) + +(test 7 (abs -7)) +(test 7 (abs 7)) + +;; (test-values (values 2 1) (floor/ 5 2)) +;; (test-values (values -3 1) (floor/ -5 2)) +;; (test-values (values -3 -1) (floor/ 5 -2)) +;; (test-values (values 2 -1) (floor/ -5 -2)) +;; (test-values (values 2 1) (truncate/ 5 2)) +;; (test-values (values -2 -1) (truncate/ -5 2)) +;; (test-values (values -2 1) (truncate/ 5 -2)) +;; (test-values (values 2 -1) (truncate/ -5 -2)) +;; (test-values (values 2.0 -1.0) (truncate/ -5.0 -2)) + +(test 1 (modulo 13 4)) +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) +(test -1 (remainder -13 -4)) + +(test -1.0 (remainder -13 -4.0)) + +(test 4 (gcd 32 -36)) +(test 0 (gcd)) +(test 288 (lcm 32 -36)) +(test 288.0 (lcm 32.0 -36)) +(test 1 (lcm)) + +;; (test 3 (numerator (/ 6 4))) +;; (test 2 (denominator (/ 6 4))) +;; (test 2.0 (denominator (inexact (/ 6 4)))) +;; (test 11.0 (numerator 5.5)) +;; (test 2.0 (denominator 5.5)) +;; (test 5.0 (numerator 5.0)) +;; (test 1.0 (denominator 5.0)) + +(test -5.0 (floor -4.3)) +(test -4.0 (ceiling -4.3)) +(test -4.0 (truncate -4.3)) +(test -4.0 (round -4.3)) + +(test 3.0 (floor 3.5)) +(test 4.0 (ceiling 3.5)) +(test 3.0 (truncate 3.5)) +(test 4.0 (round 3.5)) + +;; (test 4 (round 7/2)) +(test 7 (round 7)) + +;; (test 1/3 (rationalize (exact .3) 1/10)) +;; (test #i1/3 (rationalize .3 1/10)) + +(test 1.0 (inexact (exp 0))) ;; may return exact number +(test 20.0855369231877 (exp 3)) + +(test 0.0 (inexact (log 1))) ;; may return exact number +(test 1.0 (log (exp 1))) +(test 42.0 (log (exp 42))) +(test 2.0 (log 100 10)) +(test 12.0 (log 4096 2)) + +(test 0.0 (inexact (sin 0))) ;; may return exact number +(test 1.0 (sin 1.5707963267949)) +(test 1.0 (inexact (cos 0))) ;; may return exact number +(test -1.0 (cos 3.14159265358979)) +(test 0.0 (inexact (tan 0))) ;; may return exact number +(test 1.5574077246549 (tan 1)) + +(test 0.0 (asin 0)) +(test 1.5707963267949 (asin 1)) +(test 0.0 (acos 1)) +(test 3.14159265358979 (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 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 0.0+1.0i (inexact (sqrt -1))) + +(test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list)) +(test '(2 1) (call-with-values (lambda () (exact-integer-sqrt 5)) list)) + +(test 27 (expt 3 3)) +(test 1 (expt 0 0)) +(test 0 (expt 0 1)) +(test 1.0 (expt 0.0 0)) +(test 0.0 (expt 0 1.0)) + +;; (test 1+2i (make-rectangular 1 2)) + +;; (test 0.54030230586814+0.841470984807897i (make-polar 1 1)) + +;; (test 1 (real-part 1+2i)) + +;; (test 2 (imag-part 1+2i)) + +;; (test 2.23606797749979 (magnitude 1+2i)) + +;; (test 1.10714871779409 (angle 1+2i)) + +(test 1.0 (inexact 1)) +(test #t (inexact? (inexact 1))) +(test 1 (exact 1.0)) +(test #t (exact? (exact 1.0))) + +(test 100 (string->number "100")) +(test 256 (string->number "100" 16)) +(test 100.0 (string->number "1e2")) + +(test-end) + +(test-begin "6.3 Booleans") + +(test #t #t) +(test #f #f) +(test #f '#f) + +(test #f (not #t)) +(test #f (not 3)) +(test #f (not (list 3))) +(test #t (not #f)) +(test #f (not '())) +(test #f (not (list))) +(test #f (not 'nil)) + +(test #t (boolean? #f)) +(test #f (boolean? 0)) +(test #f (boolean? '())) + +(test #t (boolean=? #t #t)) +(test #t (boolean=? #f #f)) +(test #f (boolean=? #t #f)) +(test #t (boolean=? #f #f #f)) +(test #f (boolean=? #t #t #f)) + +(test-end) + +(test-begin "6.4 Lists") + +(let* ((x (list 'a 'b 'c)) + (y x)) + (test '(a b c) (values y)) + (test #t (list? y)) + (set-cdr! x 4) + (test '(a . 4) (values x)) + (test #t (eqv? x y)) + (test #f (list? y)) + (set-cdr! x x) + (test #f (list? x))) + +(test #t (pair? '(a . b))) +(test #t (pair? '(a b c))) +(test #f (pair? '())) +(test #f (pair? '#(a b))) + +(test '(a) (cons 'a '())) +(test '((a) b c d) (cons '(a) '(b c d))) +(test '("a" b c) (cons "a" '(b c))) +(test '(a . 3) (cons 'a 3)) +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) +(test '(a) (car '((a) b c d))) +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) +(test 2 (cdr '(1 . 2))) +(define (g) '(constant-list)) + +(test #t (list? '(a b c))) +(test #t (list? '())) +(test #f (list? '(a . b))) +(test #f (let ((x (list 'a))) (set-cdr! x x) (list? x))) + +(test '(3 3) (make-list 2 3)) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) +(test '() (list)) + +(test 3 (length '(a b c))) +(test 3 (length '(a (b) (c d e)))) +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) +(test '(a b c d) (append '(a) '(b c d))) +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test '(d e) (list-tail '(a b c d e) 3)) + +(test 'c (list-ref '(a b c d) 2)) +(test 'c (list-ref '(a b c d) + (exact (round 1.8)))) + +(test '(0 ("Sue" "Sue") "Anna") + (let ((lst (list 0 '(2 2 2 2) "Anna"))) + (list-set! lst 1 '("Sue" "Sue")) + lst)) + +(test '(a b c) (memq 'a '(a b c))) +(test '(b c) (memq 'b '(a b c))) +(test #f (memq 'a '(b c d))) +(test #f (memq (list 'a) '(b (a) c))) +(test '((a) c) (member (list 'a) '(b (a) c))) +;; (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?)) +(test '(101 102) (memv 101 '(100 101 102))) + +(let () + (define e '((a 1) (b 2) (c 3))) + (test '(a 1) (assq 'a e)) + (test '(b 2) (assq 'b e)) + (test #f (assq 'd e))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) +(test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =)) +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test '(1 2 3) (list-copy '(1 2 3))) +(test "foo" (list-copy "foo")) +(test '() (list-copy '())) +(test '(3 . 4) (list-copy '(3 . 4))) +(test '(6 7 8 . 9) (list-copy '(6 7 8 . 9))) +(let* ((l1 '((a b) (c d) e)) + (l2 (list-copy l1))) + (test l2 '((a b) (c d) e)) + (test #t (eq? (car l1) (car l2))) + (test #t (eq? (cadr l1) (cadr l2))) + (test #f (eq? (cdr l1) (cdr l2))) + (test #f (eq? (cddr l1) (cddr l2)))) + +(test-end) + +(test-begin "6.5 Symbols") + +(test #t (symbol? 'foo)) +(test #t (symbol? (car '(a b)))) +(test #f (symbol? "bar")) +(test #t (symbol? 'nil)) +(test #f (symbol? '())) +(test #f (symbol? #f)) + +(test #t (symbol=? 'a 'a)) +(test #f (symbol=? 'a 'A)) +(test #t (symbol=? 'a 'a 'a)) +(test #f (symbol=? 'a 'a 'A)) + +(test "flying-fish" +(symbol->string 'flying-fish)) +(test "Martin" (symbol->string 'Martin)) +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test 'mISSISSIppi (string->symbol "mISSISSIppi")) +(test #t (eq? 'bitBlt (string->symbol "bitBlt"))) +(test #t (eq? 'LollyPop (string->symbol (symbol->string 'LollyPop)))) +(test #t (string=? "K. Harper, M.D." + (symbol->string (string->symbol "K. Harper, M.D.")))) + +(test-end) + +(test-begin "6.6 Characters") + +(test #t (char? #\a)) +(test #f (char? "a")) +(test #f (char? 'a)) +(test #f (char? 0)) + +(test #t (char=? #\a #\a #\a)) +(test #f (char=? #\a #\A)) +(test #t (char? #\a #\b)) +(test #f (char>? #\a #\a)) +(test #t (char>? #\c #\b #\a)) +(test #t (char<=? #\a #\b #\b)) +(test #t (char<=? #\a #\a)) +(test #f (char<=? #\b #\a)) +(test #f (char>=? #\a #\b)) +(test #t (char>=? #\a #\a)) +(test #t (char>=? #\b #\b #\a)) + +;; (test #t (char-ci=? #\a #\a)) +;; (test #t (char-ci=? #\a #\A #\a)) +;; (test #f (char-ci=? #\a #\b)) +;; (test #t (char-ci? #\A #\b)) +;; (test #f (char-ci>? #\a #\A)) +;; (test #t (char-ci>? #\c #\B #\a)) +;; (test #t (char-ci<=? #\a #\B #\b)) +;; (test #t (char-ci<=? #\A #\a)) +;; (test #f (char-ci<=? #\b #\A)) +;; (test #f (char-ci>=? #\A #\b)) +;; (test #t (char-ci>=? #\a #\A)) +;; (test #t (char-ci>=? #\b #\B #\a)) + +;; (test #t (char-alphabetic? #\a)) +;; (test #f (char-alphabetic? #\space)) +;; (test #t (char-numeric? #\0)) +;; (test #f (char-numeric? #\.)) +;; (test #f (char-numeric? #\a)) +;; (test #t (char-whitespace? #\space)) +;; (test #t (char-whitespace? #\tab)) +;; (test #t (char-whitespace? #\newline)) +;; (test #f (char-whitespace? #\_)) +;; (test #f (char-whitespace? #\a)) +;; (test #t (char-upper-case? #\A)) +;; (test #f (char-upper-case? #\a)) +;; (test #f (char-upper-case? #\3)) +;; (test #t (char-lower-case? #\a)) +;; (test #f (char-lower-case? #\A)) +;; (test #f (char-lower-case? #\3)) + +;; (test #t (char-alphabetic? #\Λ)) +;; (test #f (char-alphabetic? #\x0E50)) +;; (test #t (char-upper-case? #\Λ)) +;; (test #f (char-upper-case? #\λ)) +;; (test #f (char-lower-case? #\Λ)) +;; (test #t (char-lower-case? #\λ)) +;; (test #f (char-numeric? #\Λ)) +;; (test #t (char-numeric? #\x0E50)) +;; (test #t (char-whitespace? #\x1680)) + +;; (test 0 (digit-value #\0)) +;; (test 3 (digit-value #\3)) +;; (test 9 (digit-value #\9)) +;; (test 4 (digit-value #\x0664)) +;; (test 0 (digit-value #\x0AE6)) +;; (test #f (digit-value #\.)) +;; (test #f (digit-value #\-)) + +(test 97 (char->integer #\a)) +(test #\a (integer->char 97)) + +;; (test #\A (char-upcase #\a)) +;; (test #\A (char-upcase #\A)) +;; (test #\a (char-downcase #\a)) +;; (test #\a (char-downcase #\A)) +;; (test #\a (char-foldcase #\a)) +;; (test #\a (char-foldcase #\A)) + +;; (test #\Λ (char-upcase #\λ)) +;; (test #\Λ (char-upcase #\Λ)) +;; (test #\λ (char-downcase #\λ)) +;; (test #\λ (char-downcase #\Λ)) +;; (test #\λ (char-foldcase #\λ)) +;; (test #\λ (char-foldcase #\Λ)) + +(test-end) + +(test-begin "6.7 Strings") + +(test #t (string? "")) +(test #t (string? " ")) +(test #f (string? 'a)) +(test #f (string? #\a)) + +(test 3 (string-length (make-string 3))) +(test "---" (make-string 3 #\-)) + +(test "" (string)) +(test "---" (string #\- #\- #\-)) +(test "kitten" (string #\k #\i #\t #\t #\e #\n)) + +(test 0 (string-length "")) +(test 1 (string-length "a")) +(test 3 (string-length "abc")) + +(test #\a (string-ref "abc" 0)) +(test #\b (string-ref "abc" 1)) +(test #\c (string-ref "abc" 2)) + +(test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str)) + +;; (test (string #\a #\x1F700 #\c) +;; (let ((s (string #\a #\b #\c))) +;; (string-set! s 1 #\x1F700) +;; s)) + +#;(test #t (string=? "" "")) +(test #t (string=? "abc" "abc" "abc")) +(test #f (string=? "" "abc")) +(test #f (string=? "abc" "aBc")) + +(test #f (string? "" "")) +(test #f (string>? "abc" "abc")) +(test #f (string>? "abc" "abcd")) +(test #t (string>? "acd" "abcd" "abc")) +(test #f (string>? "abc" "bbc")) + +(test #t (string<=? "" "")) +(test #t (string<=? "abc" "abc")) +(test #t (string<=? "abc" "abcd" "abcd")) +(test #f (string<=? "abcd" "abc")) +(test #t (string<=? "abc" "bbc")) + +(test #t (string>=? "" "")) +(test #t (string>=? "abc" "abc")) +(test #f (string>=? "abc" "abcd")) +(test #t (string>=? "abcd" "abcd" "abc")) +(test #f (string>=? "abc" "bbc")) + +;; (test #t (string-ci=? "" "")) +;; (test #t (string-ci=? "abc" "abc")) +;; (test #f (string-ci=? "" "abc")) +;; (test #t (string-ci=? "abc" "aBc")) +;; (test #f (string-ci=? "abc" "aBcD")) + +;; (test #f (string-ci? "abc" "aBc")) +;; (test #f (string-ci>? "abc" "aBcD")) +;; (test #t (string-ci>? "ABCd" "aBc")) + +;; (test #t (string-ci<=? "abc" "aBc")) +;; (test #t (string-ci<=? "abc" "aBcD")) +;; (test #f (string-ci<=? "ABCd" "aBc")) + +;; (test #t (string-ci>=? "abc" "aBc")) +;; (test #f (string-ci>=? "abc" "aBcD")) +;; (test #t (string-ci>=? "ABCd" "aBc")) + +;; (test #t (string-ci=? "ΑΒΓ" "αβγ" "αβγ")) +;; (test #f (string-ci? "ΑΒΓ" "αβγ")) +;; (test #t (string-ci<=? "ΑΒΓ" "αβγ")) +;; (test #t (string-ci>=? "ΑΒΓ" "αβγ")) + +;; ;; latin +;; (test "ABC" (string-upcase "abc")) +;; (test "ABC" (string-upcase "ABC")) +;; (test "abc" (string-downcase "abc")) +;; (test "abc" (string-downcase "ABC")) +;; (test "abc" (string-foldcase "abc")) +;; (test "abc" (string-foldcase "ABC")) + +;; ;; cyrillic +;; (test "ΑΒΓ" (string-upcase "αβγ")) +;; (test "ΑΒΓ" (string-upcase "ΑΒΓ")) +;; (test "αβγ" (string-downcase "αβγ")) +;; (test "αβγ" (string-downcase "ΑΒΓ")) +;; (test "αβγ" (string-foldcase "αβγ")) +;; (test "αβγ" (string-foldcase "ΑΒΓ")) + +;; ;; special cases +;; (test "SSA" (string-upcase "ßa")) +;; (test "ßa" (string-downcase "ßa")) +;; (test "ssa" (string-downcase "SSA")) +;; (test "İ" (string-upcase "İ")) +;; (test "i\x0307;" (string-downcase "İ")) +;; (test "i\x0307;" (string-foldcase "İ")) +;; (test "J̌" (string-upcase "ǰ")) + +;; ;; context-sensitive (final sigma) +;; (test "ΓΛΏΣΣΑ" (string-upcase "γλώσσα")) +;; (test "γλώσσα" (string-downcase "ΓΛΏΣΣΑ")) +;; (test "γλώσσα" (string-foldcase "ΓΛΏΣΣΑ")) +;; (test "ΜΈΛΟΣ" (string-upcase "μέλος")) +;; (test #t (and (member (string-downcase "ΜΈΛΟΣ") '("μέλος" "μέλοσ")) #t)) +;; (test "μέλοσ" (string-foldcase "ΜΈΛΟΣ")) +;; (test #t (and (member (string-downcase "ΜΈΛΟΣ ΕΝΌΣ") +;; '("μέλος ενός" "μέλοσ ενόσ")) +;; #t)) + +(test "" (substring "" 0 0)) +(test "" (substring "a" 0 0)) +(test "" (substring "abc" 1 1)) +(test "ab" (substring "abc" 0 2)) +(test "bc" (substring "abc" 1 3)) + +(test "" (string-append "")) +(test "" (string-append "" "")) +(test "abc" (string-append "" "abc")) +(test "abc" (string-append "abc" "")) +(test "abcde" (string-append "abc" "de")) +(test "abcdef" (string-append "abc" "de" "f")) + +(test '() (string->list "")) +(test '(#\a) (string->list "a")) +(test '(#\a #\b #\c) (string->list "abc")) +(test '(#\a #\b #\c) (string->list "abc" 0)) +(test '(#\b #\c) (string->list "abc" 1)) +(test '(#\b #\c) (string->list "abc" 1 3)) +(test "" (list->string '())) +(test "abc" (list->string '(#\a #\b #\c))) + +(test "" (string-copy "")) +(test "" (string-copy "" 0)) +(test "" (string-copy "" 0 0)) +(test "abc" (string-copy "abc")) +(test "abc" (string-copy "abc" 0)) +(test "bc" (string-copy "abc" 1)) +(test "b" (string-copy "abc" 1 2)) +(test "bc" (string-copy "abc" 1 3)) + +;; (test "-----" +;; (let ((str (make-string 5 #\x))) (string-fill! str #\-) str)) +;; (test "xx---" +;; (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str)) +;; (test "xx-xx" +;; (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str)) + +;; (test "a12de" +;; (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str)) +;; (test "-----" +;; (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str)) +;; (test "---xx" +;; (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str)) +;; (test "xx---" +;; (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str)) +;; (test "xx-xx" +;; (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str)) + +;; same source and dest +;; (test "aabde" +;; (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str)) +;; (test "abcab" +;; (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str)) + +(test-end) + +(test-begin "6.8 Vectors") + +(test #t (vector? #())) +(test #t (vector? #(1 2 3))) +(test #t (vector? '#(1 2 3))) + +(test 0 (vector-length (make-vector 0))) +(test 1000 (vector-length (make-vector 1000))) + +(test #(0 (2 2 2 2) "Anna") '#(0 (2 2 2 2) "Anna")) + +(test #(a b c) (vector 'a 'b 'c)) + +(test 8 (vector-ref '#(1 1 2 3 5 8 13 21) 5)) +(test 13 (vector-ref '#(1 1 2 3 5 8 13 21) + (let ((i (round (* 2 (acos -1))))) + (if (inexact? i) + (exact i) + i)))) + +(test #(0 ("Sue" "Sue") "Anna") (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) +(test '(dah didah) (vector->list '#(dah dah didah) 1)) +(test '(dah) (vector->list '#(dah dah didah) 1 2)) +(test #(dididit dah) (list->vector '(dididit dah))) + +(test #() (string->vector "")) +(test #(#\A #\B #\C) (string->vector "ABC")) +(test #(#\B #\C) (string->vector "ABC" 1)) +(test #(#\B) (string->vector "ABC" 1 2)) + +(test "" (vector->string #())) +(test "123" (vector->string #(#\1 #\2 #\3))) +(test "23" (vector->string #(#\1 #\2 #\3) 1)) +(test "2" (vector->string #(#\1 #\2 #\3) 1 2)) + +(test #() (vector-copy #())) +(test #(a b c) (vector-copy #(a b c))) +(test #(b c) (vector-copy #(a b c) 1)) +(test #(b) (vector-copy #(a b c) 1 2)) + +(test #() (vector-append #())) +(test #() (vector-append #() #())) +(test #(a b c) (vector-append #() #(a b c))) +(test #(a b c) (vector-append #(a b c) #())) +(test #(a b c d e) (vector-append #(a b c) #(d e))) +(test #(a b c d e f) (vector-append #(a b c) #(d e) #(f))) + +(test #(1 2 smash smash 5) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec)) +(test #(x x x x x) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec)) +(test #(1 2 x x x) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec)) +(test #(1 2 x 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec)) + +(test #(1 a b 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 #(a b c d e) 0 2) vec)) +(test #(a b c d e) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e)) vec)) +(test #(c d e 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e) 2) vec)) +(test #(1 2 a b c) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 0 3) vec)) +(test #(1 2 c 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 2 3) vec)) + +;; same source and dest +(test #(1 1 2 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 vec 0 2) vec)) +(test #(1 2 3 1 2) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 3 vec 0 2) vec)) + +(test-end) + +(test-begin "6.9 Bytevectors") + +(test #t (bytevector? #u8())) +(test #t (bytevector? #u8(0 1 2))) +(test #f (bytevector? #())) +(test #f (bytevector? #(0 1 2))) +(test #f (bytevector? '())) +(test #t (bytevector? (make-bytevector 0))) + +(test 0 (bytevector-length (make-bytevector 0))) +(test 1024 (bytevector-length (make-bytevector 1024))) +(test 1024 (bytevector-length (make-bytevector 1024 255))) + +(test 3 (bytevector-length (bytevector 0 1 2))) + +(test 0 (bytevector-u8-ref (bytevector 0 1 2) 0)) +(test 1 (bytevector-u8-ref (bytevector 0 1 2) 1)) +(test 2 (bytevector-u8-ref (bytevector 0 1 2) 2)) + +(test #u8(0 255 2) + (let ((bv (bytevector 0 1 2))) (bytevector-u8-set! bv 1 255) bv)) + +(test #u8() (bytevector-copy #u8())) +(test #u8(0 1 2) (bytevector-copy #u8(0 1 2))) +(test #u8(1 2) (bytevector-copy #u8(0 1 2) 1)) +(test #u8(1) (bytevector-copy #u8(0 1 2) 1 2)) + +(test #u8(1 6 7 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 1 #u8(6 7 8 9 10) 0 2) + bv)) +(test #u8(6 7 8 9 10) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 0 #u8(6 7 8 9 10)) + bv)) +(test #u8(8 9 10 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 0 #u8(6 7 8 9 10) 2) + bv)) +(test #u8(1 2 6 7 8) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 2 #u8(6 7 8 9 10) 0 3) + bv)) +(test #u8(1 2 8 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 2 #u8(6 7 8 9 10) 2 3) + bv)) + +;; same source and dest +(test #u8(1 1 2 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 1 bv 0 2) + bv)) +(test #u8(1 2 3 1 2) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 3 bv 0 2) + bv)) + +(test #u8() (bytevector-append #u8())) +(test #u8() (bytevector-append #u8() #u8())) +(test #u8(0 1 2) (bytevector-append #u8() #u8(0 1 2))) +(test #u8(0 1 2) (bytevector-append #u8(0 1 2) #u8())) +(test #u8(0 1 2 3 4) (bytevector-append #u8(0 1 2) #u8(3 4))) +(test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1 2) #u8(3 4) #u8(5))) + +(test "ABC" (utf8->string #u8(#x41 #x42 #x43))) +(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1)) +(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43 0) 1 4)) +;; (test "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3)) +;; (test #u8(#x41 #x42 #x43) (string->utf8 "ABC")) +;; (test #u8(#x42 #x43) (string->utf8 "ABC" 1)) +;; (test #u8(#x42) (string->utf8 "ABC" 1 2)) +;; (test #u8(#xCE #xBB) (string->utf8 "λ")) + +(test-end) + +(test-begin "6.10 Control Features") + +(test #t (procedure? car)) +(test #f (procedure? 'car)) +(test #t (procedure? (lambda (x) (* x x)))) +(test #f (procedure? '(lambda (x) (* x x)))) +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) + +(define compose + (lambda (f g) + (lambda args + (f (apply g args))))) +(test '(30 0) + (call-with-values (lambda () ((compose exact-integer-sqrt *) 12 75)) + list)) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6 7))) + +(test #t + (let ((res (let ((count 0)) + (map (lambda (ignored) + (set! count (+ count 1)) + count) + '(a b))))) + (or (equal? res '(1 2)) + (equal? res '(2 1))))) + +(test '(10 200 3000 40 500 6000) + (let ((ls1 (list 10 100 1000)) + (ls2 (list 1 2 3 4 5 6))) + (set-cdr! (cddr ls1) ls1) + (map * ls1 ls2))) + +;; (test "abdegh" (string-map char-foldcase "AbdEgH")) + +(test "IBM" (string-map + (lambda (c) + (integer->char (+ 1 (char->integer c)))) + "HAL")) + +;; (test "StUdLyCaPs" +;; (string-map +;; (lambda (c k) (if (eqv? k #\u) (char-upcase c) (char-downcase c))) +;; "studlycaps xxx" +;; "ululululul")) + +(test #(b e h) (vector-map cadr '#((a b) (d e) (g h)))) + +(test #(1 4 27 256 3125) + (vector-map (lambda (n) (expt n n)) + '#(1 2 3 4 5))) + +(test #(5 7 9) (vector-map + '#(1 2 3) '#(4 5 6 7))) + +(test #t + (let ((res (let ((count 0)) + (vector-map + (lambda (ignored) + (set! count (+ count 1)) + count) + '#(a b))))) + (or (equal? res #(1 2)) + (equal? res #(2 1))))) + +(test #(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each (lambda (i) + (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 9750 + (let ((ls1 (list 10 100 1000)) + (ls2 (list 1 2 3 4 5 6)) + (count 0)) + (set-cdr! (cddr ls1) ls1) + (for-each (lambda (x y) (set! count (+ count (* x y)))) ls2 ls1) + count)) + +(test '(101 100 99 98 97) + (let ((v '())) + (string-for-each + (lambda (c) (set! v (cons (char->integer c) v))) + "abcde") + v)) + +(test '(0 1 4 9 16) (let ((v (make-list 5))) + (vector-for-each + (lambda (i) (list-set! v i (* i i))) + '#(0 1 2 3 4)) + v)) + +(test -3 (call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t))) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r + (lambda (obj) + (cond ((null? obj) 0) + ((pair? obj) + (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) + +(test 4 (list-length '(1 2 3 4))) + +(test #f (list-length '(a b . c))) + +(test 5 + (call-with-values (lambda () (values 4 5)) + (lambda (a b) b))) + +(test -1 (call-with-values * -)) + +#; +(test '(connect talk1 disconnect + connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test-end) + +(test-begin "6.11 Exceptions") + +;; (test 65 +;; (with-exception-handler +;; (lambda (con) 42) +;; (lambda () +;; (+ (raise-continuable "should be a number") +;; 23)))) + +;; (test #t +;; (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +;; (test "BOOM!" +;; (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +;; (test '(1 2 3) +;; (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) + +;; (test #f +;; (file-error? (guard (exn (else exn)) (error "BOOM!")))) +;; (test #t +;; (file-error? (guard (exn (else exn)) (open-input-file " no such file ")))) + +;; (test #f +;; (read-error? (guard (exn (else exn)) (error "BOOM!")))) +;; (test #t +;; (read-error? (guard (exn (else exn)) (read (open-input-string ")"))))) + +(define something-went-wrong #f) +(define (test-exception-handler-1 v) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) + (set! something-went-wrong (list "condition: " x)) + (k 'exception)) + (lambda () + (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))) +(test 106 (test-exception-handler-1 5)) +(test #f something-went-wrong) +(test 'exception (test-exception-handler-1 -1)) +(test '("condition: " an-error) something-went-wrong) + +(set! something-went-wrong #f) +;; (define (test-exception-handler-2 v) +;; (guard (ex (else 'caught-another-exception)) +;; (with-exception-handler +;; (lambda (x) +;; (set! something-went-wrong #t) +;; (list "exception:" x)) +;; (lambda () +;; (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))) +;; (test 106 (test-exception-handler-2 5)) +;; (test #f something-went-wrong) +;; (test 'caught-another-exception (test-exception-handler-2 -1)) +;; (test #t something-went-wrong) + +;; Based on an example from R6RS-lib section 7.1 Exceptions. +;; R7RS section 6.11 Exceptions has a simplified version. +;; (let* ((out (open-output-string)) +;; (value (with-exception-handler +;; (lambda (con) +;; (cond +;; ((not (list? con)) +;; (raise con)) +;; ((list? con) +;; (display (car con) out)) +;; (else +;; (display "a warning has been issued" out))) +;; 42) +;; (lambda () +;; (+ (raise-continuable +;; (list "should be a number")) +;; 23))))) +;; (test "should be a number" (get-output-string out)) +;; (test 65 value)) + +;; From SRFI-34 "Examples" section - #3 +;; (define (test-exception-handler-3 v out) +;; (guard (condition +;; (else +;; (display "condition: " out) +;; (write condition out) +;; (display #\! out) +;; 'exception)) +;; (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v))))) +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-3 0 out))) +;; (test 'exception value) +;; (test "condition: an-error!" (get-output-string out))) + +;; (define (test-exception-handler-4 v out) +;; (call-with-current-continuation +;; (lambda (k) +;; (with-exception-handler +;; (lambda (x) +;; (display "reraised " out) +;; (write x out) (display #\! out) +;; (k 'zero)) +;; (lambda () +;; (guard (condition +;; ((positive? condition) +;; 'positive) +;; ((negative? condition) +;; 'negative)) +;; (raise v))))))) + +;; From SRFI-34 "Examples" section - #5 +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-4 1 out))) +;; (test "" (get-output-string out)) +;; (test 'positive value)) +;; ;; From SRFI-34 "Examples" section - #6 +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-4 -1 out))) +;; (test "" (get-output-string out)) +;; (test 'negative value)) +;; ;; From SRFI-34 "Examples" section - #7 +;; (let* ((out (open-output-string)) +;; (value (test-exception-handler-4 0 out))) +;; (test "reraised 0!" (get-output-string out)) +;; (test 'zero value)) + +;; From SRFI-34 "Examples" section - #8 +;; (test 42 +;; (guard (condition +;; ((assq 'a condition) => cdr) +;; ((assq 'b condition))) +;; (raise (list (cons 'a 42))))) + +;; ;; From SRFI-34 "Examples" section - #9 +;; (test '(b . 23) +;; (guard (condition +;; ((assq 'a condition) => cdr) +;; ((assq 'b condition))) +;; (raise (list (cons 'b 23))))) + +;; (test 'caught-d +;; (guard (condition +;; ((assq 'c condition) 'caught-c) +;; ((assq 'd condition) 'caught-d)) +;; (list +;; (sqrt 8) +;; (guard (condition +;; ((assq 'a condition) => cdr) +;; ((assq 'b condition))) +;; (raise (list (cons 'd 24))))))) + +(test-end) + +(test-begin "6.12 Environments and evaluation") + +;; (test 21 (eval '(* 7 3) (scheme-report-environment 5))) + +;; (test 20 +;; (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) +;; (f + 10))) + +;; (test 1024 (eval '(expt 2 10) (environment '(scheme base)))) +;; ;; (sin 0) may return exact number +;; (test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact))))) +;; ;; ditto +;; (test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0))) +;; (environment '(scheme base) '(scheme inexact)))) + +(test-end) + +(test-begin "6.13 Input and output") + +(test #t (port? (current-input-port))) +(test #t (input-port? (current-input-port))) +(test #t (output-port? (current-output-port))) +(test #t (output-port? (current-error-port))) +(test #t (input-port? (open-input-string "abc"))) +(test #t (output-port? (open-output-string))) + +(test #t (textual-port? (open-input-string "abc"))) +(test #t (textual-port? (open-output-string))) +(test #t (binary-port? (open-input-bytevector #u8(0 1 2)))) +(test #t (binary-port? (open-output-bytevector))) + +(test #t (input-port-open? (open-input-string "abc"))) +(test #t (output-port-open? (open-output-string))) + +(test #f + (let ((in (open-input-string "abc"))) + (close-input-port in) + (input-port-open? in))) + +(test #f + (let ((out (open-output-string))) + (close-output-port out) + (output-port-open? out))) + +(test #f + (let ((out (open-output-string))) + (close-port out) + (output-port-open? out))) + +(test #t (eof-object? (eof-object))) +;; (test #t (eof-object? (read (open-input-string "")))) +(test #t (char-ready? (open-input-string "42"))) +;; (test 42 (read (open-input-string " 42 "))) + +(test #t (eof-object? (read-char (open-input-string "")))) +(test #\a (read-char (open-input-string "abc"))) + +(test #t (eof-object? (read-line (open-input-string "")))) +(test "abc" (read-line (open-input-string "abc"))) +(test "abc" (read-line (open-input-string "abc\ndef\n"))) + +(test #t (eof-object? (read-string 3 (open-input-string "")))) +(test "abc" (read-string 3 (open-input-string "abcd"))) +(test "abc" (read-string 3 (open-input-string "abc\ndef\n"))) + +;; (let ((in (open-input-string (string #\x10F700 #\x10F701 #\x10F702)))) +;; (let* ((c1 (read-char in)) +;; (c2 (read-char in)) +;; (c3 (read-char in))) +;; (test #\x10F700 c1) +;; (test #\x10F701 c2) +;; (test #\x10F702 c3))) + +;; (test (string #\x10F700) +;; (let ((out (open-output-string))) +;; (write-char #\x10F700 out) +;; (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (write 'abc out) + (get-output-string out))) + +(test "abc def" + (let ((out (open-output-string))) + (display "abc def" out) + (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (display #\a out) + (display "b" out) + (display #\c out) + (get-output-string out))) + +(test #t + (let* ((out (open-output-string)) + (r (begin (newline out) (get-output-string out)))) + (or (equal? r "\n") (equal? r "\r\n")))) + +(test "abc def" + (let ((out (open-output-string))) + (write-string "abc def" out) + (get-output-string out))) + +(test "def" + (let ((out (open-output-string))) + (write-string "abc def" out 4) + (get-output-string out))) + +(test "c d" + (let ((out (open-output-string))) + (write-string "abc def" out 2 5) + (get-output-string out))) + +(test "" + (let ((out (open-output-string))) + (flush-output-port out) + (get-output-string out))) + +(test #t (eof-object? (read-u8 (open-input-bytevector #u8())))) +(test 1 (read-u8 (open-input-bytevector #u8(1 2 3)))) + +(test #t (eof-object? (read-bytevector 3 (open-input-bytevector #u8())))) +(test #t (u8-ready? (open-input-bytevector #u8(1)))) +(test #u8(1) (read-bytevector 3 (open-input-bytevector #u8(1)))) +(test #u8(1 2) (read-bytevector 3 (open-input-bytevector #u8(1 2)))) +(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3)))) +(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3 4)))) + +(test #t + (let ((bv (bytevector 1 2 3 4 5))) + (eof-object? (read-bytevector! bv (open-input-bytevector #u8()))))) + +(test #u8(6 7 8 9 10) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 5) + bv)) + +(test #u8(6 7 8 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 3) + bv)) + +(test #u8(1 2 3 6 5) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 3 4) + bv)) + +(test #u8(1 2 3) + (let ((out (open-output-bytevector))) + (write-u8 1 out) + (write-u8 2 out) + (write-u8 3 out) + (get-output-bytevector out))) + +(test #u8(1 2 3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out) + (get-output-bytevector out))) + +(test #u8(3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2) + (get-output-bytevector out))) + +(test #u8(3 4) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2 4) + (get-output-bytevector out))) + +(test #u8() + (let ((out (open-output-bytevector))) + (flush-output-port out) + (get-output-bytevector out))) + +(test #t + (and (member + (let ((out (open-output-string)) + (x (list 1))) + (set-cdr! x x) + (write x out) + (get-output-string out)) + ;; labels not guaranteed to be 0 indexed, spacing may differ + '("#0=(1 . #0#)" "#1=(1 . #1#)")) + #t)) + +(test "((1 2 3) (1 2 3))" + (let ((out (open-output-string)) + (x (list 1 2 3))) + (write (list x x) out) + (get-output-string out))) + +(test "((1 2 3) (1 2 3))" + (let ((out (open-output-string)) + (x (list 1 2 3))) + (write-simple (list x x) out) + (get-output-string out))) + +(test #t + (and (member (let ((out (open-output-string)) + (x (list 1 2 3))) + (write-shared (list x x) out) + (get-output-string out)) + '("(#0=(1 2 3) #0#)" "(#1=(1 2 3) #1#)")) + #t)) + +(test-begin "Read syntax") + +;; check reading boolean followed by eof +;; (test #t (read (open-input-string "#t"))) +;; (test #t (read (open-input-string "#true"))) +;; (test #f (read (open-input-string "#f"))) +;; (test #f (read (open-input-string "#false"))) +;; (define (read2 port) +;; (let* ((o1 (read port)) (o2 (read port))) +;; (cons o1 o2))) +;; ;; check reading boolean followed by delimiter +;; (test '(#t . (5)) (read2 (open-input-string "#t(5)"))) +;; (test '(#t . 6) (read2 (open-input-string "#true 6 "))) +;; (test '(#f . 7) (read2 (open-input-string "#f 7"))) +;; (test '(#f . "8") (read2 (open-input-string "#false\"8\""))) + +;; (test '() (read (open-input-string "()"))) +;; (test '(1 2) (read (open-input-string "(1 2)"))) +;; (test '(1 . 2) (read (open-input-string "(1 . 2)"))) +;; (test '(1 2) (read (open-input-string "(1 . (2))"))) +;; (test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))"))) +;; (test '1 (cadr (read (open-input-string "#0=(1 . #0#)")))) +;; (test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)")))) + +;; (test '(quote (1 2)) (read (open-input-string "'(1 2)"))) +;; (test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)"))) +;; (test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)"))) +;; (test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)"))) + +;; (test #() (read (open-input-string "#()"))) +;; (test #(a b) (read (open-input-string "#(a b)"))) + +;; (test #u8() (read (open-input-string "#u8()"))) +;; (test #u8(0 1) (read (open-input-string "#u8(0 1)"))) + +;; (test 'abc (read (open-input-string "abc"))) +;; (test 'abc (read (open-input-string "abc def"))) +;; (test 'ABC (read (open-input-string "ABC"))) +;; (test 'Hello (read (open-input-string "|H\\x65;llo|"))) + +;; (test 'abc (read (open-input-string "#!fold-case ABC"))) +;; (test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC"))) + +;; (test 'def (read (open-input-string "#; abc def"))) +;; (test 'def (read (open-input-string "; abc \ndef"))) +;; (test 'def (read (open-input-string "#| abc |# def"))) +;; (test 'ghi (read (open-input-string "#| abc #| def |# |# ghi"))) +;; (test 'ghi (read (open-input-string "#; ; abc\n def ghi"))) +;; (test '(abs -16) (read (open-input-string "(#;sqrt abs -16)"))) +;; (test '(a d) (read (open-input-string "(a #; #;b c d)"))) +;; (test '(a e) (read (open-input-string "(a #;(b #;c d) e)"))) +;; (test '(a . c) (read (open-input-string "(a . #;b c)"))) +;; (test '(a . b) (read (open-input-string "(a . b #;c)"))) + +;; (define (test-read-error str) +;; (test-assert +;; (guard (exn (else #t)) +;; (read (open-input-string str)) +;; #f))) + +;; (test-read-error "(#;a . b)") +;; (test-read-error "(a . #;b)") +;; (test-read-error "(a #;. b)") +;; (test-read-error "(#;x #;y . z)") +;; (test-read-error "(#; #;x #;y . z)") +;; (test-read-error "(#; #;x . z)") + +;; (test #\a (read (open-input-string "#\\a"))) +;; (test #\space (read (open-input-string "#\\space"))) +;; (test 0 (char->integer (read (open-input-string "#\\null")))) +;; (test 7 (char->integer (read (open-input-string "#\\alarm")))) +;; (test 8 (char->integer (read (open-input-string "#\\backspace")))) +;; (test 9 (char->integer (read (open-input-string "#\\tab")))) +;; (test 10 (char->integer (read (open-input-string "#\\newline")))) +;; (test 13 (char->integer (read (open-input-string "#\\return")))) +;; (test #x7F (char->integer (read (open-input-string "#\\delete")))) +;; (test #x1B (char->integer (read (open-input-string "#\\escape")))) +;; (test #x03BB (char->integer (read (open-input-string "#\\λ")))) +;; (test #x03BB (char->integer (read (open-input-string "#\\x03BB")))) + +;; (test "abc" (read (open-input-string "\"abc\""))) +;; (test "abc" (read (open-input-string "\"abc\" \"def\""))) +;; (test "ABC" (read (open-input-string "\"ABC\""))) +;; (test "Hello" (read (open-input-string "\"H\\x65;llo\""))) +;; (test 7 (char->integer (string-ref (read (open-input-string "\"\\a\"")) 0))) +;; (test 8 (char->integer (string-ref (read (open-input-string "\"\\b\"")) 0))) +;; (test 9 (char->integer (string-ref (read (open-input-string "\"\\t\"")) 0))) +;; (test 10 (char->integer (string-ref (read (open-input-string "\"\\n\"")) 0))) +;; (test 13 (char->integer (string-ref (read (open-input-string "\"\\r\"")) 0))) +;; (test #x22 (char->integer (string-ref (read (open-input-string "\"\\\"\"")) 0))) +;; (test #x7C (char->integer (string-ref (read (open-input-string "\"\\|\"")) 0))) +;; (test "line 1\nline 2\n" (read (open-input-string "\"line 1\nline 2\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\\ncontinued\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\ \ncontinued\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\\n continued\n\""))) +;; (test "line 1continued\n" (read (open-input-string "\"line 1\\ \t \n \t continued\n\""))) +;; (test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\""))) +;; (test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0))) + +;; (test-end) + +(test-begin "Numeric syntax") + +;; Numeric syntax adapted from Peter Bex's tests. +;; +;; These are updated to R7RS, using string ports instead of +;; string->number, and "error" tests removed because implementations +;; are free to provide their own numeric extensions. Currently all +;; tests are run by default - need to cond-expand and test for +;; infinities and -0.0. + +;; (define-syntax test-numeric-syntax +;; (syntax-rules () +;; ((test-numeric-syntax str expect strs ...) +;; (let* ((z (read (open-input-string str))) +;; (out (open-output-string)) +;; (z-str (begin (write z out) (get-output-string out)))) +;; (test expect (values z)) +;; (test #t (and (member z-str '(str strs ...)) #t)))))) + +;; Each test is of the form: +;; +;; (test-numeric-syntax input-str expected-value expected-write-values ...) +;; +;; where the input should be eqv? to the expected-value, and the +;; written output the same as any of the expected-write-values. The +;; form +;; +;; (test-numeric-syntax input-str expected-value) +;; +;; is a shorthand for +;; +;; (test-numeric-syntax input-str expected-value (input-str)) + +;; Simple +;; (test-numeric-syntax "1" 1) +;; (test-numeric-syntax "+1" 1 "1") +;; (test-numeric-syntax "-1" -1) +;; (test-numeric-syntax "#i1" 1.0 "1.0" "1.") +;; (test-numeric-syntax "#I1" 1.0 "1.0" "1.") +;; (test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.") +;; ;; Decimal +;; (test-numeric-syntax "1.0" 1.0 "1.0" "1.") +;; (test-numeric-syntax "1." 1.0 "1.0" "1.") +;; (test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3") +;; (test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3") +;; ;; Some Schemes don't allow negative zero. This is okay with the standard +;; (test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0") +;; (test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0") +;; (test-numeric-syntax "#i1.0" 1.0 "1.0" "1.") +;; (test-numeric-syntax "#e1.0" 1 "1") +;; (test-numeric-syntax "#e-.0" 0 "0") +;; (test-numeric-syntax "#e-0." 0 "0") +;; ;; Decimal notation with suffix +;; (test-numeric-syntax "1e2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1E2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1s2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1S2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1f2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1F2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1d2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1D2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1l2" 100.0 "100.0" "100.") +;; (test-numeric-syntax "1L2" 100.0 "100.0" "100.") +;; ;; NaN, Inf +;; (test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0") +;; (test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0") +;; (test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0") +;; (test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0") +;; (test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0") +;; (test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0") +;; (test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0") +;; (test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0") +;; (test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0") +;; ;; Exact ratios +;; (test-numeric-syntax "1/2" (/ 1 2)) +;; (test-numeric-syntax "#e1/2" (/ 1 2) "1/2") +;; (test-numeric-syntax "10/2" 5 "5") +;; (test-numeric-syntax "-1/2" (- (/ 1 2))) +;; (test-numeric-syntax "0/10" 0 "0") +;; (test-numeric-syntax "#e0/10" 0 "0") +;; (test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5") +;; ;; Exact complex +;; (test-numeric-syntax "1+2i" (make-rectangular 1 2)) +;; (test-numeric-syntax "1+2I" (make-rectangular 1 2) "1+2i") +;; (test-numeric-syntax "1-2i" (make-rectangular 1 -2)) +;; (test-numeric-syntax "-1+2i" (make-rectangular -1 2)) +;; (test-numeric-syntax "-1-2i" (make-rectangular -1 -2)) +;; (test-numeric-syntax "+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +;; (test-numeric-syntax "0+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +;; (test-numeric-syntax "0+1i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +;; (test-numeric-syntax "-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +;; (test-numeric-syntax "0-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +;; (test-numeric-syntax "0-1i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +;; (test-numeric-syntax "+2i" (make-rectangular 0 2) "2i" "+2i" "0+2i") +;; (test-numeric-syntax "-2i" (make-rectangular 0 -2) "-2i" "0-2i") +;; ;; Decimal-notation complex numbers (rectangular notation) +;; (test-numeric-syntax "1.0+2i" (make-rectangular 1.0 2) "1.0+2.0i" "1.0+2i" "1.+2i" "1.+2.i") +;; (test-numeric-syntax "1+2.0i" (make-rectangular 1 2.0) "1.0+2.0i" "1+2.0i" "1.+2.i" "1+2.i") +;; (test-numeric-syntax "1e2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i") +;; (test-numeric-syntax "1s2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i") +;; (test-numeric-syntax "1.0+1e2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i") +;; (test-numeric-syntax "1.0+1s2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i") +;; ;; Fractional complex numbers (rectangular notation) +;; (test-numeric-syntax "1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4))) +;; ;; Mixed fractional/decimal notation complex numbers (rectangular notation) +;; (test-numeric-syntax "0.5+3/4i" (make-rectangular 0.5 (/ 3 4)) +;; "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i") +;; ;; Complex NaN, Inf (rectangular notation) +;; ;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i") +;; (test-numeric-syntax "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0) "+Inf.0+Inf.0i") +;; (test-numeric-syntax "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0) "-Inf.0+Inf.0i") +;; (test-numeric-syntax "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0) "-Inf.0-Inf.0i") +;; (test-numeric-syntax "+inf.0-inf.0i" (make-rectangular +inf.0 -inf.0) "+Inf.0-Inf.0i") +;; ;; Complex numbers (polar notation) +;; ;; Need to account for imprecision in write output. +;; ;;(test-numeric-syntax "1@2" -0.416146836547142+0.909297426825682i "-0.416146836547142+0.909297426825682i") +;; ;; Base prefixes +;; (test-numeric-syntax "#x11" 17 "17") +;; (test-numeric-syntax "#X11" 17 "17") +;; (test-numeric-syntax "#d11" 11 "11") +;; (test-numeric-syntax "#D11" 11 "11") +;; (test-numeric-syntax "#o11" 9 "9") +;; (test-numeric-syntax "#O11" 9 "9") +;; (test-numeric-syntax "#b11" 3 "3") +;; (test-numeric-syntax "#B11" 3 "3") +;; (test-numeric-syntax "#o7" 7 "7") +;; (test-numeric-syntax "#xa" 10 "10") +;; (test-numeric-syntax "#xA" 10 "10") +;; (test-numeric-syntax "#xf" 15 "15") +;; (test-numeric-syntax "#x-10" -16 "-16") +;; (test-numeric-syntax "#d-10" -10 "-10") +;; (test-numeric-syntax "#o-10" -8 "-8") +;; (test-numeric-syntax "#b-10" -2 "-2") +;; ;; Combination of prefixes +;; (test-numeric-syntax "#e#x10" 16 "16") +;; (test-numeric-syntax "#i#x10" 16.0 "16.0" "16.") +;; ;; (Attempted) decimal notation with base prefixes +;; (test-numeric-syntax "#d1." 1.0 "1.0" "1.") +;; (test-numeric-syntax "#d.1" 0.1 "0.1" ".1" "100.0e-3") +;; (test-numeric-syntax "#x1e2" 482 "482") +;; (test-numeric-syntax "#d1e2" 100.0 "100.0" "100.") +;; ;; Fractions with prefixes +;; (test-numeric-syntax "#x10/2" 8 "8") +;; (test-numeric-syntax "#x11/2" (/ 17 2) "17/2") +;; (test-numeric-syntax "#d11/2" (/ 11 2) "11/2") +;; (test-numeric-syntax "#o11/2" (/ 9 2) "9/2") +;; (test-numeric-syntax "#b11/10" (/ 3 2) "3/2") +;; ;; Complex numbers with prefixes +;; ;;(test-numeric-syntax "#x10+11i" (make-rectangular 16 17) "16+17i") +;; (test-numeric-syntax "#d1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i") +;; (test-numeric-syntax "#d10+11i" (make-rectangular 10 11) "10+11i") +;; ;;(test-numeric-syntax "#o10+11i" (make-rectangular 8 9) "8+9i") +;; ;;(test-numeric-syntax "#b10+11i" (make-rectangular 2 3) "2+3i") +;; ;;(test-numeric-syntax "#e1.0+1.0i" (make-rectangular 1 1) "1+1i" "1+i") +;; ;;(test-numeric-syntax "#i1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i") + +(test-end) + +(test-end) + +(test-begin "6.14 System interface") + +;; 6.14 System interface + +;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH")) + +;; (test #t (string? (get-environment-variable "PATH"))) + +;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables)) + +;; (let ((env (get-environment-variables))) +;; (define (env-pair? x) +;; (and (pair? x) (string? (car x)) (string? (cdr x)))) +;; (define (all? pred ls) +;; (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls))))) +;; (test #t (list? env)) +;; (test #t (all? env-pair? env))) + +(test #t (list? (command-line))) + +(test #t (real? (current-second))) +(test #t (inexact? (current-second))) +(test #t (exact? (current-jiffy))) +(test #t (exact? (jiffies-per-second))) + +(test #t (list? (features))) +(test #t (and (memq 'r7rs (features)) #t)) + +(test #t (file-exists? ".")) +(test #f (file-exists? " no such file ")) + +;; (test #t (file-error? +;; (guard (exn (else exn)) +;; (delete-file " no such file ")))) + +(test-end) + +(test-end) From 8c80b6ef5ba5bc9682e2f6d805bdcb4ae315c732 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 20:09:38 +0900 Subject: [PATCH 013/200] use "%zu"s for size_t --- src/codegen.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/codegen.c b/src/codegen.c index 63abd247..f18062b0 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -1442,13 +1442,13 @@ pic_compile(pic_state *pic, pic_value obj) size_t ai = pic_gc_arena_preserve(pic); #if DEBUG - fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "# input expression\n"); pic_debug(pic, obj); fprintf(stdout, "\n"); - fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif /* macroexpand */ @@ -1457,7 +1457,7 @@ pic_compile(pic_state *pic, pic_value obj) fprintf(stdout, "## macroexpand completed\n"); pic_debug(pic, obj); fprintf(stdout, "\n"); - fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif /* analyze */ @@ -1466,7 +1466,7 @@ pic_compile(pic_state *pic, pic_value obj) fprintf(stdout, "## analyzer completed\n"); pic_debug(pic, obj); fprintf(stdout, "\n"); - fprintf(stdout, "ai = %d\n", pic_gc_arena_preserve(pic)); + fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); #endif /* codegen */ From 316f36a64bd42e777ef25c439ffe90a34bbddc3f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 20:23:23 +0900 Subject: [PATCH 014/200] add copyright notice --- t/r7rs-tests.scm | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index be54d4aa..2d7ed100 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -1,3 +1,31 @@ +;; Copyright (c) 2014 Yuichi Nishiwaki, and other picrin contributers. + +;; Copyright (c) 2009-2012 Alex Shinn +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. The name of the author may not be used to endorse or promote products +;; derived from this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + ;; -*- coding: utf-8 -*- (import (scheme base) From 44b80ccb8a46ef37e6c8458b3167abc77c177781 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 20:24:29 +0900 Subject: [PATCH 015/200] remove file-variable --- t/r7rs-tests.scm | 3 --- 1 file changed, 3 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 2d7ed100..b27f331f 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -25,9 +25,6 @@ ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -;; -*- coding: utf-8 -*- - (import (scheme base) ; (scheme char) (scheme lazy) From 82f8679efdca02f3537d84333ee5889c9b04ec86 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 20:27:32 +0900 Subject: [PATCH 016/200] remove useless notice --- t/r7rs-tests.scm | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index b27f331f..98f3a727 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -43,11 +43,7 @@ ;; language except `delete-file'. Currently assumes full-unicode ;; support, the full numeric tower and all standard libraries ;; provided. -;; -;; Uses the (chibi test) library which is written in portable R7RS. -;; This is mostly a subset of SRFI-64, providing test-begin, test-end -;; and test, which could be defined as something like: -;; + (define (test-begin . o) #f) (define (test-end . o) #f) @@ -80,9 +76,6 @@ (display "") (newline))) (set! counter (+ counter 1)))))) -;; -;; however (chibi test) provides nicer output, timings, and -;; approximate equivalence for floating point numbers. (newline) From b9e1e7d31b9017c3eb03e4c9ae2f501b69f20722 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 20:32:34 +0900 Subject: [PATCH 017/200] add 'make test' target --- CMakeLists.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 22cc4f9d..bba9bd1d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -39,6 +39,9 @@ include(tools/CMakeLists.txt) # $ make run add_custom_target(run bin/picrin DEPENDS repl) +# $ make test +add_custom_target(test DEPENDS no-act) + # $ make no-act add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl) From 2932486ab556e714b4c2cef9fdeaa2af800abade Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 20:34:08 +0900 Subject: [PATCH 018/200] update travis config --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 5bccf52b..fc6103f9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,5 +6,5 @@ before_script: - cd build script: - perl --version - - cmake .. && make && make no-act - - cmake -DCMAKE_BUILD_TYPE=Debug .. && make && make no-act + - cmake .. && make test + - cmake -DCMAKE_BUILD_TYPE=Debug .. && make test From 20427fb66a0e1a1698b96c719d4df64b7e621a4d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 22:29:02 +0900 Subject: [PATCH 019/200] 'make test' runs r7rs tests --- CMakeLists.txt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bba9bd1d..12347110 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -40,11 +40,14 @@ include(tools/CMakeLists.txt) add_custom_target(run bin/picrin DEPENDS repl) # $ make test -add_custom_target(test DEPENDS no-act) +add_custom_target(test DEPENDS no-act test-r7rs) # $ make no-act add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl) +# $ make test-r7rs +add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl) + # $ make tak add_custom_target(tak bin/picrin etc/tak.scm DEPENDS repl) From e3c60b56e62cd788059fc0d0841428776fa62fa7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 22 Jun 2014 22:29:25 +0900 Subject: [PATCH 020/200] we don't have support for #x123 literals --- t/r7rs-tests.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 98f3a727..e5ce8af7 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -1445,9 +1445,9 @@ (test #u8(0 1 2 3 4) (bytevector-append #u8(0 1 2) #u8(3 4))) (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1 2) #u8(3 4) #u8(5))) -(test "ABC" (utf8->string #u8(#x41 #x42 #x43))) -(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1)) -(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43 0) 1 4)) +;; (test "ABC" (utf8->string #u8(#x41 #x42 #x43))) +;; (test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1)) +;; (test "ABC" (utf8->string #u8(0 #x41 #x42 #x43 0) 1 4)) ;; (test "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3)) ;; (test #u8(#x41 #x42 #x43) (string->utf8 "ABC")) ;; (test #u8(#x42 #x43) (string->utf8 "ABC" 1)) From 711b53eb72540a6219afa65f38b4b085251d56dd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 23 Jun 2014 00:52:36 +0900 Subject: [PATCH 021/200] fix #140 --- src/vm.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/vm.c b/src/vm.c index c2d0b1e0..8b7c51f1 100644 --- a/src/vm.c +++ b/src/vm.c @@ -747,7 +747,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) /* invoke! */ pic->sp[0] = proc->u.func.f(pic); - pic->sp += ci->retc; + pic->sp += pic->ci->retc; pic_gc_arena_restore(pic, ai); goto L_RET; @@ -1002,21 +1002,23 @@ static pic_code trampoline_iseq[] = { pic_value pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) { - pic_value v, call_list, *fp = pic->ci->fp; + pic_value v, *sp; pic_callinfo *ci; - call_list = pic_cons(pic, pic_obj_value(proc), args); + *pic->sp++ = pic_obj_value(proc); - pic_for_each (v, call_list) { - *fp++ = v; + sp = pic->sp; + pic_for_each (v, args) { + *sp++ = v; } - trampoline_iseq[1].u.i = pic_length(pic, call_list); + trampoline_iseq[1].u.i = -1; ci = PUSHCI(); ci->ip = trampoline_iseq; - ci->fp = fp - 1; /* the last argument is pushed by the VM */ - return v; + ci->fp = pic->sp; + ci->retc = pic_length(pic, args); + return pic_obj_value(proc); } pic_value From fa179dc1528b1d599004012f10bdd3bd44ff2dbb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 23 Jun 2014 00:54:11 +0900 Subject: [PATCH 022/200] trampoline_iseq is no longer mutable --- src/vm.c | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/src/vm.c b/src/vm.c index 8b7c51f1..1fe153a4 100644 --- a/src/vm.c +++ b/src/vm.c @@ -994,14 +994,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) } VM_LOOP_END; } -static pic_code trampoline_iseq[] = { - { OP_NOP, {0} }, - { OP_TAILCALL, {0} }, -}; - pic_value pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) { + static const pic_code iseq[] = { { OP_NOP, {0} }, { OP_TAILCALL, { .i = -1 } } }; + pic_value v, *sp; pic_callinfo *ci; @@ -1012,10 +1009,8 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) *sp++ = v; } - trampoline_iseq[1].u.i = -1; - ci = PUSHCI(); - ci->ip = trampoline_iseq; + ci->ip = (pic_code *)iseq; ci->fp = pic->sp; ci->retc = pic_length(pic, args); return pic_obj_value(proc); From 4c78e0694a940ccb187fc529577bbd28610538a9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 23 Jun 2014 00:56:43 +0900 Subject: [PATCH 023/200] shrink trampoline iseq --- src/vm.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/vm.c b/src/vm.c index 1fe153a4..9e4509f4 100644 --- a/src/vm.c +++ b/src/vm.c @@ -997,7 +997,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) pic_value pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) { - static const pic_code iseq[] = { { OP_NOP, {0} }, { OP_TAILCALL, { .i = -1 } } }; + static const pic_code iseq = { OP_TAILCALL, { .i = -1 } }; pic_value v, *sp; pic_callinfo *ci; @@ -1010,7 +1010,7 @@ pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) } ci = PUSHCI(); - ci->ip = (pic_code *)iseq; + ci->ip = (pic_code *)&iseq - 1; ci->fp = pic->sp; ci->retc = pic_length(pic, args); return pic_obj_value(proc); From 694d5eafe3d4def6e9ccad3d069d7fc72504b5da Mon Sep 17 00:00:00 2001 From: stibear Date: Mon, 23 Jun 2014 03:11:43 +0900 Subject: [PATCH 024/200] implements (srfi 60) --- piclib/srfi/60.scm | 182 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 piclib/srfi/60.scm diff --git a/piclib/srfi/60.scm b/piclib/srfi/60.scm new file mode 100644 index 00000000..627a71cf --- /dev/null +++ b/piclib/srfi/60.scm @@ -0,0 +1,182 @@ +(define-library (srfi 60) + (import (scheme base) + (srfi 1)) + + ;; # Bitwise Operations + (define (logand . args) + (letrec ((lgand + (lambda (x y) + (if (or (zero? x) (zero? y)) + 0 + (+ (* (lgand (floor/ x 2) (floor/ y 2)) 2) + (if (or (even? x) (even? y)) 0 1)))))) + (fold lgand -1 args))) + + (define bitwise-and logand) + + (define (logior . args) + (letrec ((lgior + (lambda (x y) + (cond + ((= x y) x) + ((zero? x) y) + ((zero? y) x) + (else + (+ (* (lgior (truncate-quotient x 2) + (truncate-quotient y 2)) + 2) + (if (and (even? x) (even? y)) 0 1))))))) + (fold lgior 0 args))) + + (define bitwise-ior logior) + + (define (logxor . args) + (letrec ((lgxor + (lambda (x y) + (cond + ((zero? x) y) + ((zero? y) x) + (else + (+ (* (lgxor (floor/ x 2) (floor/ y 2)) 2) + (if (even? x) + (if (even? y) 0 1) + (if (even? y) 1 0)))))))) + (fold lgxor 0 args))) + + (define bitwise-xor logxor) + + (define (lognot n) + (- -1 n)) + + (define bitwise-not lognot) + + (define (bitwise-if mask n0 n1) + (logior (logand mask n0) + (logand (lognot mask) n1))) + + (define bitwise-merge bitwise-if) + + (define (logtest j k) + (not (zero? (logand j k)))) + + (define any-bits-set? logtest) + + ;; # Integer Properties + (define (logcount n) + (letrec ((lgcnt + (lambda (n) + (if (zero? n) 0 + (+ (lgcnt (floor/ n 2)) + (if (even? n) 0 1)))))) + (if (negative? n) + (lgcnt (lognot n)) + (lgcnt n)))) + + (define bit-count logcount) + + (define (integer-length n) + (let loop ((n n) (count 0)) + (if (zero? n) + count + (loop (floor/ n 2) (+ count 1))))) + + (define (log2-binary-factors n) + (+ -1 (integer-length (logand n (- n))))) + + (define first-set-bit log2-binary-factors) + + ;; # Bit Within Word + (define (logbit? index n) + (logtest (expt 2 index) n)) + + (define bit-set? logbit?) + + (define (copy-bit index from bit) + (if bit + (logior from (expt 2 index)) + (logand from (lognot (expt 2 index))))) + + + ;; # Field of Bits + (define (ash n count) + (if (negative? count) + (let ((k (expt 2 (- count)))) + (if (negative? n) + (+ -1 (truncate-quotient (+ 1 n) k)) + (truncate-quotient n k))) + (* (expt 2 count) n))) + + (define arithmetic-shift ash) + + (define (bit-field n start end) + (logand (lognot (ash -1 (- end start))) + (ash n (- start)))) + + (define (copy-bit-field to from start end) + (bitwise-if (ash (lognot (ash -1 (- end start))) start) + (ash from start) + to)) + + (define (rotate-bit-field n count start end) + (let* ((width (- start end)) + (count (floor-remainder count width)) + (mask (lognot (ash -1 width))) + (zn (logand mask (ash n (- start))))) + (logior (ash (logior (logand mask (ash zn count)) + (ash zn (- count width))) + start) + (logand (lognot (ash mask start)) n)))) + + (define (reverse-bit-field n start end) + (letrec ((bit-reverse + (lambda (k n) + (let loop ((m (if (negative? n) (lognot n) n)) + (k (- k 1)) + (rvs 0)) + (if (negative? k) + (if (negative? n) (lognot rvs) rvs) + (loop (ash m -1) + (- k 1) + (logior (ash rvs 1) (logand 1 m)))))))) + (let* ((width (- start end)) + (mask (lognot (ash -1 width))) + (zn (logand mask (ash n (- start))))) + (logior (ash (bit-reverse width zn) start) + (logand (lognot (ash mask start)) n))))) + + ;; Bits as Booleans + (define (integer->list k . len) + (let ((len (if (null? len) (integer-length k) len))) + (let loop ((k k) (len len) (acc '())) + (if (or (zero? k) (zero? len)) + acc + (loop (floor/ k 2) (- len 1) (cons (if (even? k) #f #t) acc)))))) + + (define (list->integer lst) + (let loop ((lst lst) (acc 0)) + (if (null? lst) + acc + (loop (cdr lst) (+ (* acc 2) (if (car lst) 1 0)))))) + + (define (booleans->integer . args) + (list->integer args)) + + (export logand bitwise-and + logior bitwise-ior + logxor bitwise-xor + lognot bitwise-not + bitwise-if bitwise-merge + logtest any-bits-set? + logcount bit-count + integer-length + log2-binary-factors first-set-bit + logbit? bit-set? + copy-bit + bit-field + copy-bit-field + ash arithmetic-shift + rotate-bit-field + reverse-bit-field + integer->list + list->integer + booleans->integer)) From 219b2447434f60ef513fe88cb82e2a60665132bc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:36:36 +0900 Subject: [PATCH 025/200] initial read implementation --- src/read.c | 717 ++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 492 insertions(+), 225 deletions(-) diff --git a/src/read.c b/src/read.c index 6f1d39ba..daf3f764 100644 --- a/src/read.c +++ b/src/read.c @@ -2,84 +2,427 @@ * See Copyright Notice in picrin.h */ +#include +#include #include "picrin.h" -#include "picrin/parse.h" +#include "picrin/error.h" #include "picrin/pair.h" #include "picrin/string.h" #include "picrin/vector.h" #include "picrin/blob.h" #include "picrin/port.h" -#define YY_NO_UNISTD_H -#include "lex.yy.h" +typedef pic_value (*read_func_t)(pic_state *, struct pic_port *, char); -static pic_value read(int, yyscan_t); +static pic_value read(pic_state *pic, struct pic_port *port, char c); -#define pic (yyget_extra(scanner)->pic) -#define yylval (yyget_extra(scanner)->yylval) -#define yylabels (yyget_extra(scanner)->labels) -#define yymsg (yyget_extra(scanner)->msg) -#define yyjmp (yyget_extra(scanner)->jmp) - -static void -error(const char *msg, yyscan_t scanner) +static noreturn void +read_error(pic_state *pic, const char *msg) { - yymsg = msg; - longjmp(yyjmp, 1); + pic_error(pic, msg); } -static int -gettok(yyscan_t scanner) +static char +skip(struct pic_port *port, char c) { - int tok; - - while ((tok = yylex(scanner)) == tDATUM_COMMENT) { - read(gettok(scanner), scanner); /* discard */ + while (isspace(c)) { + c = xfgetc(port->file); } - return tok; + return c; +} + +static char +next(struct pic_port *port) +{ + char c; + + c = xfgetc(port->file); + + // printf("%c", c); + + return c; +} + +static char +peek(struct pic_port *port) +{ + char c; + + xungetc((c = xfgetc(port->file)), port->file); + + return c; } static pic_value -read_label_set(int i, yyscan_t scanner) +read_comment(pic_state *pic, struct pic_port *port, char c) +{ + do { + c = next(port); + } while (! (c == EOF || c == '\n')); + + return read(pic, port, c); +} + +static pic_value +read_block_comment(pic_state *pic, struct pic_port *port, char c) +{ + char x, y; + + UNUSED(c); + + x = next(port); + y = next(port); + + while (! (x == '|' && y == '#')) { + x = y; + y = next(port); + if (y == EOF) { + break; + } + } + if (y != EOF) { + y = next(port); + } + + return read(pic, port, y); +} + +static pic_value +read_quote(pic_state *pic, struct pic_port *port, char c) +{ + UNUSED(c); + + return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_quasiquote(pic_state *pic, struct pic_port *port, char c) +{ + UNUSED(c); + + return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port))); +} + +static pic_value +read_comma(pic_state *pic, struct pic_port *port, char c) +{ + c = next(port); + + if (c == '@') { + return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port))); + } else { + return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, c)); + } +} + +static pic_value +read_datum_comment(pic_state *pic, struct pic_port *port, char c) +{ + UNUSED(c); + + read(pic, port, next(port)); + + return read(pic, port, next(port)); +} + +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; + + len = 0; + buf = NULL; + + do { + if (len != 0) { + c = next(port); + } + len += 1; + buf = pic_realloc(pic, buf, len); + buf[len - 1] = c; + } while (isalnum(peek(port)) || strchr(TRAIL_SYMBOL, peek(port))); + + buf[len] = '\0'; + sym = pic_intern_cstr(pic, buf); + pic_free(pic, buf); + + return pic_sym_value(sym); +} + +static int +read_uinteger(pic_state *pic, struct pic_port *port, char c) +{ + int n; + + c = skip(port, c); + + if (! isdigit(c)) { + read_error(pic, "expected one or more digits"); + } + + n = c - '0'; + while (isdigit(c = peek(port))) { + next(port); + n = n * 10 + c - '0'; + } + + return n; +} + +static pic_value +read_number(pic_state *pic, struct pic_port *port, char c) +{ + int i, j; + + i = read_uinteger(pic, port, c); + + if (peek(port) == '.') { + next(port); + j = read_uinteger(pic, port, next(port)); + return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%d", j))); + } + else { + return pic_int_value(i); + } + +} + +static pic_value +negate(pic_value n) +{ + if (pic_int_p(n)) { + return pic_int_value(-pic_int(n)); + } else { + return pic_float_value(-pic_float(n)); + } +} + +static pic_value +read_minus(pic_state *pic, struct pic_port *port, char c) +{ + static const char DIGITS[] = "0123456789"; + + /* TODO: -inf.0, -nan.0 */ + + if (strchr(DIGITS, peek(port))) { + return negate(read_number(pic, port, c)); + } + else { + return read_symbol(pic, port, c); + } +} + +static pic_value +read_plus(pic_state *pic, struct pic_port *port, char c) +{ + static const char DIGITS[] = "0123456789"; + + /* TODO: +inf.0, +nan.0 */ + + if (strchr(DIGITS, peek(port))) { + return read_number(pic, port, c); + } + else { + return read_symbol(pic, port, c); + } +} + +static pic_value +read_boolean(pic_state *pic, struct pic_port *port, char c) +{ + UNUSED(pic); + UNUSED(port); + + /* TODO: support #true and #false */ + + if (c == 't') { + return pic_true_value(); + } else { + return pic_false_value(); + } +} + +static pic_value +read_char(pic_state *pic, struct pic_port *port, char c) +{ + UNUSED(pic); + UNUSED(c); + + /* TODO: #\alart, #\space, so on and so on */ + + return pic_char_value(next(port)); +} + +static pic_value +read_string(pic_state *pic, struct pic_port *port, char c) +{ + char *buf; + size_t size, cnt; + pic_str *str; + + size = 256; + buf = pic_alloc(pic, size); + cnt = 0; + + /* TODO: intraline whitespaces */ + + while ((c = next(port)) != '"') { + if (c == '\\') { + switch (c = next(port)) { + case 'a': c = '\a'; break; + case 'b': c = '\b'; break; + case 't': c = '\t'; break; + case 'n': c = '\n'; break; + case 'r': c = '\r'; break; + } + } + buf[cnt++] = c; + if (cnt >= size) { + buf = pic_realloc(pic, buf, size *= 2); + } + } + buf[cnt] = '\0'; + + str = pic_str_new(pic, buf, size); + pic_free(pic, buf); + return pic_obj_value(str); +} + +static pic_value +read_unsigned_blob(pic_state *pic, struct pic_port *port, char c) +{ + int nbits, n; + size_t len; + char *buf; + pic_blob *blob; + + nbits = 0; + + while (isdigit(c = next(port))) { + nbits = 10 * nbits + c - '0'; + } + + if (nbits != 8) { + read_error(pic, "unsupported bytevector bit width"); + } + + if (c != '(') { + read_error(pic, "expected '(' character"); + } + + len = 0; + buf = NULL; + c = next(port); + while ((c = skip(port, c)) != ')') { + n = read_uinteger(pic, port, c); + 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; + c = next(port); + } + + blob = pic_blob_new(pic, buf, len); + pic_free(pic, buf); + return pic_obj_value(blob); +} + +static pic_value +read_pair(pic_state *pic, struct pic_port *port, char c) +{ + char tOPEN = c, tCLOSE = (tOPEN == '(') ? ')' : ']'; + pic_value car, cdr; + + c = skip(port, ' '); + + if (c == tCLOSE) { + return pic_nil_value(); + } + if (c == '.') { + cdr = read(pic, port, next(port)); + + if ((c = skip(port, ' ')) != tCLOSE) { + read_error(pic, "unmatched parenthesis"); + } + return cdr; + } + else { + car = read(pic, port, c); + cdr = read_pair(pic, port, tOPEN); /* FIXME: don't use recursion */ + return pic_cons(pic, car, cdr); + } +} + +static pic_value +read_vector(pic_state *pic, struct pic_port *port, char c) { - int tok; pic_value val; - switch (tok = gettok(scanner)) { - case tLPAREN: - case tLBRACKET: + 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))); +} + +static pic_value +read_label_set(pic_state *pic, struct pic_port *port, int i) +{ + pic_value val; + char c; + + switch (c = skip(port, ' ')) { + case '(': case '[': { pic_value tmp; val = pic_cons(pic, pic_none_value(), pic_none_value()); - xh_put_int(&yylabels, i, &val); + xh_put_int(&pic->rlabels, i, &val); - tmp = read(tok, scanner); + tmp = read(pic, port, c); pic_pair_ptr(val)->car = pic_car(pic, tmp); pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp); return val; } - case tVPAREN: + case '#': { - pic_vec *tmp; + bool vect; - val = pic_obj_value(pic_vec_new(pic, 0)); + if (peek(port) == '(') { + vect = true; + } else { + vect = false; + } - xh_put_int(&yylabels, i, &val); + if (vect) { + pic_vec *tmp; - tmp = pic_vec_ptr(read(tok, scanner)); - SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); - SWAP(size_t, tmp->len, pic_vec_ptr(val)->len); + val = pic_obj_value(pic_vec_new(pic, 0)); - return val; + xh_put_int(&pic->rlabels, i, &val); + + tmp = pic_vec_ptr(read(pic, port, c)); + SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); + SWAP(size_t, tmp->len, pic_vec_ptr(val)->len); + + return val; + } + + FALLTHROUGH; } default: { - val = read(tok, scanner); + val = read(pic, port, c); - xh_put_int(&yylabels, i, &val); + xh_put_int(&pic->rlabels, i, &val); return val; } @@ -87,239 +430,163 @@ read_label_set(int i, yyscan_t scanner) } static pic_value -read_label_ref(int i, yyscan_t scanner) +read_label_ref(pic_state *pic, struct pic_port *port, int i) { xh_entry *e; - e = xh_get_int(&yylabels, i); + UNUSED(port); + + e = xh_get_int(&pic->rlabels, i); if (! e) { - error("label of given index not defined", scanner); + read_error(pic, "label of given index not defined"); } return xh_val(e, pic_value); } static pic_value -read_pair(int tOPEN, yyscan_t scanner) +read_label(pic_state *pic, struct pic_port *port, char c) { - int tok, tCLOSE = (tOPEN == tLPAREN) ? tRPAREN : tRBRACKET; - pic_value car, cdr; + int i; - tok = gettok(scanner); - if (tok == tCLOSE) { - return pic_nil_value(); - } - if (tok == tDOT) { - cdr = read(gettok(scanner), scanner); + i = 0; + do { + i = i * 10 + c; + } while (isdigit(c = next(port))); - if (gettok(scanner) != tCLOSE) { - error("unmatched parenthesis", scanner); - } - return cdr; + if (c == '=') { + return read_label_set(pic, port, i); } - else { - car = read(tok, scanner); - cdr = read_pair(tOPEN, scanner); - return pic_cons(pic, car, cdr); + if (c == '#') { + return read_label_ref(pic, port, i); } -} - -static pic_vec * -read_vect(yyscan_t scanner) -{ - int tok; - pic_value val; - - val = pic_nil_value(); - while ((tok = gettok(scanner)) != tRPAREN) { - val = pic_cons(pic, read(tok, scanner), val); - } - return pic_vec_new_from_list(pic, pic_reverse(pic, val)); + read_error(pic, "broken label expression"); } static pic_value -read_abbrev(pic_sym sym, yyscan_t scanner) +read_dispatch(pic_state *pic, struct pic_port *port, char c) { - return pic_cons(pic, pic_sym_value(sym), pic_cons(pic, read(gettok(scanner), scanner), pic_nil_value())); + c = next(port); + + switch (c) { + case '!': + return read_comment(pic, port, c); + case '|': + return read_block_comment(pic, port, c); + case ';': + return read_datum_comment(pic, port, c); + case 't': case 'f': + return read_boolean(pic, port, c); + case '\\': + return read_char(pic, port, c); + case '(': + return read_vector(pic, port, c); + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + return read_label(pic, port, c); + case 'u': + return read_unsigned_blob(pic, port, c); + default: + read_error(pic, "unexpected dispatch character"); + } } static pic_value -read_datum(int tok, yyscan_t scanner) +read(pic_state *pic, struct pic_port *port, char c) { - pic_value val; + c = skip(port, c); - switch (tok) { - case tLABEL_SET: - return read_label_set(yylval.i, scanner); - - case tLABEL_REF: - return read_label_ref(yylval.i, scanner); - - case tSYMBOL: - return pic_symbol_value(pic_intern(pic, yylval.buf.dat, yylval.buf.len)); - - case tINT: - return pic_int_value(yylval.i); - - case tFLOAT: - return pic_float_value(yylval.f); - - case tBOOLEAN: - return pic_bool_value(yylval.i); - - case tCHAR: - return pic_char_value(yylval.c); - - case tSTRING: - val = pic_obj_value(pic_str_new(pic, yylval.buf.dat, yylval.buf.len)); - pic_free(pic, yylval.buf.dat); - return val; - - case tBYTEVECTOR: - val = pic_obj_value(pic_blob_new(pic, yylval.buf.dat, yylval.buf.len)); - pic_free(pic, yylval.buf.dat); - return val; - - case tLPAREN: - case tLBRACKET: - return read_pair(tok, scanner); - - case tVPAREN: - return pic_obj_value(read_vect(scanner)); - - case tQUOTE: - return read_abbrev(pic->sQUOTE, scanner); - - case tQUASIQUOTE: - return read_abbrev(pic->sQUASIQUOTE, scanner); - - case tUNQUOTE: - return read_abbrev(pic->sUNQUOTE, scanner); - - case tUNQUOTE_SPLICING: - return read_abbrev(pic->sUNQUOTE_SPLICING, scanner); - - case tRPAREN: - error("unexpected close parenthesis", scanner); - - case tRBRACKET: - error("unexpected close bracket", scanner); - - case tDOT: - error("unexpected '.'", scanner); - - case tEOF: - error(NULL, scanner); + if (c == EOF) { + read_error(pic, "unexpected EOF"); } - UNREACHABLE(); -} - -static pic_value -read(int tok, yyscan_t scanner) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = read_datum(tok, scanner); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; + switch (c) { + case ';': + return read_comment(pic, port, c); + case '#': + return read_dispatch(pic, port, c); + case '\'': + return read_quote(pic, port, c); + case '`': + return read_quasiquote(pic, port, c); + case ',': + return read_comma(pic, port, c); + case '"': + return read_string(pic, port, c); + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + return read_number(pic, port, c); + case '+': + return read_plus(pic, port, c); + case '-': + return read_minus(pic, port, c); + case '(': case '[': + return read_pair(pic, port, c); + default: + return read_symbol(pic, port, c); + } } pic_value -read_one(yyscan_t scanner) +pic_read(pic_state *pic, struct pic_port *port) { - int tok; + char c; - if (setjmp(yyjmp) != 0) { - pic_errorf(pic, "%s", yymsg ? yymsg : "unexpected EOF"); + c = next(port); + + if (c == EOF) { + return pic_eof_object(); } - if ((tok = gettok(scanner)) == tEOF) { + return read(pic, port, c); +} + +pic_value +pic_read_cstr(pic_state *pic, const char *str) +{ + struct pic_port *port; + + port = pic_open_input_string(pic, str); + + return pic_read(pic, port); +} + +static pic_value +pic_parse(pic_state *pic, struct pic_port *port) +{ + pic_value val, acc; + + pic_try { + acc = pic_nil_value(); + while (! pic_eof_p(val = pic_read(pic, port))) { + pic_push(pic, val, acc); + } + } + pic_catch { return pic_undef_value(); } - return read(tok, scanner); -} -pic_list -read_many(yyscan_t scanner) -{ - int tok; - pic_value vals; - - if (setjmp(yyjmp) != 0) { - if (yymsg) { - pic_errorf(pic, "%s", yymsg); - } - return pic_undef_value(); /* incomplete string */ - } - - vals = pic_nil_value(); - while ((tok = gettok(scanner)) != tEOF) { - vals = pic_cons(pic, read(tok, scanner), vals); - } - return pic_reverse(pic, vals); -} - -#undef pic - -pic_value -pic_read(pic_state *pic, const char *cstr) -{ - yyscan_t scanner; - struct parser_control ctrl; - pic_value val; - - ctrl.pic = pic; - xh_init_int(&ctrl.labels, sizeof(pic_value)); - yylex_init_extra(&ctrl, &scanner); - yy_scan_string(cstr, scanner); - - val = read_one(scanner); - - yylex_destroy(scanner); - xh_destroy(&ctrl.labels); - - return val; + return pic_reverse(pic, acc); } pic_list pic_parse_file(pic_state *pic, FILE *file) { - yyscan_t scanner; - struct parser_control ctrl; - pic_value vals; + struct pic_port *port; - ctrl.pic = pic; - xh_init_int(&ctrl.labels, sizeof(pic_value)); - yylex_init_extra(&ctrl, &scanner); - yyset_in(file, scanner); + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xfpopen(file); + port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; - vals = read_many(scanner); - - yylex_destroy(scanner); - xh_destroy(&ctrl.labels); - - return vals; + return pic_parse(pic, port); } pic_list -pic_parse_cstr(pic_state *pic, const char *cstr) +pic_parse_cstr(pic_state *pic, const char *str) { - yyscan_t scanner; - struct parser_control ctrl; - pic_value vals; + struct pic_port *port; - ctrl.pic = pic; - xh_init_int(&ctrl.labels, sizeof(pic_value)); - yylex_init_extra(&ctrl, &scanner); - yy_scan_string(cstr, scanner); + port = pic_open_input_string(pic, str); - vals = read_many(scanner); - - yylex_destroy(scanner); - xh_destroy(&ctrl.labels); - - return vals; + return pic_parse(pic, port); } From 0b087b785eb0638f7a6435e09b556c3395f23ac7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:37:24 +0900 Subject: [PATCH 026/200] store rlabels in global state --- include/picrin.h | 2 ++ src/state.c | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index d194de1f..8522ef5b 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -100,6 +100,8 @@ typedef struct { pic_value lib_tbl; struct pic_lib *lib; + xhash rlabels; + jmp_buf *jmp; struct pic_error *err; struct pic_jmpbuf *try_jmps; diff --git a/src/state.c b/src/state.c index a9a13ba8..61cd2f41 100644 --- a/src/state.c +++ b/src/state.c @@ -64,6 +64,9 @@ pic_open(int argc, char *argv[], char **envp) pic->lib_tbl = pic_nil_value(); pic->lib = NULL; + /* reader */ + xh_init_int(&pic->rlabels, sizeof(pic_value)); + /* error handling */ pic->jmp = NULL; pic->err = NULL; @@ -154,6 +157,7 @@ pic_close(pic_state *pic) xh_destroy(&pic->syms); xh_destroy(&pic->global_tbl); xh_destroy(&pic->macros); + xh_destroy(&pic->rlabels); /* free GC arena */ free(pic->arena); From da4a4fd4490660ef02b19ab74d89da1de1ec27ed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:39:04 +0900 Subject: [PATCH 027/200] api changes of reader/parser --- include/picrin.h | 5 +++-- src/codegen.c | 2 +- src/state.c | 4 ++-- tools/main.c | 22 +++++++++++----------- 4 files changed, 17 insertions(+), 16 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 8522ef5b..0e673dca 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -152,7 +152,8 @@ bool pic_interned_p(pic_state *, pic_sym); char *pic_strdup(pic_state *, const char *); char *pic_strndup(pic_state *, const char *, size_t); -pic_value pic_read(pic_state *, const char *); +pic_value pic_read(pic_state *, struct pic_port *); +pic_value pic_read_cstr(pic_state *, const char *); pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */ pic_list pic_parse_cstr(pic_state *, const char *); @@ -180,7 +181,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value); #define pic_deflibrary_helper__(i, prev_lib, spec) \ for (int i = 0; ! i; ) \ for (struct pic_lib *prev_lib; ! i; ) \ - for ((prev_lib = pic->lib), pic_make_library(pic, pic_read(pic, spec)), pic_in_library(pic, pic_read(pic, spec)); ! i++; pic->lib = prev_lib) + for ((prev_lib = pic->lib), pic_make_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib) void pic_import(pic_state *, pic_value); void pic_export(pic_state *, pic_sym); diff --git a/src/codegen.c b/src/codegen.c index f18062b0..d097896f 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -68,7 +68,7 @@ new_analyze_state(pic_state *pic) state->pic = pic; state->scope = NULL; - stdlib = pic_find_library(pic, pic_read(pic, "(scheme base)")); + stdlib = pic_find_library(pic, pic_read_cstr(pic, "(scheme base)")); /* native VM procedures */ register_renamed_symbol(pic, state, rCONS, stdlib, "cons"); diff --git a/src/state.c b/src/state.c index 61cd2f41..63a25254 100644 --- a/src/state.c +++ b/src/state.c @@ -119,8 +119,8 @@ pic_open(int argc, char *argv[], char **envp) pic_init_core(pic); /* set library */ - pic_make_library(pic, pic_read(pic, "(picrin user)")); - pic_in_library(pic, pic_read(pic, "(picrin user)")); + pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); + pic_in_library(pic, pic_read_cstr(pic, "(picrin user)")); return pic; } diff --git a/tools/main.c b/tools/main.c index 2d3a8cfd..83f7bd40 100644 --- a/tools/main.c +++ b/tools/main.c @@ -39,16 +39,16 @@ import_repllib(pic_state *pic) { int ai = pic_gc_arena_preserve(pic); - pic_import(pic, pic_read(pic, "(scheme base)")); - pic_import(pic, pic_read(pic, "(scheme load)")); - pic_import(pic, pic_read(pic, "(scheme process-context)")); - pic_import(pic, pic_read(pic, "(scheme write)")); - pic_import(pic, pic_read(pic, "(scheme file)")); - pic_import(pic, pic_read(pic, "(scheme inexact)")); - pic_import(pic, pic_read(pic, "(scheme cxr)")); - pic_import(pic, pic_read(pic, "(scheme lazy)")); - pic_import(pic, pic_read(pic, "(scheme time)")); - pic_import(pic, pic_read(pic, "(picrin macro)")); + pic_import(pic, pic_read_cstr(pic, "(scheme base)")); + pic_import(pic, pic_read_cstr(pic, "(scheme load)")); + pic_import(pic, pic_read_cstr(pic, "(scheme process-context)")); + pic_import(pic, pic_read_cstr(pic, "(scheme write)")); + pic_import(pic, pic_read_cstr(pic, "(scheme file)")); + pic_import(pic, pic_read_cstr(pic, "(scheme inexact)")); + pic_import(pic, pic_read_cstr(pic, "(scheme cxr)")); + pic_import(pic, pic_read_cstr(pic, "(scheme lazy)")); + pic_import(pic, pic_read_cstr(pic, "(scheme time)")); + pic_import(pic, pic_read_cstr(pic, "(picrin macro)")); #if DEBUG puts("* imported repl libraries"); @@ -289,7 +289,7 @@ main(int argc, char *argv[], char **envp) parse_opt(argc, argv); if (mode == INTERACTIVE_MODE || mode == ONE_LINER_MODE) { - import_repllib(pic); + // import_repllib(pic); } switch (mode) { From 83a13d4ca4d4f71913c8a5799ff08581dde25715 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:39:30 +0900 Subject: [PATCH 028/200] remove flex dependency --- cmake/FindFLEX.cmake | 179 -------------------------------- include/picrin/parse.h | 46 --------- src/CMakeLists.txt | 7 +- src/scan.l | 230 ----------------------------------------- 4 files changed, 1 insertion(+), 461 deletions(-) delete mode 100644 cmake/FindFLEX.cmake delete mode 100644 include/picrin/parse.h delete mode 100644 src/scan.l diff --git a/cmake/FindFLEX.cmake b/cmake/FindFLEX.cmake deleted file mode 100644 index c56e8eda..00000000 --- a/cmake/FindFLEX.cmake +++ /dev/null @@ -1,179 +0,0 @@ -# - Find flex executable and provides a macro to generate custom build rules -# -# The module defines the following variables: -# FLEX_FOUND - true is flex executable is found -# FLEX_EXECUTABLE - the path to the flex executable -# FLEX_VERSION - the version of flex -# FLEX_LIBRARIES - The flex libraries -# -# The minimum required version of flex can be specified using the -# standard syntax, e.g. FIND_PACKAGE(FLEX 2.5.13) -# -# -# If flex is found on the system, the module provides the macro: -# FLEX_TARGET(Name FlexInput FlexOutput [COMPILE_FLAGS ]) -# which creates a custom command to generate the file from -# the file. If COMPILE_FLAGS option is specified, the next -# parameter is added to the flex command line. Name is an alias used to -# get details of this custom command. Indeed the macro defines the -# following variables: -# FLEX_${Name}_DEFINED - true is the macro ran successfully -# FLEX_${Name}_OUTPUTS - the source file generated by the custom rule, an -# alias for FlexOutput -# FLEX_${Name}_INPUT - the flex source file, an alias for ${FlexInput} -# -# Flex scanners oftenly use tokens defined by Bison: the code generated -# by Flex depends of the header generated by Bison. This module also -# defines a macro: -# ADD_FLEX_BISON_DEPENDENCY(FlexTarget BisonTarget) -# which adds the required dependency between a scanner and a parser -# where and are the first parameters of -# respectively FLEX_TARGET and BISON_TARGET macros. -# -# ==================================================================== -# Example: -# -# find_package(BISON) -# find_package(FLEX) -# -# BISON_TARGET(MyParser parser.y ${CMAKE_CURRENT_BINARY_DIR}/parser.cpp -# FLEX_TARGET(MyScanner lexer.l ${CMAKE_CURRENT_BIANRY_DIR}/lexer.cpp) -# ADD_FLEX_BISON_DEPENDENCY(MyScanner MyParser) -# -# include_directories(${CMAKE_CURRENT_BINARY_DIR}) -# add_executable(Foo -# Foo.cc -# ${BISON_MyParser_OUTPUTS} -# ${FLEX_MyScanner_OUTPUTS} -# ) -# ==================================================================== - -#============================================================================= -# Copyright 2009 Kitware, Inc. -# Copyright 2006 Tristan Carel -# Modified 2010 by Jon Siwek, backporting for CMake 2.6 compat -# -# Distributed under the OSI-approved BSD License (the "License"): -# CMake - Cross Platform Makefile Generator -# Copyright 2000-2009 Kitware, Inc., Insight Software Consortium -# All rights reserved. - -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions -# are met: -# -# * Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. -# -# * Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. -# -# * Neither the names of Kitware, Inc., the Insight Software Consortium, -# nor the names of their contributors may be used to endorse or promote -# products derived from this software without specific prior written -# permission. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -# -# This software is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -# See the License for more information. -#============================================================================= - -FIND_PROGRAM(FLEX_EXECUTABLE flex DOC "path to the flex executable") -MARK_AS_ADVANCED(FLEX_EXECUTABLE) - -FIND_LIBRARY(FL_LIBRARY NAMES fl - DOC "path to the fl library") -MARK_AS_ADVANCED(FL_LIBRARY) -SET(FLEX_LIBRARIES ${FL_LIBRARY}) - -IF(FLEX_EXECUTABLE) - - EXECUTE_PROCESS(COMMAND ${FLEX_EXECUTABLE} --version - OUTPUT_VARIABLE FLEX_version_output - ERROR_VARIABLE FLEX_version_error - RESULT_VARIABLE FLEX_version_result - OUTPUT_STRIP_TRAILING_WHITESPACE) - IF(NOT ${FLEX_version_result} EQUAL 0) - IF(FLEX_FIND_REQUIRED) - MESSAGE(SEND_ERROR "Command \"${FLEX_EXECUTABLE} --version\" failed with output:\n${FLEX_version_output}\n${FLEX_version_error}") - ELSE() - MESSAGE("Command \"${FLEX_EXECUTABLE} --version\" failed with output:\n${FLEX_version_output}\n${FLEX_version_error}\nFLEX_VERSION will not be available") - ENDIF() - ELSE() - STRING(REGEX REPLACE "^flex (.*)$" "\\1" - FLEX_VERSION "${FLEX_version_output}") - ENDIF() - - #============================================================ - # FLEX_TARGET (public macro) - #============================================================ - # - MACRO(FLEX_TARGET Name Input Output) - SET(FLEX_TARGET_usage "FLEX_TARGET( [COMPILE_FLAGS ]") - IF(${ARGC} GREATER 3) - IF(${ARGC} EQUAL 5) - IF("${ARGV3}" STREQUAL "COMPILE_FLAGS") - SET(FLEX_EXECUTABLE_opts "${ARGV4}") - SEPARATE_ARGUMENTS(FLEX_EXECUTABLE_opts) - ELSE() - MESSAGE(SEND_ERROR ${FLEX_TARGET_usage}) - ENDIF() - ELSE() - MESSAGE(SEND_ERROR ${FLEX_TARGET_usage}) - ENDIF() - ENDIF() - - ADD_CUSTOM_COMMAND(OUTPUT ${Output} - COMMAND ${FLEX_EXECUTABLE} - ARGS ${FLEX_EXECUTABLE_opts} -o${Output} ${Input} - DEPENDS ${Input} - COMMENT "[FLEX][${Name}] Building scanner with flex ${FLEX_VERSION}" - WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) - - SET(FLEX_${Name}_DEFINED TRUE) - SET(FLEX_${Name}_OUTPUTS ${Output}) - SET(FLEX_${Name}_INPUT ${Input}) - SET(FLEX_${Name}_COMPILE_FLAGS ${FLEX_EXECUTABLE_opts}) - ENDMACRO(FLEX_TARGET) - #============================================================ - - - #============================================================ - # ADD_FLEX_BISON_DEPENDENCY (public macro) - #============================================================ - # - MACRO(ADD_FLEX_BISON_DEPENDENCY FlexTarget BisonTarget) - - IF(NOT FLEX_${FlexTarget}_OUTPUTS) - MESSAGE(SEND_ERROR "Flex target `${FlexTarget}' does not exists.") - ENDIF() - - IF(NOT BISON_${BisonTarget}_OUTPUT_HEADER) - MESSAGE(SEND_ERROR "Bison target `${BisonTarget}' does not exists.") - ENDIF() - - SET_SOURCE_FILES_PROPERTIES(${FLEX_${FlexTarget}_OUTPUTS} - PROPERTIES OBJECT_DEPENDS ${BISON_${BisonTarget}_OUTPUT_HEADER}) - ENDMACRO(ADD_FLEX_BISON_DEPENDENCY) - #============================================================ - -ENDIF(FLEX_EXECUTABLE) - -INCLUDE(FindPackageHandleStandardArgs) -FIND_PACKAGE_HANDLE_STANDARD_ARGS(FLEX FLEX_EXECUTABLE - FLEX_VERSION) - -# FindFLEX.cmake ends here diff --git a/include/picrin/parse.h b/include/picrin/parse.h deleted file mode 100644 index 0451d201..00000000 --- a/include/picrin/parse.h +++ /dev/null @@ -1,46 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PARSE_H__ -#define PICRIN_PARSE_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -enum { - tEOF = 0, - tLABEL_SET, tLABEL_REF, tDATUM_COMMENT, - tLPAREN, tRPAREN, tLBRACKET, tRBRACKET, tDOT, tVPAREN, - tQUOTE, tQUASIQUOTE, tUNQUOTE, tUNQUOTE_SPLICING, - tINT, tBOOLEAN, - tFLOAT, - tSYMBOL, tSTRING, - tCHAR, - tBYTEVECTOR, -}; - -typedef union YYSTYPE { - int i; - double f; - struct { - char *dat; - size_t len; - } buf; - char c; -} YYSTYPE; - -struct parser_control { - pic_state *pic; - YYSTYPE yylval; - xhash labels; - jmp_buf jmp; - const char *msg; -}; - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 7a727e9b..9318f442 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,8 +1,3 @@ -# flex -find_package(FLEX REQUIRED) -flex_target(scan src/scan.l ${PROJECT_SOURCE_DIR}/src/lex.yy.c COMPILE_FLAGS --header-file="src/lex.yy.h") -set_directory_properties(PROPERTIES ADDITIONAL_MAKE_CLEAN_FILES ${PROJECT_SOURCE_DIR}/src/lex.yy.h) - # xfile set(XFILE_SOURCES extlib/xfile/xfile.c) @@ -18,7 +13,7 @@ add_custom_command( # build! file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c) -add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${FLEX_scan_OUTPUTS} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES}) +add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES}) target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES}) # install diff --git a/src/scan.l b/src/scan.l deleted file mode 100644 index 747f31a7..00000000 --- a/src/scan.l +++ /dev/null @@ -1,230 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -%{ -#include "picrin.h" -#include "picrin/parse.h" - -#define yylval (yyextra->yylval) - -#define YY_NO_UNISTD_H - -/* NOTE: - * An internal function `yy_fatal_error` takes yyscanner for its second - * argument but doesn't use it. This invokes a `unused variable` compiler - * warning and it became super unusable if `-Werror` is turned on the system. - * Since there's no flag to switch `yy_fatal_error` off and replace it with - * a user-defined function, we modify this macro constant to use yyscanner - * at least once avoiding get flex affected in any condition. - */ -#define YY_EXIT_FAILURE ( (void)yyscanner, 2 ) -%} - -%option reentrant - -%option noyyalloc -%option noyyrealloc -%option noyyfree -%option noinput -%option nounput -%option noyywrap - -%option extra-type="struct parser_control *" -%option never-interactive - - /* shebang */ -shebang #!.*$ - - /* comment */ -comment ;.*$ - - /* boolean */ -boolean #t|#f|#true|#false - - /* symbol */ -identifier [a-z0-9A-Z+/*!$%&:@^~?<=>_.-]+ - - /* number */ -digit [0-9] -real {sign}{ureal}|{infnan} -ureal {uinteger}|\.{digit}+|{digit}+\.{digit}* -integer {sign}{uinteger} -uinteger {digit}+ -sign [+-]? -infnan "+inf.0"|"-inf.0"|"+nan.0"|"-nan.0" - - /* char */ -%x CHAR - - /* string */ -%x STRING - - /* bytevector */ -%x BYTEVECTOR - - /* block comment */ -%x BLOCK_COMMENT - - /* datum label */ -label #{uinteger} -%x DATUM_LABEL - -%% - -[ \t\n\r] /* skip whitespace */ -{comment} /* skip comment */ -{shebang} /* skip shebang */ - -"#|" { - BEGIN(BLOCK_COMMENT); - yylval.i = 0; -} -"#|" { - yylval.i++; -} -"|#" { - if (yylval.i == 0) - BEGIN(INITIAL); - else - yylval.i--; -} -.|\n { - /* skip block comment */ -} - -{label} { - BEGIN(DATUM_LABEL); - yylval.i = atoi(yytext + 1); -} -= { - BEGIN(INITIAL); - return tLABEL_SET; -} -# { - BEGIN(INITIAL); - return tLABEL_REF; -} - -"#;" return tDATUM_COMMENT; -"." return tDOT; -"(" return tLPAREN; -")" return tRPAREN; -"[" return tLBRACKET; -"]" return tRBRACKET; -"#(" return tVPAREN; -"'" return tQUOTE; -"`" return tQUASIQUOTE; -"," return tUNQUOTE; -",@" return tUNQUOTE_SPLICING; - -{boolean} { - yylval.i = (yytext[1] == 't'); - return tBOOLEAN; -} - -{integer} { - yylval.i = atoi(yytext); - return tINT; -} - -{real} { - yylval.f = atof(yytext); - return tFLOAT; -} - -{identifier} { - yylval.buf.dat = yytext; - yylval.buf.len = yyleng; - return tSYMBOL; -} - -"\"" { - BEGIN(STRING); - yylval.buf.len = 0; - yylval.buf.dat = yyalloc(yylval.buf.len + 1, yyscanner); - strcpy(yylval.buf.dat, ""); -} -[^\\"]+ { - yylval.buf.len += yyleng; - yylval.buf.dat = yyrealloc(yylval.buf.dat, yylval.buf.len + 1, yyscanner); - strcpy(yylval.buf.dat + yylval.buf.len - yyleng, yytext); -} -\\. { - yylval.buf.len += 1; - yylval.buf.dat = yyrealloc(yylval.buf.dat, yylval.buf.len + 1, yyscanner); - yylval.buf.dat[yylval.buf.len] = '\0'; - - switch (yytext[yyleng - 1]) { - case 'a': yylval.buf.dat[yylval.buf.len - 1] = '\a'; break; - case 'b': yylval.buf.dat[yylval.buf.len - 1] = '\b'; break; - case 't': yylval.buf.dat[yylval.buf.len - 1] = '\t'; break; - case 'n': yylval.buf.dat[yylval.buf.len - 1] = '\n'; break; - case 'r': yylval.buf.dat[yylval.buf.len - 1] = '\r'; break; - default: yylval.buf.dat[yylval.buf.len - 1] = yytext[yyleng - 1]; break; - } -} -\\[:blank:]*\n[:blank:]* { - /* skip intraline whitespaces */ -} -\" { - BEGIN(INITIAL); - return tSTRING; -} - -#\\ { - BEGIN(CHAR); -} -alarm { yylval.c = '\a'; BEGIN(INITIAL); return tCHAR; } -backspace { yylval.c = '\b'; BEGIN(INITIAL); return tCHAR; } -delete { yylval.c = 0x7f; BEGIN(INITIAL); return tCHAR; } -escape { yylval.c = 0x1b; BEGIN(INITIAL); return tCHAR; } -newline { yylval.c = '\n'; BEGIN(INITIAL); return tCHAR; } -null { yylval.c = '\0'; BEGIN(INITIAL); return tCHAR; } -return { yylval.c = '\r'; BEGIN(INITIAL); return tCHAR; } -space { yylval.c = ' '; BEGIN(INITIAL); return tCHAR; } -tab { yylval.c = '\t'; BEGIN(INITIAL); return tCHAR; } -. { yylval.c = yytext[0]; BEGIN(INITIAL); return tCHAR; } - -"#u8(" { - BEGIN(BYTEVECTOR); - yylval.buf.len = 0; - yylval.buf.dat = NULL; -} -[ \r\n\t] { - /* skip whitespace */ -} -{uinteger} { - int i = atoi(yytext); - if (0 > i || i > 255) { - yyfree(yylval.buf.dat, yyscanner); - REJECT; - } - yylval.buf.len += 1; - yylval.buf.dat = yyrealloc(yylval.buf.dat, yylval.buf.len, yyscanner); - yylval.buf.dat[yylval.buf.len - 1] = (char)i; -} -")" { - BEGIN(INITIAL); - return tBYTEVECTOR; -} - -%% - -void * -yyalloc(size_t bytes, yyscan_t yyscanner) -{ - return pic_alloc(yyget_extra(yyscanner)->pic, bytes); -} - -void * -yyrealloc(void *ptr, size_t bytes, yyscan_t yyscanner) -{ - return pic_realloc(yyget_extra(yyscanner)->pic, ptr, bytes); -} - -void -yyfree(void * ptr, yyscan_t yyscanner) -{ - return pic_free(yyget_extra(yyscanner)->pic, ptr); -} From 0e66144a4d3eeb11570b17286bc7ab7bbf088c03 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:39:40 +0900 Subject: [PATCH 029/200] add pic_open_input_string --- include/picrin/port.h | 1 + src/port.c | 26 ++++++++++++++++++-------- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/include/picrin/port.h b/include/picrin/port.h index 9fabf8ed..e51d8759 100644 --- a/include/picrin/port.h +++ b/include/picrin/port.h @@ -37,6 +37,7 @@ struct pic_port *pic_stdin(pic_state *); struct pic_port *pic_stdout(pic_state *); struct pic_port *pic_stderr(pic_state *); +struct pic_port *pic_open_input_string(pic_state *, const char *); struct pic_port *pic_open_output_string(pic_state *); struct pic_string *pic_get_output_string(pic_state *, struct pic_port *); diff --git a/src/port.c b/src/port.c index 419b8aee..6febdf8e 100644 --- a/src/port.c +++ b/src/port.c @@ -54,6 +54,23 @@ port_new_stdport(pic_state *pic, xFILE *file, short dir) return pic_obj_value(port); } +struct pic_port * +pic_open_input_string(pic_state *pic, const char *str) +{ + struct pic_port *port; + + port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); + port->file = xmopen(); + port->flags = PIC_PORT_IN | PIC_PORT_TEXT; + port->status = PIC_PORT_OPEN; + + xfputs(str, port->file); + xfflush(port->file); + xrewind(port->file); + + return port; +} + struct pic_port * pic_open_output_string(pic_state *pic) { @@ -268,14 +285,7 @@ pic_port_open_input_string(pic_state *pic) pic_get_args(pic, "z", &str); - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); - port->flags = PIC_PORT_IN | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - - xfputs(str, port->file); - xfflush(port->file); - xrewind(port->file); + port = pic_open_input_string(pic, str); return pic_obj_value(port); } From 4087ebb4d6c3ddcc48778b0d89ed9723543ae196 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:39:45 +0900 Subject: [PATCH 030/200] add pic_eof_p --- include/picrin/value.h | 1 + 1 file changed, 1 insertion(+) diff --git a/include/picrin/value.h b/include/picrin/value.h index 44dd0763..a569cc71 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -158,6 +158,7 @@ typedef struct pic_blob pic_blob; #define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT) #define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL) #define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR) +#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF) #define pic_test(v) (! pic_false_p(v)) From 08f0fbd3d3afc9dfc590ef782b3029ae354ca8c0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 15:40:21 +0900 Subject: [PATCH 031/200] [experimental] update xfile --- extlib/xfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/xfile b/extlib/xfile index c7d08eb1..db624568 160000 --- a/extlib/xfile +++ b/extlib/xfile @@ -1 +1 @@ -Subproject commit c7d08eb1abc829f3380991d3754a1ef6ce539c4d +Subproject commit db624568950ae32b348f9178a25c2928ee544e72 From b646948e9b67be73cc201d1056de8eaf414110ed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 17:22:15 +0900 Subject: [PATCH 032/200] allocate buffer in +1 size --- src/port.c | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/port.c b/src/port.c index 6febdf8e..168b5cce 100644 --- a/src/port.c +++ b/src/port.c @@ -87,19 +87,20 @@ pic_open_output_string(pic_state *pic) struct pic_string * pic_get_output_string(pic_state *pic, struct pic_port *port) { - long endpos; + long size; char *buf; /* get endpos */ xfflush(port->file); - endpos = xftell(port->file); + size = xftell(port->file); xrewind(port->file); /* copy to buf */ - buf = (char *)pic_alloc(pic, endpos); - xfread(buf, 1, endpos, port->file); + buf = (char *)pic_alloc(pic, size + 1); + buf[size] = 0; + xfread(buf, size, 1, port->file); - return pic_str_new(pic, buf, endpos); + return pic_str_new(pic, buf, size); } void From 72db056f1e34c828ffe52c00f6579ac4c631b381 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 17:24:33 +0900 Subject: [PATCH 033/200] update xfile --- extlib/xfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/xfile b/extlib/xfile index db624568..a0b1fe61 160000 --- a/extlib/xfile +++ b/extlib/xfile @@ -1 +1 @@ -Subproject commit db624568950ae32b348f9178a25c2928ee544e72 +Subproject commit a0b1fe6108b84b94bb35340b232911dc760c4269 From 6eec3629e9cd949545a9ff0be090100cd4301020 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 17:24:42 +0900 Subject: [PATCH 034/200] use xprintf instead of printf --- src/write.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/write.c b/src/write.c index 952bf436..4aae7e44 100644 --- a/src/write.c +++ b/src/write.c @@ -440,8 +440,8 @@ pic_printf(pic_state *pic, const char *fmt, ...) va_end(ap); - printf("%s", pic_str_cstr(str)); - fflush(stdout); + xprintf("%s", pic_str_cstr(str)); + xfflush(xstdout); } static pic_value From a90330d3d92f67bde3252b03abfa24a87db05679 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 18:06:48 +0900 Subject: [PATCH 035/200] comment readers should return undef values to report continuablility to the parent function --- src/read.c | 66 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 27 deletions(-) diff --git a/src/read.c b/src/read.c index daf3f764..8393b611 100644 --- a/src/read.c +++ b/src/read.c @@ -34,13 +34,7 @@ skip(struct pic_port *port, char c) static char next(struct pic_port *port) { - char c; - - c = xfgetc(port->file); - - // printf("%c", c); - - return c; + return xfgetc(port->file); } static char @@ -56,11 +50,13 @@ peek(struct pic_port *port) static pic_value read_comment(pic_state *pic, struct pic_port *port, char c) { + UNUSED(pic); + do { c = next(port); } while (! (c == EOF || c == '\n')); - return read(pic, port, c); + return pic_undef_value(); } static pic_value @@ -68,6 +64,7 @@ read_block_comment(pic_state *pic, struct pic_port *port, char c) { char x, y; + UNUSED(pic); UNUSED(c); x = next(port); @@ -80,11 +77,18 @@ read_block_comment(pic_state *pic, struct pic_port *port, char c) break; } } - if (y != EOF) { - y = next(port); - } - return read(pic, port, y); + return pic_undef_value(); +} + +static pic_value +read_datum_comment(pic_state *pic, struct pic_port *port, char c) +{ + UNUSED(c); + + read(pic, port, next(port)); + + return pic_undef_value(); } static pic_value @@ -115,16 +119,6 @@ read_comma(pic_state *pic, struct pic_port *port, char c) } } -static pic_value -read_datum_comment(pic_state *pic, struct pic_port *port, char c) -{ - UNUSED(c); - - read(pic, port, next(port)); - - return read(pic, port, next(port)); -} - static pic_value read_symbol(pic_state *pic, struct pic_port *port, char c) { @@ -491,7 +485,7 @@ read_dispatch(pic_state *pic, struct pic_port *port, char c) } static pic_value -read(pic_state *pic, struct pic_port *port, char c) +read_nullable(pic_state *pic, struct pic_port *port, char c) { c = skip(port, c); @@ -526,6 +520,28 @@ read(pic_state *pic, struct pic_port *port, char c) } } +static pic_value +read(pic_state *pic, struct pic_port *port, char c) +{ + pic_value val; + + retry: + c = skip(port, c); + + if (c == EOF) { + return pic_eof_object(); + } + + val = read_nullable(pic, port, c); + + if (pic_undef_p(val)) { + c = next(port); + goto retry; + } + + return val; +} + pic_value pic_read(pic_state *pic, struct pic_port *port) { @@ -533,10 +549,6 @@ pic_read(pic_state *pic, struct pic_port *port) c = next(port); - if (c == EOF) { - return pic_eof_object(); - } - return read(pic, port, c); } From 1440a51ef8cf49ac1e655c62874fae962f8530cc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 18:18:01 +0900 Subject: [PATCH 036/200] improve error messages of load function --- src/load.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/load.c b/src/load.c index b1fcf39a..f4b4db73 100644 --- a/src/load.c +++ b/src/load.c @@ -14,7 +14,7 @@ pic_load_cstr(pic_state *pic, const char *src) exprs = pic_parse_cstr(pic, src); if (pic_undef_p(exprs)) { - pic_error(pic, "load: unexpected EOF"); + pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); } pic_for_each (v, exprs) { @@ -48,7 +48,7 @@ pic_load(pic_state *pic, const char *fn) exprs = pic_parse_file(pic, file); if (pic_undef_p(exprs)) { - pic_error(pic, "load: unexpected EOF"); + pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); } pic_for_each (v, exprs) { From ee82ee99d7ab9665e6ab8196502dbbfe3ea4239d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 21:38:11 +0900 Subject: [PATCH 037/200] support nested block comment --- src/read.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/read.c b/src/read.c index 8393b611..62c456b2 100644 --- a/src/read.c +++ b/src/read.c @@ -63,6 +63,7 @@ static pic_value read_block_comment(pic_state *pic, struct pic_port *port, char c) { char x, y; + int i; UNUSED(pic); UNUSED(c); @@ -70,12 +71,16 @@ read_block_comment(pic_state *pic, struct pic_port *port, char c) x = next(port); y = next(port); - while (! (x == '|' && y == '#')) { + i = 1; + while (x != EOF && y != EOF && i > 0) { + if (x == '|' && y == '#') { + i--; + } + if (x == '#' && y == '|') { + i++; + } x = y; y = next(port); - if (y == EOF) { - break; - } } return pic_undef_value(); From bd822fa4c6c918b89dd1f23fbd31dca181f8460c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 21:40:18 +0900 Subject: [PATCH 038/200] fix EOF handling --- src/read.c | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/read.c b/src/read.c index 62c456b2..15416251 100644 --- a/src/read.c +++ b/src/read.c @@ -530,6 +530,23 @@ read(pic_state *pic, struct pic_port *port, char c) { pic_value val; + retry: + val = read_nullable(pic, port, c); + + if (pic_undef_p(val)) { + c = next(port); + goto retry; + } + + return val; +} + +pic_value +pic_read(pic_state *pic, struct pic_port *port) +{ + pic_value val; + char c = next(port); + retry: c = skip(port, c); @@ -547,16 +564,6 @@ read(pic_state *pic, struct pic_port *port, char c) return val; } -pic_value -pic_read(pic_state *pic, struct pic_port *port) -{ - char c; - - c = next(port); - - return read(pic, port, c); -} - pic_value pic_read_cstr(pic_state *pic, const char *str) { From 029efc91c95f29348341b2473efaec4b54b93aff Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 21:40:26 +0900 Subject: [PATCH 039/200] allow symbols with leading '.' --- src/read.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index 15416251..44b69c6a 100644 --- a/src/read.c +++ b/src/read.c @@ -342,7 +342,7 @@ read_pair(pic_state *pic, struct pic_port *port, char c) if (c == tCLOSE) { return pic_nil_value(); } - if (c == '.') { + if (c == '.' && strchr("()#;,|'\" \t\n\r", peek(port)) != NULL) { cdr = read(pic, port, next(port)); if ((c = skip(port, ' ')) != tCLOSE) { From 4d9dc8011c19f127f8cb90b13537a9aecf0ebf1e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 21:40:51 +0900 Subject: [PATCH 040/200] fix read_vector bug --- src/read.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/read.c b/src/read.c index 44b69c6a..c9f8f631 100644 --- a/src/read.c +++ b/src/read.c @@ -362,6 +362,8 @@ read_vector(pic_state *pic, struct pic_port *port, char c) { pic_value val; + c = next(port); + val = pic_nil_value(); while ((c = skip(port, c)) != ')') { val = pic_cons(pic, read(pic, port, c), val); From 3f2a0d2160dca53cc25386d210fc8c7e9b786fe5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 21:41:57 +0900 Subject: [PATCH 041/200] update xfile --- extlib/xfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/xfile b/extlib/xfile index a0b1fe61..45cad164 160000 --- a/extlib/xfile +++ b/extlib/xfile @@ -1 +1 @@ -Subproject commit a0b1fe6108b84b94bb35340b232911dc760c4269 +Subproject commit 45cad164afcd0ad3f83286f39ae947c0e595c077 From 2c841688616923ba901dde26d1f533be072eef6f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 21:49:28 +0900 Subject: [PATCH 042/200] hold integers in 64bit size --- src/read.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/read.c b/src/read.c index c9f8f631..de8edaae 100644 --- a/src/read.c +++ b/src/read.c @@ -151,10 +151,10 @@ read_symbol(pic_state *pic, struct pic_port *port, char c) return pic_sym_value(sym); } -static int +static int64_t read_uinteger(pic_state *pic, struct pic_port *port, char c) { - int n; + int64_t n; c = skip(port, c); @@ -174,14 +174,14 @@ read_uinteger(pic_state *pic, struct pic_port *port, char c) static pic_value read_number(pic_state *pic, struct pic_port *port, char c) { - int i, j; + int64_t i, j; i = read_uinteger(pic, port, c); if (peek(port) == '.') { next(port); j = read_uinteger(pic, port, next(port)); - return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%d", j))); + return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%lld", j))); } else { return pic_int_value(i); From 6b8903bd83c6d901134814d002f560f5f9c3b760 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 22:36:42 +0900 Subject: [PATCH 043/200] fix degre --- tools/main.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/main.c b/tools/main.c index 83f7bd40..4716333d 100644 --- a/tools/main.c +++ b/tools/main.c @@ -289,7 +289,7 @@ main(int argc, char *argv[], char **envp) parse_opt(argc, argv); if (mode == INTERACTIVE_MODE || mode == ONE_LINER_MODE) { - // import_repllib(pic); + import_repllib(pic); } switch (mode) { From bc2a6849617dde8c1e7d13b88705be4355d58473 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 22:36:56 +0900 Subject: [PATCH 044/200] add read function support --- src/init.c | 2 ++ src/read.c | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+) diff --git a/src/init.c b/src/init.c index 91e55daa..5770d819 100644 --- a/src/init.c +++ b/src/init.c @@ -29,6 +29,7 @@ void pic_init_macro(pic_state *); void pic_init_var(pic_state *); void pic_init_load(pic_state *); void pic_init_write(pic_state *); +void pic_init_read(pic_state *); void pic_init_dict(pic_state *); void pic_load_piclib(pic_state *); @@ -94,6 +95,7 @@ pic_init_core(pic_state *pic) pic_init_var(pic); DONE; pic_init_load(pic); DONE; pic_init_write(pic); DONE; + pic_init_read(pic); DONE; pic_init_dict(pic); DONE; pic_load_piclib(pic); DONE; diff --git a/src/read.c b/src/read.c index de8edaae..95158fbd 100644 --- a/src/read.c +++ b/src/read.c @@ -616,3 +616,21 @@ pic_parse_cstr(pic_state *pic, const char *str) return pic_parse(pic, port); } + +static pic_value +pic_read_read(pic_state *pic) +{ + struct pic_port *port = pic_stdin(pic); + + pic_get_args(pic, "|p", &port); + + return pic_read(pic, port); +} + +void +pic_init_read(pic_state *pic) +{ + pic_deflibrary ("(scheme read)") { + pic_defun(pic, "read", pic_read_read); + } +} From 9e9fd2527d982047fd569807f85be6813c819184 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 25 Jun 2014 22:39:29 +0900 Subject: [PATCH 045/200] load (scheme read) library at initialization --- tools/main.c | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/main.c b/tools/main.c index 4716333d..5e43f2b7 100644 --- a/tools/main.c +++ b/tools/main.c @@ -42,6 +42,7 @@ import_repllib(pic_state *pic) pic_import(pic, pic_read_cstr(pic, "(scheme base)")); pic_import(pic, pic_read_cstr(pic, "(scheme load)")); pic_import(pic, pic_read_cstr(pic, "(scheme process-context)")); + pic_import(pic, pic_read_cstr(pic, "(scheme read)")); pic_import(pic, pic_read_cstr(pic, "(scheme write)")); pic_import(pic, pic_read_cstr(pic, "(scheme file)")); pic_import(pic, pic_read_cstr(pic, "(scheme inexact)")); From 846ee72ce4bf9b0f3aee7b780539e7b268b2ae52 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 26 Jun 2014 00:36:59 +0900 Subject: [PATCH 046/200] drop flex support on documentation --- README.md | 1 - docs/deploy.rst | 1 - 2 files changed, 2 deletions(-) diff --git a/README.md b/README.md index 9828c113..dceed0be 100644 --- a/README.md +++ b/README.md @@ -83,7 +83,6 @@ If you execute `cmake` with debug flag `-DCMAKE_BUILD_TYPE=Debug`, it builds the Picrin scheme depends on some external libraries to build the binary: - perl -- lex (preferably, flex) - getopt - libedit (optional) - regex.h of POSIX.1 (optional) diff --git a/docs/deploy.rst b/docs/deploy.rst index 3c8b9ceb..0807466b 100644 --- a/docs/deploy.rst +++ b/docs/deploy.rst @@ -64,7 +64,6 @@ Requirement Picrin scheme depends on some external libraries to build the binary: - perl -- lex (preferably, flex) - getopt - readline (optional) - regex.h of POSIX.1 (optional) From 33fcf33bd1faedac4539eb2382cdd1dcfd8d7e26 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 26 Jun 2014 00:57:12 +0900 Subject: [PATCH 047/200] fix #146 --- include/picrin/value.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/include/picrin/value.h b/include/picrin/value.h index a569cc71..d6a07e20 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -444,6 +444,8 @@ pic_eq_p(pic_value x, pic_value y) switch (pic_type(x)) { case PIC_TT_NIL: return true; + case PIC_TT_BOOL: + return pic_vtype(x) == pic_vtype(y); case PIC_TT_SYMBOL: return pic_sym(x) == pic_sym(y); default: @@ -460,6 +462,8 @@ pic_eqv_p(pic_value x, pic_value y) switch (pic_type(x)) { case PIC_TT_NIL: return true; + case PIC_TT_BOOL: + return pic_vtype(x) == pic_vtype(y); case PIC_TT_SYMBOL: return pic_sym(x) == pic_sym(y); case PIC_TT_FLOAT: From d39a2eb4c9e9ce1a9a85bc21b5628980cc7dd723 Mon Sep 17 00:00:00 2001 From: Yuito Murase Date: Thu, 26 Jun 2014 09:42:16 +0900 Subject: [PATCH 048/200] fix bug that filter-map fails when called with multiple clists --- piclib/srfi/1.scm | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 259c0c5a..85bc227e 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -387,15 +387,10 @@ (reverse! acc))))) (define (filter-map f clist . clists) - (if (null? clists) - (let rec ((clist clist) (cont values)) - (if (null? clist) - (cont '()) - (rec (cdr clist) - (let ((it (f (car clist)))) - (if it - (lambda (x) (cont (cons it x))) - (lambda (x) (cont x))))))))) + (let recur ((l (apply map f clist clists))) + (cond ((null? l) '()) + ((car l) (cons (car l) (recur (cdr l)))) + (else (recur (cdr l)))))) (export map for-each fold unfold pair-fold reduce From 8374297a221b0cdaac244f4713596dd2106e512a Mon Sep 17 00:00:00 2001 From: Yuito Murase Date: Thu, 26 Jun 2014 17:40:26 +0900 Subject: [PATCH 049/200] append returns '() when given no args --- src/pair.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/pair.c b/src/pair.c index 6fe316c1..bb4ef0bb 100644 --- a/src/pair.c +++ b/src/pair.c @@ -501,6 +501,10 @@ pic_pair_append(pic_state *pic) pic_get_args(pic, "*", &argc, &args); + if (argc == 0) { + return pic_nil_value(); + } + list = args[--argc]; while (argc-- > 0) { From 5b215eb57aeb47e9f08fa466d17a7db4f173a938 Mon Sep 17 00:00:00 2001 From: koba-e964 Date: Thu, 26 Jun 2014 18:40:40 +0900 Subject: [PATCH 050/200] Make filter tail-recursive --- piclib/srfi/1.scm | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 85bc227e..2eafdf0d 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -402,12 +402,8 @@ ;; filter partition remove ;; filter! partition! remove! (define (filter pred list) - (if (null? list) - '() - (if (pred (car list)) - (cons (car list) - (filter pred (cdr list))) - (filter pred (cdr list))))) + (let ((pcons (lambda (v acc) (if (pred v) (cons v acc) acc)))) + (reverse (fold pcons '() list)))) (define (remove pred list) (filter (lambda (x) (not (pred x))) list)) From 2526474fb3356e02b8a00798317b5579a711a163 Mon Sep 17 00:00:00 2001 From: stibear Date: Thu, 26 Jun 2014 22:44:38 +0900 Subject: [PATCH 051/200] implements delete-duplicates(!) tail-recursively --- piclib/srfi/1.scm | 650 +++++++++++++++++++++++----------------------- 1 file changed, 325 insertions(+), 325 deletions(-) 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! From 606f34420c0594d586966d1436701cb5f1cc3024 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 07:12:35 +0900 Subject: [PATCH 052/200] update gitignore --- .gitignore | 2 -- 1 file changed, 2 deletions(-) diff --git a/.gitignore b/.gitignore index 6b185c72..e0975baf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,4 @@ build/* -src/lex.yy.c -src/lex.yy.h src/load_piclib.c .dir-locals.el GPATH From 1eb4940b135bd810ea18be7e126b54c91459606a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 07:23:19 +0900 Subject: [PATCH 053/200] use isdigit --- src/read.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/read.c b/src/read.c index 95158fbd..96893f92 100644 --- a/src/read.c +++ b/src/read.c @@ -202,11 +202,9 @@ negate(pic_value n) static pic_value read_minus(pic_state *pic, struct pic_port *port, char c) { - static const char DIGITS[] = "0123456789"; - /* TODO: -inf.0, -nan.0 */ - if (strchr(DIGITS, peek(port))) { + if (isdigit(peek(port))) { return negate(read_number(pic, port, c)); } else { @@ -217,11 +215,9 @@ read_minus(pic_state *pic, struct pic_port *port, char c) static pic_value read_plus(pic_state *pic, struct pic_port *port, char c) { - static const char DIGITS[] = "0123456789"; - /* TODO: +inf.0, +nan.0 */ - if (strchr(DIGITS, peek(port))) { + if (isdigit(peek(port))) { return read_number(pic, port, c); } else { From bb43c8d9dc3a589cd6c8de875d5eb08f6ce62ffc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 07:23:34 +0900 Subject: [PATCH 054/200] add isdelim --- src/read.c | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/read.c b/src/read.c index 96893f92..b2d8c8f8 100644 --- a/src/read.c +++ b/src/read.c @@ -47,6 +47,12 @@ peek(struct pic_port *port) return c; } +static bool +isdelim(char c) +{ + return strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ +} + static pic_value read_comment(pic_state *pic, struct pic_port *port, char c) { @@ -127,7 +133,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; @@ -142,7 +147,7 @@ read_symbol(pic_state *pic, struct pic_port *port, char c) len += 1; buf = pic_realloc(pic, buf, len); 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); @@ -338,7 +343,7 @@ read_pair(pic_state *pic, struct pic_port *port, char c) 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)); if ((c = skip(port, ' ')) != tCLOSE) { From 556a4606637aae9a97d2f921c05dfe0cfa979a9b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 07:28:46 +0900 Subject: [PATCH 055/200] [bugfix] EOF is a delimiter --- src/read.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index b2d8c8f8..f76e26f8 100644 --- a/src/read.c +++ b/src/read.c @@ -50,7 +50,7 @@ peek(struct pic_port *port) static bool isdelim(char c) { - return strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ + return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ } static pic_value From a98411cd0bac26907c01509367d57768d587f65d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 07:28:56 +0900 Subject: [PATCH 056/200] syntax error around comma --- piclib/built-in.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 64e2ee10..4660cf89 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1063,7 +1063,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) From 0b85e251a2882c5a61bfd0a902d74ca13e1f39e1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 07:59:25 +0900 Subject: [PATCH 057/200] fix negative number reader --- src/read.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index f76e26f8..d123059c 100644 --- a/src/read.c +++ b/src/read.c @@ -210,7 +210,7 @@ read_minus(pic_state *pic, struct pic_port *port, char c) /* TODO: -inf.0, -nan.0 */ if (isdigit(peek(port))) { - return negate(read_number(pic, port, c)); + return negate(read_number(pic, port, next(port))); } else { return read_symbol(pic, port, c); From e1ca64b56ee438cf718a326969bc65a256e22c0c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 08:21:53 +0900 Subject: [PATCH 058/200] block comment reader must not consume the character right after the comment end --- src/read.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/read.c b/src/read.c index d123059c..2e7bb19f 100644 --- a/src/read.c +++ b/src/read.c @@ -69,24 +69,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(); From 36e0aa6f697f1a765f7dfd69173d23a3d03dc677 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 08:34:00 +0900 Subject: [PATCH 059/200] [bugfix] compound literals should consider inner comments --- src/read.c | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/read.c b/src/read.c index 2e7bb19f..ccd055d9 100644 --- a/src/read.c +++ b/src/read.c @@ -15,6 +15,7 @@ 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) @@ -336,6 +337,8 @@ 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) { @@ -350,7 +353,12 @@ read_pair(pic_state *pic, struct pic_port *port, char c) 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); } @@ -359,16 +367,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 From 195ccf199dc7da63f68b7bf4bcaf1b3531842535 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 08:41:42 +0900 Subject: [PATCH 060/200] [bugfix] make-promise makes a promise that is done all along --- piclib/built-in.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 4660cf89..ae9ecbce 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -926,7 +926,7 @@ (define (make-promise obj) (if (promise? obj) obj - (make-promise% #f obj))) + (make-promise% #t obj))) (export delay-force delay force make-promise promise?)) From 51b8344527c5c708cb311890acd65660cafe2280 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 08:54:32 +0900 Subject: [PATCH 061/200] support infinity and nan literals --- src/read.c | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/read.c b/src/read.c index ccd055d9..03e72aa3 100644 --- a/src/read.c +++ b/src/read.c @@ -206,25 +206,39 @@ negate(pic_value n) static pic_value read_minus(pic_state *pic, struct pic_port *port, char c) { - /* TODO: -inf.0, -nan.0 */ + pic_value sym; 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) { - /* TODO: +inf.0, +nan.0 */ + pic_value sym; if (isdigit(peek(port))) { return read_number(pic, port, c); } else { + sym = read_symbol(pic, port, c); + if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+inf.0")))) { + return pic_float_value(INFINITY); + } + if (pic_eq_p(sym, pic_sym_value(pic_intern_cstr(pic, "+nan.0")))) { + return pic_float_value(NAN); + } return read_symbol(pic, port, c); } } From 4501b9bd93bffdddb6f5227f7c5a286ff82ab27b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 17:35:00 +0900 Subject: [PATCH 062/200] update xrope --- extlib/xrope | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extlib/xrope b/extlib/xrope index 3bc8a992..32d99fae 160000 --- a/extlib/xrope +++ b/extlib/xrope @@ -1 +1 @@ -Subproject commit 3bc8a992e249ef6aea6d05dedf3e158446e1339b +Subproject commit 32d99fae069c1ec7bf0fc31345bfc27cae84b47a From 3ee807a3473dfee189b9cd30f5cbd5453d566823 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 27 Jun 2014 17:40:43 +0900 Subject: [PATCH 063/200] fix xr_put --- src/string.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/string.c b/src/string.c index edaf1edc..e9a0095b 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 From 952814ec3d3c7139dc94207e567ff3835929888b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 10:12:53 +0900 Subject: [PATCH 064/200] make no-act: direct error logs to /dev/null --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 12347110..530e568a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -43,7 +43,7 @@ add_custom_target(run bin/picrin DEPENDS repl) 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(no-act bin/picrin -e '' > /dev/null 2> /dev/null DEPENDS repl) # $ make test-r7rs add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl) From 8387397e1b1d72386b615733b0806c56a591d2e3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 10:13:18 +0900 Subject: [PATCH 065/200] don't run make test in debug mode on travis --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index fc6103f9..2d33fec2 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 no-act From e82a688a66c557265d432960749d0c1c99b6fa41 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 11:31:13 +0900 Subject: [PATCH 066/200] add number prefix to contrib libraries --- contrib/10.partcont/CMakeLists.txt | 2 ++ contrib/{partcont => 10.partcont}/piclib/partcont.scm | 0 contrib/{regexp => 10.regexp}/CMakeLists.txt | 2 +- contrib/{regexp => 10.regexp}/src/regexp.c | 0 contrib/partcont/CMakeLists.txt | 2 -- 5 files changed, 3 insertions(+), 3 deletions(-) create mode 100644 contrib/10.partcont/CMakeLists.txt rename contrib/{partcont => 10.partcont}/piclib/partcont.scm (100%) rename contrib/{regexp => 10.regexp}/CMakeLists.txt (81%) rename contrib/{regexp => 10.regexp}/src/regexp.c (100%) delete mode 100644 contrib/partcont/CMakeLists.txt 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/regexp/CMakeLists.txt b/contrib/10.regexp/CMakeLists.txt similarity index 81% rename from contrib/regexp/CMakeLists.txt rename to contrib/10.regexp/CMakeLists.txt index 0e28d430..f71ccfc7 100644 --- a/contrib/regexp/CMakeLists.txt +++ b/contrib/10.regexp/CMakeLists.txt @@ -5,7 +5,7 @@ if (REGEX_FOUND) add_definitions(${REGEX_DEFINITIONS}) include_directories(${REGEX_INCLUDE_DIR}) - file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/regexp/src/*.c) + file(GLOB PICRIN_REGEX_SOURCES ${PROJECT_SOURCE_DIR}/contrib/10.regexp/src/*.c) list(APPEND PICRIN_CONTRIB_INITS "void pic_init_regexp(pic_state *)\; pic_init_regexp(pic)\;") list(APPEND PICRIN_CONTRIB_LIBRARIES ${REGEX_LIBRARIES}) diff --git a/contrib/regexp/src/regexp.c b/contrib/10.regexp/src/regexp.c similarity index 100% rename from contrib/regexp/src/regexp.c rename to contrib/10.regexp/src/regexp.c diff --git a/contrib/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}) From f37c88c174105874de9a7799aa22776948af3f69 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 11:32:23 +0900 Subject: [PATCH 067/200] add for macro library --- contrib/20.for/CMakeLists.txt | 2 ++ contrib/20.for/piclib/for.scm | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+) create mode 100644 contrib/20.for/CMakeLists.txt create mode 100644 contrib/20.for/piclib/for.scm 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..bd421ef8 --- /dev/null +++ b/contrib/20.for/piclib/for.scm @@ -0,0 +1,18 @@ +(define-library (picrin control list) + (import (scheme base) + (picrin control) + (scheme write)) + + (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)) + + (export for in yield)) From 31acb210935c4ef17d1ada8913e311eece9dfefc Mon Sep 17 00:00:00 2001 From: stibear Date: Sat, 28 Jun 2014 11:48:30 +0900 Subject: [PATCH 068/200] rewrite an unavailable symbol into an available one --- piclib/srfi/43.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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))))))))) From c26fc144f31958b1a1870cc772e8336af18c97e5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 12:07:56 +0900 Subject: [PATCH 069/200] added null operator to (picrin control list) --- contrib/20.for/piclib/for.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/contrib/20.for/piclib/for.scm b/contrib/20.for/piclib/for.scm index bd421ef8..d37afd9f 100644 --- a/contrib/20.for/piclib/for.scm +++ b/contrib/20.for/piclib/for.scm @@ -15,4 +15,7 @@ (define (yield x) (list x)) - (export for in yield)) + (define (null . x) + '()) + + (export for in yield null)) From 706a3a4965ebea6c3ce4bf5eb2ea2e0c88281f97 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 12:14:27 +0900 Subject: [PATCH 070/200] add (picrin control list) doc --- docs/libs.rst | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/docs/libs.rst b/docs/libs.rst index 9d71963f..d4ed18d0 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -79,6 +79,51 @@ 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 dictionary) ------------------- From 1e458d96919bf2427c8a23014d950132b26445e0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 12:40:02 +0900 Subject: [PATCH 071/200] fix #153 --- piclib/CMakeLists.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index b795ad54..497d8cd1 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,6 +1,9 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/built-in.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm + ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm + ${PROJECT_SOURCE_DIR}/piclib/srfi/43.scm + ${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/95.scm ) From 6fe87b8fa29a73f60734d91b309bdf23b6f12739 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 12:42:36 +0900 Subject: [PATCH 072/200] update docs. mentioning new srfi libraries --- docs/libs.rst | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/docs/libs.rst b/docs/libs.rst index d4ed18d0..2a7a7a1f 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. From 853387668205b88d98b244fa3cc27fad041e4e2e Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Tue, 27 May 2014 21:35:19 +0900 Subject: [PATCH 073/200] vectors, blobs, strings with equal contets are equal --- src/bool.c | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/bool.c b/src/bool.c index fa56fa31..ef497362 100644 --- a/src/bool.c +++ b/src/bool.c @@ -6,6 +6,9 @@ #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) @@ -22,6 +25,27 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) 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)); + case PIC_TT_BLOB: { + int i; + struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y); + for(i = 0; i < v1->len; ++i){ + if(v1->data[i] != v2->data[i]) + return false; + } + return true; + } + case PIC_TT_VECTOR:{ + size_t i; + struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y); + + for(i = 0; i < v1->len; ++i){ + if(! pic_equal_p(pic, v1->data[i], v2->data[i])) + return false; + } + return true; + } + case PIC_TT_STRING: + return pic_strcmp(pic_str_ptr(x), pic_str_ptr(y)) == 0; default: return false; } From 49a4808a2262926b866207094000763d89758742 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Wed, 28 May 2014 02:55:19 +0900 Subject: [PATCH 074/200] check length before compare contents --- src/bool.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/bool.c b/src/bool.c index ef497362..904a21d6 100644 --- a/src/bool.c +++ b/src/bool.c @@ -28,6 +28,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) case PIC_TT_BLOB: { int i; struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y); + if(v1->len != v2->len){ + return false; + } for(i = 0; i < v1->len; ++i){ if(v1->data[i] != v2->data[i]) return false; @@ -38,6 +41,9 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) size_t i; struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y); + if(v1->len != v2->len){ + return false; + } for(i = 0; i < v1->len; ++i){ if(! pic_equal_p(pic, v1->data[i], v2->data[i])) return false; From 2fb97d16edb606dcb2d0f17bc3133e78aee6eea4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 19:23:06 +0900 Subject: [PATCH 075/200] style fix --- src/bool.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/bool.c b/src/bool.c index 904a21d6..07ddcffc 100644 --- a/src/bool.c +++ b/src/bool.c @@ -23,29 +23,29 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value 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)); + 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)); case PIC_TT_BLOB: { int i; - struct pic_blob *v1 = pic_blob_ptr(x), *v2 = pic_blob_ptr(y); - if(v1->len != v2->len){ + struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y); + + if(u->len != v->len){ return false; } - for(i = 0; i < v1->len; ++i){ - if(v1->data[i] != v2->data[i]) + for(i = 0; i < u->len; ++i){ + if(u->data[i] != v->data[i]) return false; } return true; } - case PIC_TT_VECTOR:{ + case PIC_TT_VECTOR: { size_t i; - struct pic_vector *v1 = pic_vec_ptr(x), *v2 = pic_vec_ptr(y); - - if(v1->len != v2->len){ + struct pic_vector *u = pic_vec_ptr(x), *v = pic_vec_ptr(y); + + if(u->len != v->len){ return false; } - for(i = 0; i < v1->len; ++i){ - if(! pic_equal_p(pic, v1->data[i], v2->data[i])) + for(i = 0; i < u->len; ++i){ + if(! pic_equal_p(pic, u->data[i], v->data[i])) return false; } return true; From 5ba0402221f053c8ccd1dca2338ab0995d22d593 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 19:23:24 +0900 Subject: [PATCH 076/200] fix type warning (int and size_t) --- src/bool.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bool.c b/src/bool.c index 07ddcffc..bb4fae82 100644 --- a/src/bool.c +++ b/src/bool.c @@ -25,7 +25,7 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) 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)); case PIC_TT_BLOB: { - int i; + size_t i; struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y); if(u->len != v->len){ From cee98a9954b149c7121492bb9311bcbee485f244 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 19:43:49 +0900 Subject: [PATCH 077/200] [bugfix] support vector literal in quasiquote --- piclib/built-in.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index ae9ecbce..ca2271fa 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -136,6 +136,22 @@ (define (unquote-splicing? form compare?) (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing))) + (define (list->vector list) + (let ((vector (make-vector (length list)))) + (let loop ((list list) (i 0)) + (if (null? list) + vector + (begin + (vector-set! vector i (car list)) + (loop (cdr list) (+ i 1))))))) + + (define (vector->list vector) + (let ((length (vector-length vector))) + (let loop ((list '()) (i 0)) + (if (= i length) + (reverse list) + (loop (cons (vector-ref vector i) list) (+ i 1)))))) + (define-syntax quasiquote (ir-macro-transformer (lambda (form inject compare) @@ -170,6 +186,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)))) From aae4bba98d86a97e88521a95c35cc950351e724d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 19:47:45 +0900 Subject: [PATCH 078/200] [bugfix] wrong size for read string --- src/read.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index 03e72aa3..1dae699f 100644 --- a/src/read.c +++ b/src/read.c @@ -299,7 +299,7 @@ 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); } From 8f5a4e8980b3ce32a8ca0efb26a66495b05caeb8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:02:06 +0900 Subject: [PATCH 079/200] unlock reader test --- t/r7rs-tests.scm | 90 ++++++++++++++++++++++++------------------------ 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index e5ce8af7..5836ed26 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -32,7 +32,7 @@ ; (scheme complex) (scheme time) (scheme file) -; (scheme read) + (scheme read) (scheme write) ; (scheme eval) (scheme process-context) @@ -1962,56 +1962,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)"))) +(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 @@ -2058,7 +2058,7 @@ ;; (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") From 4772441589553847a0de58bfe7cdcff57ee8b981 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:02:13 +0900 Subject: [PATCH 080/200] allow "(a . b #;c )" --- src/read.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/read.c b/src/read.c index 1dae699f..66b1625f 100644 --- a/src/read.c +++ b/src/read.c @@ -361,7 +361,11 @@ read_pair(pic_state *pic, struct pic_port *port, char c) 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; From 5869f13ae0216d2807ba68ba8b3e1299f61beb0c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:02:38 +0900 Subject: [PATCH 081/200] unlock some of environment-variable tests --- t/r7rs-tests.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 5836ed26..f1439ff2 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -2226,17 +2226,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))) From a7c9537e067d7877c9a744101a113a781ff2f54d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:12:06 +0900 Subject: [PATCH 082/200] unlock more reader tests --- t/r7rs-tests.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index f1439ff2..4fc078a1 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -1802,9 +1802,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"))) From d294330aa56fc47409b95d83ff4fcef3c6654f7b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:13:06 +0900 Subject: [PATCH 083/200] delete trailing whitespaces --- t/r7rs-tests.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 4fc078a1..6a101cef 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -310,7 +310,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 +328,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)))) @@ -390,7 +390,7 @@ (test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) ;; (define plus -;; (case-lambda +;; (case-lambda ;; (() 0) ;; ((x) x) ;; ((x y) (+ x y)) @@ -404,7 +404,7 @@ ;; (test 10 (plus 1 2 3 4)) ;; (define mult -;; (case-lambda +;; (case-lambda ;; (() 1) ;; ((x) x) ;; ((x y) (* x y)) @@ -1017,7 +1017,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"))) @@ -2168,7 +2168,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") From 0716ff8a03e0d5774ede76088148217e23861279 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:21:02 +0900 Subject: [PATCH 084/200] unlock a string test --- t/r7rs-tests.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 6a101cef..d89afd12 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -1151,7 +1151,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")) From c5400b4b2d6a3cf5cb0e67331aa448c6fa54edb9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:29:49 +0900 Subject: [PATCH 085/200] support more than 2 argument-comparators --- src/codegen.c | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/codegen.c b/src/codegen.c index d097896f..8dd84b7a 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -690,6 +690,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), \ @@ -768,23 +774,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 +804,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: From 015d0872c9590c0602be519b17ab4d5ee8e69aa4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:30:10 +0900 Subject: [PATCH 086/200] unlock comparator tests --- t/r7rs-tests.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index d89afd12..2bdea07e 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -648,14 +648,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: ;; From 39b1e6c6bc9d1053cd963101679b2aec18a18161 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:30:19 +0900 Subject: [PATCH 087/200] [bugfix] comparator transitivity broken --- src/number.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/number.c b/src/number.c index 42140260..b8960466 100644 --- a/src/number.c +++ b/src/number.c @@ -133,6 +133,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])) \ From c44803d2381e77624742082123e42f8734b2875e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:45:41 +0900 Subject: [PATCH 088/200] [bugfix] using uninitializing variable --- src/var.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/var.c b/src/var.c index a779ddff..e667966d 100644 --- a/src/var.c +++ b/src/var.c @@ -48,10 +48,7 @@ get_var_from_proc(pic_state *pic, struct pic_proc *proc) { pic_value v; - if (! pic_proc_p(v)) { - goto typeerror; - } - if (! pic_proc_func_p(pic_proc_ptr(v))) { + if (! pic_proc_func_p(proc)) { goto typeerror; } if (pic_proc_cv_size(pic, proc) != 1) { @@ -64,8 +61,7 @@ get_var_from_proc(pic_state *pic, struct pic_proc *proc) return pic_var_ptr(v); typeerror: - pic_error(pic, "expected parameter"); - UNREACHABLE(); + pic_errorf(pic, "expected parameter, but got ~s", v); } static pic_value From 7da5786ef3bf963c2092c1407ab03251636cec2f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:46:04 +0900 Subject: [PATCH 089/200] unlock parameter tests --- t/r7rs-tests.scm | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 2bdea07e..c31b3dfa 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -364,18 +364,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)) From b2a14ca0f17fd2317a54f2ceb04e4a42874aed8b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 20:58:53 +0900 Subject: [PATCH 090/200] print test statistics at the end of all tests --- t/r7rs-tests.scm | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index c31b3dfa..845cddde 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -44,11 +44,27 @@ ;; support, the full numeric tower and all standard libraries ;; provided. -(define (test-begin . o) #f) +(define test-counter 0) +(define counter 0) +(define failure-counter 0) -(define (test-end . o) #f) +(define (print-statistics) + (newline) + (display "Test Result: ") + (write (- counter failure-counter)) + (display " / ") + (write counter) + (display " [PASS/TOTAL]") + (display "") + (newline)) -(define counter 1) +(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 () @@ -66,6 +82,7 @@ (newline) ) ((not (equal? res expected)) + (set! failure-counter (+ failure-counter 1)) (display " FAIL: ") (write 'expr) (newline) From 5d3c59fc985604f37c577844c197c316b92d8aba Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 21:41:35 +0900 Subject: [PATCH 091/200] reads number as accurate as possible --- src/read.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/read.c b/src/read.c index 66b1625f..fab3ceaf 100644 --- a/src/read.c +++ b/src/read.c @@ -178,14 +178,18 @@ read_uinteger(pic_state *pic, struct pic_port *port, char c) static pic_value read_number(pic_state *pic, struct pic_port *port, char c) { - int64_t i, j; + char buf[256], *cur; + int64_t i; i = read_uinteger(pic, port, c); if (peek(port) == '.') { - next(port); - j = read_uinteger(pic, port, next(port)); - return pic_float_value(i + (double)j * pow(10, -snprintf(NULL, 0, "%lld", j))); + cur = buf + snprintf(buf, sizeof buf, "%lld", i); + do { + *cur++ = next(port); + } while (isdigit(peek(port))); + *cur = '\0'; + return pic_float_value(atof(buf)); } else { return pic_int_value(i); From 1a1d380a78c5d255ed4600755304181fe4ff9e0c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 21:41:59 +0900 Subject: [PATCH 092/200] [bugfix] bad accuracy of test cases --- t/r7rs-tests.scm | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 845cddde..6fc1ae64 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -822,7 +822,7 @@ ;; (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))) @@ -835,30 +835,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)) From 76220e1e8ed67df58c3987554ccf853688e29a0a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 21:43:44 +0900 Subject: [PATCH 093/200] infinity is not rational --- src/number.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/number.c b/src/number.c index b8960466..c0a1e7ec 100644 --- a/src/number.c +++ b/src/number.c @@ -50,6 +50,10 @@ pic_number_integer_p(pic_state *pic) if (pic_float_p(v)) { double f = pic_float(v); + if (isinf(f)) { + return pic_false_value(); + } + if (f == round(f)) { return pic_true_value(); } From 4fd99b5955a7b367ee5170a3899a5ae05baf99d6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 21:53:14 +0900 Subject: [PATCH 094/200] [bugfix] return value from pic_get_args does not include proc object --- src/string.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/string.c b/src/string.c index e9a0095b..6015688c 100644 --- a/src/string.c +++ b/src/string.c @@ -386,9 +386,9 @@ pic_str_string_fill_ip(pic_state *pic) n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end); switch (n) { - case 1: - start = 0; case 2: + start = 0; + case 3: end = pic_strlen(str); } From 2d594064035ed6143b2d328abe2f7008326bfec1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 21:54:07 +0900 Subject: [PATCH 095/200] improve test value accuracy --- t/r7rs-tests.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 6fc1ae64..59903db3 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -257,7 +257,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))) From 2615ce11bd02bf4495acd5c2a017ceaa621b8ed3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 21:54:19 +0900 Subject: [PATCH 096/200] unlock string-fill! tests --- t/r7rs-tests.scm | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 59903db3..ec97e20c 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -1292,29 +1292,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) From 5c3e5b116ec56c23f9649fe6731769b88149696e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 22:02:09 +0900 Subject: [PATCH 097/200] show success rate in statistics --- t/r7rs-tests.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index ec97e20c..362247eb 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -54,6 +54,9 @@ (write (- counter failure-counter)) (display " / ") (write counter) + (display " (") + (write (* (/ (- counter failure-counter) counter) 100)) + (display "%)") (display " [PASS/TOTAL]") (display "") (newline)) From 690e2cdba67e1781c7a589c7c4faf9596f6e0702 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 28 Jun 2014 22:32:26 +0900 Subject: [PATCH 098/200] refactor number parser --- src/read.c | 46 ++++++++++++++++++++++------------------------ 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/src/read.c b/src/read.c index fab3ceaf..0cf4cdaa 100644 --- a/src/read.c +++ b/src/read.c @@ -155,46 +155,43 @@ 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) { - char buf[256], *cur; - int64_t i; + char buf[256]; + size_t i; - i = read_uinteger(pic, port, c); + i = read_uinteger(pic, port, c, buf); if (peek(port) == '.') { - cur = buf + snprintf(buf, sizeof buf, "%lld", i); do { - *cur++ = next(port); + buf[i++] = next(port); } while (isdigit(peek(port))); - *cur = '\0'; + buf[i] = '\0'; return pic_float_value(atof(buf)); } else { - return pic_int_value(i); + return pic_int_value(atoi(buf)); } - } static pic_value @@ -313,7 +310,7 @@ 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; @@ -331,21 +328,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); } From 89506d0ced16902ef5aca7b3d6e90a7b987b824e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 00:54:20 +0900 Subject: [PATCH 099/200] [bugfix] allocate size was inefficient --- src/read.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index 0cf4cdaa..47321029 100644 --- a/src/read.c +++ b/src/read.c @@ -144,7 +144,7 @@ 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 (! isdelim(peek(port))); From fdbd7bd2c9ccd988ef014fb60fd553d5594455e6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 01:06:07 +0900 Subject: [PATCH 100/200] [bugfix] glibc's getenv function does not igrore trailing '=' --- src/system.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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); From 85d513abe66abcc6dae26cecc4f22dc878d7d4a5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 01:23:21 +0900 Subject: [PATCH 101/200] remove "2> /dev/null" from make test command line --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 530e568a..12347110 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -43,7 +43,7 @@ add_custom_target(run bin/picrin DEPENDS repl) add_custom_target(test DEPENDS no-act test-r7rs) # $ make no-act -add_custom_target(no-act bin/picrin -e '' > /dev/null 2> /dev/null DEPENDS repl) +add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl) # $ make test-r7rs add_custom_target(test-r7rs bin/picrin ${PROJECT_SOURCE_DIR}/t/r7rs-tests.scm DEPENDS repl) From 5e12794467cab988038fcbd75d371d44c76b91ec Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 01:29:09 +0900 Subject: [PATCH 102/200] sort contrib libraries before include them --- contrib/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/contrib/CMakeLists.txt b/contrib/CMakeLists.txt index 2a25b8b8..2487f0d0 100644 --- a/contrib/CMakeLists.txt +++ b/contrib/CMakeLists.txt @@ -1,4 +1,5 @@ file(GLOB CONTRIBS ${PROJECT_SOURCE_DIR}/contrib/*/CMakeLists.txt) +list(SORT CONTRIBS) foreach(contrib ${CONTRIBS}) include(${contrib}) endforeach() From 8d9b7e9bf35b0c78ff8d1c4e492effbad845bdcc Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Sun, 29 Jun 2014 13:46:46 +0900 Subject: [PATCH 103/200] ensure flush contents into the port made in `open-input-bytevector` --- src/port.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/port.c b/src/port.c index 168b5cce..2da85177 100644 --- a/src/port.c +++ b/src/port.c @@ -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); } From a6ac56d311489e426b6e420a28b006d507ece75c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 13:58:21 +0900 Subject: [PATCH 104/200] rewrite `include` macro with scheme --- docs/lang.rst | 2 +- piclib/built-in.scm | 25 +++++++++++++++++++++++++ src/macro.c | 35 ----------------------------------- 3 files changed, 26 insertions(+), 36 deletions(-) diff --git a/docs/lang.rst b/docs/lang.rst index fe0e60f7..9e787548 100644 --- a/docs/lang.rst +++ b/docs/lang.rst @@ -38,7 +38,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 diff --git a/piclib/built-in.scm b/piclib/built-in.scm index ca2271fa..a58e0aa8 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -907,6 +907,31 @@ (export call-with-port) +;;; include syntax + +(import (scheme read) + (scheme file)) + +(define (call-with-input-file filename callback) + (call-with-port (open-input-file filename) callback)) + +(define (read-many filename) + (call-with-input-file filename + (lambda (port) + (let loop ((expr (read port)) (exprs '())) + (if (eof-object? expr) + (reverse exprs) + (loop (read port) (cons expr exprs))))))) + +(define-syntax include + (er-macro-transformer + (lambda (form rename compare) + (let ((filenames (cdr form))) + (let ((exprs (apply append (map read-many filenames)))) + `(,(rename 'begin) ,@exprs)))))) + +(export include) + ;;; Appendix A. Standard Libraries Lazy (define-library (scheme lazy) (import (scheme base) diff --git a/src/macro.c b/src/macro.c index 7783c0e4..1a0ed192 100644 --- a/src/macro.c +++ b/src/macro.c @@ -599,39 +599,6 @@ 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) -{ - size_t argc, i; - pic_value *argv, exprs, body; - FILE *file; - - pic_get_args(pic, "*", &argc, &argv); - - /* FIXME unhygienic */ - body = pic_list1(pic, pic_sym_value(pic->sBEGIN)); - - for (i = 0; i < argc; ++i) { - const char *filename; - if (! pic_str_p(argv[i])) { - pic_error(pic, "expected string"); - } - filename = pic_str_cstr(pic_str_ptr(argv[i])); - file = fopen(filename, "r"); - if (file == NULL) { - pic_error(pic, "could not open file"); - } - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - pic_error(pic, "parse error"); - } - body = pic_append(pic, body, exprs); - } - - return body; -} - static pic_value pic_macro_gensym(pic_state *pic) { @@ -958,8 +925,6 @@ pic_macro_ir_macro_transformer(pic_state *pic) 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 */ From 2af2362b4fdddc71d5819d3e90c376dba4fa810e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 15:07:52 +0900 Subject: [PATCH 105/200] support `(define-values (x y . z) ...)` --- piclib/built-in.scm | 73 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 56 insertions(+), 17 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index a58e0aa8..3f6eb5a7 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -343,24 +343,63 @@ (lambda (form r c) `(,(r 'let*-values) ,@(cdr form))))) + (define (vector-map proc vect) + (do ((i 0 (+ i 1)) + (u (make-vector (vector-length vect)))) + ((= i (vector-length vect)) + u) + (vector-set! u i (proc (vector-ref vect i))))) + + (define (walk proc expr) + (cond + ((null? expr) + '()) + ((pair? expr) + (cons (proc (car expr)) + (walk proc (cdr expr)))) + ((vector? expr) + (vector-map proc expr)) + (else + (proc expr)))) + + (define (flatten expr) + (let ((list '())) + (walk + (lambda (x) + (set! list (cons x list))) + expr) + (reverse list))) + + (define (predefine var) + `(define ,var #f)) + + (define (predefines vars) + (map predefine vars)) + + (define (assign var val) + `(set! ,var ,val)) + + (define (assigns vars vals) + (map assign vars vals)) + + (define uniq + (let ((counter 0)) + (lambda (x) + (let ((sym (string->symbol (string-append "var$" (number->string counter))))) + (set! counter (+ counter 1)) + sym)))) + (define-syntax define-values - (er-macro-transformer - (lambda (form r c) - (let ((formals (cadr form))) - `(,(r 'begin) - ,@(do ((vars formals (cdr vars)) - (defs '())) - ((null? vars) - defs) - (set! defs (cons `(,(r 'define) ,(car vars) #f) defs))) - (,(r 'call-with-values) - (,(r 'lambda) () ,@(cddr form)) - (,(r 'lambda) (,@(map r formals)) - ,@(do ((vars formals (cdr vars)) - (assn '())) - ((null? vars) - assn) - (set! assn (cons `(,(r 'set!) ,(car vars) ,(r (car vars))) assn)))))))))) + (ir-macro-transformer + (lambda (form inject compare) + (let* ((formal (cadr form)) + (formal* (walk uniq formal)) + (exprs (cddr form))) + `(begin + ,@(predefines (flatten formal)) + (call-with-values (lambda () ,@exprs) + (lambda ,formal* + ,@(assigns (flatten formal) (flatten formal*))))))))) (export let-values let*-values From 3c26c289f343b829be6694e44f87571aad1819f5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 15:08:04 +0900 Subject: [PATCH 106/200] unlock define-values tests --- t/r7rs-tests.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 362247eb..da0a1cbb 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -520,10 +520,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)) @@ -532,10 +532,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! From 69c0e702c63b255b5959f7ce2754fa91aaf84a9b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 29 Jun 2014 16:22:22 +0900 Subject: [PATCH 107/200] remove useless fflush --- src/error.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/error.c b/src/error.c index f4b96675..773b5d2c 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(); } From 1402a973544011d70dcf48bf8b61376dc3719469 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Jul 2014 13:32:45 +0900 Subject: [PATCH 108/200] change pic_throw API --- include/picrin/error.h | 3 ++- src/error.c | 28 +++++++++++++++++++++------- src/macro.c | 2 +- 3 files changed, 24 insertions(+), 9 deletions(-) diff --git a/include/picrin/error.h b/include/picrin/error.h index 024d5d29..75361c1a 100644 --- a/include/picrin/error.h +++ b/include/picrin/error.h @@ -32,7 +32,8 @@ struct pic_jmpbuf { void pic_push_try(pic_state *); void pic_pop_try(pic_state *); -noreturn void pic_throw(pic_state *, struct pic_error *); +noreturn void pic_throw(pic_state *, short, const char *, pic_value); +noreturn void pic_throw_error(pic_state *, struct pic_error *); struct pic_error { PIC_OBJECT_HEADER diff --git a/src/error.c b/src/error.c index 773b5d2c..21f6d487 100644 --- a/src/error.c +++ b/src/error.c @@ -87,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) { @@ -97,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) { @@ -109,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 @@ -146,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/macro.c b/src/macro.c index 1a0ed192..ea200e7d 100644 --- a/src/macro.c +++ b/src/macro.c @@ -246,7 +246,7 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr) pic_catch { /* restores pic->lib even if an error occurs */ pic_in_library(pic, prev->name); - pic_throw(pic, pic->err); + pic_throw_error(pic, pic->err); } return pic_none_value(); From d810e426668dac933608fcc3bb4a6f79ce7e0002 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Jul 2014 13:32:54 +0900 Subject: [PATCH 109/200] throw READ_ERROR when parser raised --- src/read.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index 47321029..5ea58f4a 100644 --- a/src/read.c +++ b/src/read.c @@ -20,7 +20,7 @@ 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 From 6614f8fc4f964d36a05921d64c579e5e2c58a99d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 4 Jul 2014 13:44:30 +0900 Subject: [PATCH 110/200] support #true and #false literals --- src/read.c | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index 5ea58f4a..7c995499 100644 --- a/src/read.c +++ b/src/read.c @@ -48,6 +48,19 @@ 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 != next(port)) + return false; + } + + return true; +} + static bool isdelim(char c) { @@ -250,13 +263,26 @@ 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 From 351d7948c07c20c24a31ebd30be46b731e655b29 Mon Sep 17 00:00:00 2001 From: "Sunrim KIM (keen)" <3han5chou7@gmail.com> Date: Mon, 7 Jul 2014 04:16:40 +0900 Subject: [PATCH 111/200] fix bug of `{bytevector, vector}-copy!` with the same src and dst --- piclib/built-in.scm | 42 +++++++++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 15 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 3f6eb5a7..c57aef21 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -777,14 +777,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)) @@ -836,14 +842,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)) From 7aa17f5d1f7d347f0e1ab276d11bed8b6807b6fa Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 11 Jul 2014 22:44:44 +0900 Subject: [PATCH 112/200] read rational '123/456' literal --- src/read.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/read.c b/src/read.c index 7c995499..3979755c 100644 --- a/src/read.c +++ b/src/read.c @@ -192,17 +192,25 @@ read_number(pic_state *pic, struct pic_port *port, char c) { char buf[256]; size_t i; + long n; i = read_uinteger(pic, port, c, buf); - 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)); - } - else { + + case '/': + n = atoi(buf); + next(port); + read_uinteger(pic, port, next(port), buf); + return pic_float_value(n / (double)atoi(buf)); + + default: return pic_int_value(atoi(buf)); } } From 03bffef7488358cf0002855cd3409b0dbc853ae5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 00:03:09 +0900 Subject: [PATCH 113/200] 'make tak' broken --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 12347110..c9311e1b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -49,7 +49,7 @@ add_custom_target(no-act bin/picrin -e '' > /dev/null DEPENDS repl) 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}) From 82de3cfe2f92f0a3dfc91e7085940e19871acff2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 10:58:13 +0900 Subject: [PATCH 114/200] add pic_dict_new --- include/picrin/dict.h | 2 ++ src/dict.c | 15 ++++++++++++--- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/include/picrin/dict.h b/include/picrin/dict.h index bb720534..7d969818 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -17,6 +17,8 @@ struct pic_dict { #define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) #define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v)) +struct pic_dict *pic_dict_new(pic_state *); + #if defined(__cplusplus) } #endif diff --git a/src/dict.c b/src/dict.c index ddbe2cb5..9789f117 100644 --- a/src/dict.c +++ b/src/dict.c @@ -5,6 +5,17 @@ #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; +} + static pic_value pic_dict_dict(pic_state *pic) { @@ -12,9 +23,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); } From 56ae4de82643c0d4c7d48c0665a806b6ca7ffa3f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 10:58:21 +0900 Subject: [PATCH 115/200] add attribute information to closure objects --- include/picrin/proc.h | 3 +++ src/gc.c | 3 +++ src/proc.c | 12 ++++++++++++ 3 files changed, 18 insertions(+) diff --git a/include/picrin/proc.h b/include/picrin/proc.h index d96fb6c3..039a4384 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -31,6 +31,7 @@ struct pic_proc { struct pic_irep *irep; } u; struct pic_env *env; + struct pic_dict *attr; }; #define PIC_PROC_KIND_FUNC 1 @@ -50,6 +51,8 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en pic_sym pic_proc_name(struct pic_proc *); +struct pic_dict *pic_proc_attr(pic_state *, struct pic_proc *); + /* closed variables accessor */ void pic_proc_cv_init(pic_state *, struct pic_proc *, size_t); int pic_proc_cv_size(pic_state *, struct pic_proc *); diff --git a/src/gc.c b/src/gc.c index efbd98f5..ea3c35b3 100644 --- a/src/gc.c +++ b/src/gc.c @@ -381,6 +381,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); } diff --git a/src/proc.c b/src/proc.c index d4c73d7a..0fec6ac3 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,6 +49,15 @@ pic_proc_name(struct pic_proc *proc) UNREACHABLE(); } +struct pic_dict * +pic_proc_attr(pic_state *pic, struct pic_proc *proc) +{ + if (proc->attr == NULL) { + proc->attr = pic_dict_new(pic); + } + return proc->attr; +} + void pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size) { From 378f01fa03be80fd8c2e1ca55cfafade5bda72ab Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 11:01:23 +0900 Subject: [PATCH 116/200] add attribute function --- src/proc.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/proc.c b/src/proc.c index 0fec6ac3..cfb9bcbb 100644 --- a/src/proc.c +++ b/src/proc.c @@ -218,6 +218,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_proc_attr(pic, proc)); +} + void pic_init_proc(pic_state *pic) { @@ -225,4 +235,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); + } } From fce57ec8c9336415bd163c0b55dba66b2bf8d72b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 14:41:56 +0900 Subject: [PATCH 117/200] remove get_var_from_proc (essentially the same as pic_unwrap_var) --- src/var.c | 44 +++++++++++++++++++------------------------- 1 file changed, 19 insertions(+), 25 deletions(-) diff --git a/src/var.c b/src/var.c index e667966d..16f29064 100644 --- a/src/var.c +++ b/src/var.c @@ -43,27 +43,6 @@ pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value) var->value = value; } -static struct pic_var * -get_var_from_proc(pic_state *pic, struct pic_proc *proc) -{ - pic_value v; - - if (! pic_proc_func_p(proc)) { - 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); - - typeerror: - pic_errorf(pic, "expected parameter, but got ~s", v); -} - static pic_value var_call(pic_state *pic) { @@ -105,7 +84,22 @@ pic_wrap_var(pic_state *pic, struct pic_var *var) struct pic_var * pic_unwrap_var(pic_state *pic, struct pic_proc *proc) { - return get_var_from_proc(pic, proc); + pic_value v; + + if (! pic_proc_func_p(proc)) { + 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); + + typeerror: + pic_errorf(pic, "expected parameter, but got ~s", v); } static pic_value @@ -129,7 +123,7 @@ pic_var_parameter_ref(pic_state *pic) pic_get_args(pic, "l", &proc); - var = get_var_from_proc(pic, proc); + var = pic_unwrap_var(pic, proc); return pic_var_ref(pic, var); } @@ -142,7 +136,7 @@ pic_var_parameter_set(pic_state *pic) pic_get_args(pic, "lo", &proc, &v); - var = get_var_from_proc(pic, proc); + var = pic_unwrap_var(pic, proc); /* no convert */ pic_var_set_force(pic, var, v); return pic_none_value(); @@ -156,7 +150,7 @@ pic_var_parameter_converter(pic_state *pic) pic_get_args(pic, "l", &proc); - var = get_var_from_proc(pic, proc); + var = pic_unwrap_var(pic, proc); if (var->conv) { return pic_obj_value(var->conv); } From 13fec26c592966b86e33064d36bae07a106fce8a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 14:47:18 +0900 Subject: [PATCH 118/200] remove var accessor and mutators --- include/picrin/var.h | 4 ---- src/var.c | 56 ++++++++++++++++++++++---------------------- 2 files changed, 28 insertions(+), 32 deletions(-) diff --git a/include/picrin/var.h b/include/picrin/var.h index bc098200..883b4612 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -23,10 +23,6 @@ struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc *); struct pic_proc *pic_wrap_var(pic_state *, struct pic_var *); struct pic_var *pic_unwrap_var(pic_state *, struct pic_proc *); -pic_value pic_var_ref(pic_state *, struct pic_var *); -void pic_var_set(pic_state *, struct pic_var *, pic_value); -void pic_var_set_force(pic_state *, struct pic_var *, pic_value); - #if defined(__cplusplus) } #endif diff --git a/src/var.c b/src/var.c index 16f29064..41dd7fef 100644 --- a/src/var.c +++ b/src/var.c @@ -6,6 +6,29 @@ #include "picrin/proc.h" #include "picrin/var.h" +static pic_value +var_ref(pic_state *pic, struct pic_var *var) +{ + UNUSED(pic); + return var->value; +} + +static void +var_set_force(pic_state *pic, struct pic_var *var, pic_value value) +{ + UNUSED(pic); + var->value = value; +} + +static void +var_set(pic_state *pic, struct pic_var *var, pic_value value) +{ + if (var->conv) { + value = pic_apply1(pic, var->conv, value); + } + var_set_force(pic, var, value); +} + struct pic_var * pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */) { @@ -15,34 +38,11 @@ pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv /* = NULL */) var->value = pic_undef_value(); var->conv = conv; - pic_var_set(pic, var, init); + var_set(pic, var, init); return var; } -pic_value -pic_var_ref(pic_state *pic, struct pic_var *var) -{ - UNUSED(pic); - return var->value; -} - -void -pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv) { - value = pic_apply1(pic, var->conv, value); - } - pic_var_set_force(pic, var, value); -} - -void -pic_var_set_force(pic_state *pic, struct pic_var *var, pic_value value) -{ - UNUSED(pic); - var->value = value; -} - static pic_value var_call(pic_state *pic) { @@ -56,12 +56,12 @@ var_call(pic_state *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); + return var_ref(pic, var); } else if (c == 1) { var = pic_var_ptr(proc->env->regs[0]); - pic_var_set(pic, var, v); + var_set(pic, var, v); return pic_none_value(); } else { @@ -124,7 +124,7 @@ pic_var_parameter_ref(pic_state *pic) pic_get_args(pic, "l", &proc); var = pic_unwrap_var(pic, proc); - return pic_var_ref(pic, var); + return var_ref(pic, var); } static pic_value @@ -138,7 +138,7 @@ pic_var_parameter_set(pic_state *pic) var = pic_unwrap_var(pic, proc); /* no convert */ - pic_var_set_force(pic, var, v); + var_set_force(pic, var, v); return pic_none_value(); } From fe375a7224067a5b35a9ea546e2a87f0b516857f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 22:07:06 +0900 Subject: [PATCH 119/200] add pic_funcall --- include/picrin.h | 2 ++ src/vm.c | 12 ++++++++++++ 2 files changed, 14 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index 0e673dca..ec799d96 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -135,6 +135,8 @@ void pic_define(pic_state *, const char *, pic_value); /* automatic export */ pic_value pic_ref(pic_state *, const char *); void pic_set(pic_state *, const char *, pic_value); +pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); + struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); void pic_defun(pic_state *, const char *, pic_func_t); diff --git a/src/vm.c b/src/vm.c index 9e4509f4..432921d1 100644 --- a/src/vm.c +++ b/src/vm.c @@ -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) { From 05309a1d384cf81c2e52c168d65cdf2c0be369bb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 22:20:49 +0900 Subject: [PATCH 120/200] don't use pic_defvar --- include/picrin.h | 1 - piclib/built-in.scm | 10 ++++++++++ src/port.c | 8 +++++--- src/vm.c | 9 --------- 4 files changed, 15 insertions(+), 13 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index ec799d96..2bf9f9fd 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -141,7 +141,6 @@ struct pic_proc *pic_get_proc(pic_state *); int pic_get_args(pic_state *, const char *, ...); void pic_defun(pic_state *, const char *, pic_func_t); void pic_defmacro(pic_state *, const char *, struct pic_proc *); -void pic_defvar(pic_state *, const char *, pic_value); bool pic_equal_p(pic_state *, pic_value, pic_value); diff --git a/piclib/built-in.scm b/piclib/built-in.scm index c57aef21..d5a7b726 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -950,6 +950,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) diff --git a/src/port.c b/src/port.c index 2da85177..42ba0863 100644 --- a/src/port.c +++ b/src/port.c @@ -684,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/vm.c b/src/vm.c index 432921d1..cfa8355c 100644 --- a/src/vm.c +++ b/src/vm.c @@ -465,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) { From 114e4459015ea5da207cc4031b536ea0e0e0f8ff Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 22:21:02 +0900 Subject: [PATCH 121/200] get rid of doubled semicolons --- src/port.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/port.c b/src/port.c index 42ba0863..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); @@ -353,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; From c3106a96082276c72daabce0557042d0d1df7b9f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 22:21:19 +0900 Subject: [PATCH 122/200] improve error message --- src/vm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/vm.c b/src/vm.c index cfa8355c..0063cb92 100644 --- a/src/vm.c +++ b/src/vm.c @@ -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]; } From 7ffcbb7a7deade7dd9e2684ba7b234eb13cff540 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 12 Jul 2014 22:30:50 +0900 Subject: [PATCH 123/200] refactor var. c api no longer supports converters. --- include/picrin/var.h | 7 +-- piclib/built-in.scm | 35 +++++++++-- src/gc.c | 3 - src/var.c | 142 +++++++++++++------------------------------ 4 files changed, 75 insertions(+), 112 deletions(-) diff --git a/include/picrin/var.h b/include/picrin/var.h index 883b4612..73afaaba 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -12,16 +12,15 @@ extern "C" { struct pic_var { PIC_OBJECT_HEADER pic_value value; - struct pic_proc *conv; }; #define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) #define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o)) -struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc *); +struct pic_var *pic_var_new(pic_state *, pic_value); -struct pic_proc *pic_wrap_var(pic_state *, struct pic_var *); -struct pic_var *pic_unwrap_var(pic_state *, struct pic_proc *); +pic_value pic_var_ref(pic_state *, const char *); +void pic_var_set(pic_state *, const char *, pic_value); #if defined(__cplusplus) } diff --git a/piclib/built-in.scm b/piclib/built-in.scm index d5a7b726..f598310a 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -410,10 +410,34 @@ (import (scheme base) (scheme cxr) (picrin macro) - (picrin core-syntax)) + (picrin core-syntax) + (picrin var)) - ;; 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)))) + (lambda 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")))))) + + (define (make-parameter init . conv) + (let ((conv + (if (null? conv) + (lambda (x) x) + (car conv)))) + (%make-parameter init conv))) (define-syntax parameterize (er-macro-transformer @@ -432,11 +456,12 @@ ,@bindings (,(r 'let) ((,(r 'result) (begin ,@body))) ,@(map (lambda (var) - `(,(r 'parameter-set!) ,var ,(r (gensym var)))) + `(,var ,(r (gensym var)) (,(r 'lambda) (x) x))) vars) ,(r 'result)))))))) - (export parameterize)) + (export make-parameter + parameterize)) ;;; Record Type (define-library (picrin record) diff --git a/src/gc.c b/src/gc.c index ea3c35b3..cfaffa60 100644 --- a/src/gc.c +++ b/src/gc.c @@ -476,9 +476,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_VAR: { struct pic_var *var = (struct pic_var *)obj; gc_mark(pic, var->value); - if (var->conv) { - gc_mark_object(pic, (struct pic_object *)var->conv); - } break; } case PIC_TT_IREP: { diff --git a/src/var.c b/src/var.c index 41dd7fef..76d3c297 100644 --- a/src/var.c +++ b/src/var.c @@ -14,158 +14,100 @@ var_ref(pic_state *pic, struct pic_var *var) } static void -var_set_force(pic_state *pic, struct pic_var *var, pic_value value) +var_set(pic_state *pic, struct pic_var *var, pic_value value) { UNUSED(pic); var->value = value; } -static void -var_set(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv) { - value = pic_apply1(pic, var->conv, value); - } - var_set_force(pic, var, value); -} - 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_set(pic, var, init); + var->value = init; return var; } -static pic_value -var_call(pic_state *pic) +pic_value +pic_var_ref(pic_state *pic, const char *name) { - struct pic_proc *proc; + pic_value v; struct pic_var *var; - pic_value v; - int c; - proc = pic_get_proc(pic); + v = pic_ref(pic, name); - c = pic_get_args(pic, "|o", &v); - if (c == 0) { - var = pic_var_ptr(proc->env->regs[0]); - return var_ref(pic, var); - } - else if (c == 1) { - var = pic_var_ptr(proc->env->regs[0]); + pic_assert_type(pic, v, var); - var_set(pic, var, v); - return pic_none_value(); - } - else { - pic_abort(pic, "logic flaw"); - } - UNREACHABLE(); + var = pic_var_ptr(v); + + return var_ref(pic, var); } -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) +void +pic_var_set(pic_state *pic, const char *name, pic_value value) { pic_value v; + struct pic_var *var; - if (! pic_proc_func_p(proc)) { - 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_errorf(pic, "expected parameter, but got ~s", v); + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + + var_set(pic, var, value); } static pic_value -pic_var_make_parameter(pic_state *pic) +pic_var_make_var(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_value v; - pic_get_args(pic, "l", &proc); + pic_get_args(pic, "o", &v); + + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); - var = pic_unwrap_var(pic, proc); return var_ref(pic, var); } static pic_value -pic_var_parameter_set(pic_state *pic) +pic_var_var_set(pic_state *pic) { - struct pic_proc *proc; struct pic_var *var; - pic_value v; + pic_value v, val; - pic_get_args(pic, "lo", &proc, &v); + pic_get_args(pic, "oo", &v, &val); + + pic_assert_type(pic, v, var); + + var = pic_var_ptr(v); + var_set(pic, var, val); - var = pic_unwrap_var(pic, proc); - /* no convert */ - var_set_force(pic, var, v); return pic_none_value(); } -static pic_value -pic_var_parameter_converter(pic_state *pic) -{ - struct pic_proc *proc; - struct pic_var *var; - - pic_get_args(pic, "l", &proc); - - var = pic_unwrap_var(pic, proc); - if (var->conv) { - return pic_obj_value(var->conv); - } - else { - return pic_false_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); } } From 9e8d53088facac4c364c97982e415fb18449aa28 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 00:23:33 +0900 Subject: [PATCH 124/200] add pic_set_c[ad]r --- include/picrin/pair.h | 2 ++ src/pair.c | 26 ++++++++++++++++++++++++++ 2 files changed, 28 insertions(+) diff --git a/include/picrin/pair.h b/include/picrin/pair.h index 64d5d1cb..1f7fccfa 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -21,6 +21,8 @@ struct pic_pair { pic_value pic_cons(pic_state *, pic_value, pic_value); pic_value pic_car(pic_state *, pic_value); pic_value pic_cdr(pic_state *, pic_value); +void pic_set_car(pic_state *, pic_value, pic_value); +void pic_set_cdr(pic_state *, pic_value, pic_value); bool pic_list_p(pic_value); pic_value pic_list1(pic_state *, pic_value); diff --git a/src/pair.c b/src/pair.c index bb4ef0bb..499b7bb5 100644 --- a/src/pair.c +++ b/src/pair.c @@ -45,6 +45,32 @@ pic_cdr(pic_state *pic, pic_value obj) return pair->cdr; } +void +pic_set_car(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_error(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->car = val; +} + +void +pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) +{ + struct pic_pair *pair; + + if (! pic_pair_p(obj)) { + pic_error(pic, "pair required"); + } + pair = pic_pair_ptr(obj); + + pair->cdr = val; +} + bool pic_list_p(pic_value obj) { From 2c4fd589bf86eb5a3f649b335a545def51140cdd Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 00:48:03 +0900 Subject: [PATCH 125/200] manage values in a stack --- include/picrin/var.h | 4 ++- src/gc.c | 2 +- src/var.c | 85 ++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 83 insertions(+), 8 deletions(-) diff --git a/include/picrin/var.h b/include/picrin/var.h index 73afaaba..9926c092 100644 --- a/include/picrin/var.h +++ b/include/picrin/var.h @@ -11,7 +11,7 @@ extern "C" { struct pic_var { PIC_OBJECT_HEADER - pic_value value; + pic_value stack; }; #define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) @@ -21,6 +21,8 @@ struct pic_var *pic_var_new(pic_state *, pic_value); pic_value pic_var_ref(pic_state *, const char *); void pic_var_set(pic_state *, const char *, pic_value); +void pic_var_push(pic_state *, const char *, pic_value); +void pic_var_pop(pic_state *, const char *); #if defined(__cplusplus) } diff --git a/src/gc.c b/src/gc.c index cfaffa60..97532671 100644 --- a/src/gc.c +++ b/src/gc.c @@ -475,7 +475,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_VAR: { struct pic_var *var = (struct pic_var *)obj; - gc_mark(pic, var->value); + gc_mark(pic, var->stack); break; } case PIC_TT_IREP: { diff --git a/src/var.c b/src/var.c index 76d3c297..9cbb00e5 100644 --- a/src/var.c +++ b/src/var.c @@ -3,21 +3,31 @@ */ #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) { - UNUSED(pic); - return var->value; + return pic_car(pic, var->stack); } static void var_set(pic_state *pic, struct pic_var *var, pic_value value) { - UNUSED(pic); - var->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 * @@ -26,7 +36,9 @@ 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 = init; + var->stack = pic_nil_value(); + + var_push(pic, var, init); return var; } @@ -61,6 +73,36 @@ pic_var_set(pic_state *pic, const char *name, pic_value value) var_set(pic, var, value); } +void +pic_var_push(pic_state *pic, const char *name, pic_value 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_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 pic_var_make_var(pic_state *pic) { @@ -98,7 +140,36 @@ pic_var_var_set(pic_state *pic) var = pic_var_ptr(v); var_set(pic, var, val); + return pic_none_value(); +} +static pic_value +pic_var_var_push(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_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(); } @@ -109,5 +180,7 @@ pic_init_var(pic_state *pic) 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); } } From 9c78a9a51f70fc2afab146bbd7e20ab274ac4456 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 00:56:09 +0900 Subject: [PATCH 126/200] refactor parameterize --- piclib/built-in.scm | 56 +++++++++++++++++++++++++++------------------ 1 file changed, 34 insertions(+), 22 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index f598310a..e2131ab2 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -411,7 +411,9 @@ (scheme cxr) (picrin macro) (picrin core-syntax) - (picrin var)) + (picrin var) + (picrin attribute) + (picrin dictionary)) (define (single? x) (and (list? x) (= (length x) 1))) @@ -421,7 +423,7 @@ (define (%make-parameter init conv) (let ((var (make-var (conv init)))) - (lambda args + (define (parameter . args) (cond ((null? args) (var-ref var)) @@ -430,7 +432,11 @@ ((double? args) (var-set! var ((cadr args) (car args)))) (else - (error "invalid arguments for parameter")))))) + (error "invalid arguments for parameter")))) + + (dictionary-set! (attribute parameter) '@@var var) + + parameter)) (define (make-parameter init . conv) (let ((conv @@ -439,26 +445,32 @@ (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) - `(,var ,(r (gensym var)) (,(r 'lambda) (x) x))) - 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 make-parameter parameterize)) From b0474aaec21dfb4fb410812023378d4d496f5619 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 12:07:07 +0900 Subject: [PATCH 127/200] add dictionary operators --- include/picrin/dict.h | 5 ++++ src/dict.c | 55 +++++++++++++++++++++++++++++++++---------- 2 files changed, 47 insertions(+), 13 deletions(-) diff --git a/include/picrin/dict.h b/include/picrin/dict.h index 7d969818..ae118e13 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -19,6 +19,11 @@ struct pic_dict { struct pic_dict *pic_dict_new(pic_state *); +pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym); +void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value); +void pic_dict_del(pic_state *, struct pic_dict *, pic_sym); +size_t pic_dict_size(pic_state *, struct pic_dict *); + #if defined(__cplusplus) } #endif diff --git a/src/dict.c b/src/dict.c index 9789f117..2f7088cd 100644 --- a/src/dict.c +++ b/src/dict.c @@ -16,6 +16,44 @@ pic_dict_new(pic_state *pic) 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; +} + +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) { @@ -43,15 +81,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 @@ -63,7 +96,7 @@ 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(); } @@ -76,11 +109,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(); } @@ -92,7 +121,7 @@ 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)); } void From 88593b1f9d2e10200e721b70024e48e311b144e7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 12:07:56 +0900 Subject: [PATCH 128/200] rename 'dictionary' 'make-dictionary' --- src/dict.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dict.c b/src/dict.c index 2f7088cd..6c8fb3c5 100644 --- a/src/dict.c +++ b/src/dict.c @@ -128,7 +128,7 @@ 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-ref", pic_dict_dict_ref); pic_defun(pic, "dictionary-set!", pic_dict_dict_set); From 71677d3e85b5640d2446461692ddc459ebfdaefc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 12:18:39 +0900 Subject: [PATCH 129/200] add dictionary.scm --- piclib/CMakeLists.txt | 1 + piclib/picrin/dictionary.scm | 31 +++++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+) create mode 100644 piclib/picrin/dictionary.scm diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 497d8cd1..49f1c4b3 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,5 +1,6 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/built-in.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm new file mode 100644 index 00000000..ac23f8ab --- /dev/null +++ b/piclib/picrin/dictionary.scm @@ -0,0 +1,31 @@ +(define-library (picrin dictionary) + (import (scheme base)) + + (define (dictionary->plist dict) + (error "not implemented")) + + (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) + (error "not implemented")) + + (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->plist + plist->dictionary + dictionary->alist + alist->dictionary)) From 9e5b019e449d8a9fff63e6a76d90adfe94cf6aaa Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 12:27:03 +0900 Subject: [PATCH 130/200] add dictionary-for-each --- src/dict.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/dict.c b/src/dict.c index 6c8fb3c5..e9fd5e80 100644 --- a/src/dict.c +++ b/src/dict.c @@ -124,6 +124,23 @@ pic_dict_dict_size(pic_state *pic) 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) { @@ -134,5 +151,6 @@ pic_init_dict(pic_state *pic) 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); } } From b7a44ee8106a25a30da052c6d67b05e49e52ef91 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 12:33:13 +0900 Subject: [PATCH 131/200] fix not-implemented errors --- piclib/picrin/dictionary.scm | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm index ac23f8ab..a532b2e4 100644 --- a/piclib/picrin/dictionary.scm +++ b/piclib/picrin/dictionary.scm @@ -1,8 +1,21 @@ (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) - (error "not implemented")) + (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))) @@ -12,7 +25,10 @@ (dictionary-set! dict (car kv) (cadr kv))))) (define (dictionary->alist dict) - (error "not implemented")) + (dictionary-map + (lambda (key val) + (cons key val)) + dict)) (define (alist->dictionary alist) (let ((dict (make-dictionary))) @@ -25,6 +41,7 @@ (plist->dictionary plist)) (export dictionary + dictionary-map dictionary->plist plist->dictionary dictionary->alist From 21b21cc3cce7fd120b8475040e97f625212efa9c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 12:37:15 +0900 Subject: [PATCH 132/200] update docs --- docs/libs.rst | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/docs/libs.rst b/docs/libs.rst index 2a7a7a1f..102a1b54 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -144,9 +144,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)** @@ -168,6 +168,21 @@ 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 user) ------------- From 73c406ed42febec6809506c8563c4d0a9cd7e61e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 16:56:39 +0900 Subject: [PATCH 133/200] add translate function --- src/macro.c | 70 +++++++++++++++++++++++++++++------------------------ 1 file changed, 38 insertions(+), 32 deletions(-) diff --git a/src/macro.c b/src/macro.c index ea200e7d..6edc62b3 100644 --- a/src/macro.c +++ b/src/macro.c @@ -156,6 +156,33 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass return senv; } +static pic_sym +translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) +{ + 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; + } + if (! senv->up) + 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; + } +} + static pic_value macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) { @@ -191,31 +218,10 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu return list; } -static pic_sym +static pic_value macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) { - 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; - } - if (! senv->up) - break; - senv = senv->up; - } - x = pic_assq(pic, pic_sym_value(sym), pic_unbox(pic, assoc_box)); - if (pic_test(x)) { - return pic_sym(pic_cdr(pic, x)); - } else { - rename = pic_gensym(pic, sym); - pic_set_box(pic, assoc_box, pic_acons(pic, pic_sym_value(sym), pic_sym_value(rename), pic_unbox(pic, assoc_box))); - return rename; - } + return pic_sym_value(translate(pic, sym, senv, assoc_box)); } static pic_value @@ -499,7 +505,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu 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, assoc_box); } case PIC_TT_PAIR: { pic_value car; @@ -720,7 +726,7 @@ er_macro_rename(pic_state *pic) 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); - return pic_sym_value(macroexpand_symbol(pic, sym, mac_env, assoc_box)); + return pic_sym_value(translate(pic, sym, mac_env, assoc_box)); } static pic_value @@ -739,8 +745,8 @@ er_macro_compare(pic_state *pic) 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); + m = translate(pic, pic_sym(a), use_env, assoc_box); + n = translate(pic, pic_sym(b), use_env, assoc_box); return pic_bool_value(m == n); } @@ -805,7 +811,7 @@ ir_macro_inject(pic_state *pic) 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)); + return pic_sym_value(translate(pic, sym, use_env, assoc_box)); } static pic_value @@ -824,8 +830,8 @@ ir_macro_compare(pic_state *pic) 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); + m = translate(pic, pic_sym(a), mac_env, assoc_box); + n = translate(pic, pic_sym(b), mac_env, assoc_box); return pic_bool_value(m == n); } @@ -835,7 +841,7 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu { if (pic_sym_p(expr)) { pic_value r; - r = pic_sym_value(macroexpand_symbol(pic, pic_sym(expr), use_env, assoc_box)); + r = pic_sym_value(translate(pic, pic_sym(expr), use_env, assoc_box)); *ir = pic_acons(pic, r, expr, *ir); return r; } @@ -857,7 +863,7 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va 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)); + return pic_sym_value(translate(pic, pic_sym(expr), mac_env, assoc_box)); } else if (pic_pair_p(expr)) { return pic_cons(pic, From 54d50d57a19570608cab7f7ecc9ac6260d054956 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 17:01:55 +0900 Subject: [PATCH 134/200] add pic_dict_has --- include/picrin/dict.h | 1 + src/dict.c | 8 ++++++++ 2 files changed, 9 insertions(+) diff --git a/include/picrin/dict.h b/include/picrin/dict.h index ae118e13..8bc58ad8 100644 --- a/include/picrin/dict.h +++ b/include/picrin/dict.h @@ -23,6 +23,7 @@ pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym); void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value); void pic_dict_del(pic_state *, struct pic_dict *, pic_sym); size_t pic_dict_size(pic_state *, struct pic_dict *); +bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym); #if defined(__cplusplus) } diff --git a/src/dict.c b/src/dict.c index e9fd5e80..d3eb895b 100644 --- a/src/dict.c +++ b/src/dict.c @@ -44,6 +44,14 @@ pic_dict_size(pic_state *pic, struct pic_dict *dict) 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) { From e1cba4b48e38f295dd0e365e7d200544569563cb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 17:07:27 +0900 Subject: [PATCH 135/200] refactor translate to use pic_dict instead of boxes --- src/macro.c | 162 ++++++++++++++++++++++++++-------------------------- 1 file changed, 80 insertions(+), 82 deletions(-) diff --git a/src/macro.c b/src/macro.c index 6edc62b3..0cb7349f 100644 --- a/src/macro.c +++ b/src/macro.c @@ -9,7 +9,7 @@ #include "picrin/macro.h" #include "picrin/lib.h" #include "picrin/error.h" -#include "picrin/box.h" +#include "picrin/dict.h" struct pic_senv * pic_null_syntactic_environment(pic_state *pic) @@ -108,15 +108,15 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) pic_export(pic, sym); } -static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, pic_value); +static pic_value macroexpand_node(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { size_t ai = pic_gc_arena_preserve(pic); pic_value v; - v = macroexpand_node(pic, expr, senv, assoc_box); + v = macroexpand_node(pic, expr, senv, cxt); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); @@ -124,7 +124,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value ass } static struct pic_senv * -push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value assoc_box) +push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, struct pic_dict *cxt) { struct pic_senv *senv; pic_value a; @@ -137,7 +137,7 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass pic_value v = pic_car(pic, a); if (! pic_sym_p(v)) { - v = macroexpand(pic, v, up, assoc_box); + v = macroexpand(pic, v, up, cxt); } if (! pic_sym_p(v)) { pic_error(pic, "syntax error"); @@ -145,7 +145,7 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass pic_add_rename(pic, senv, pic_sym(v)); } if (! pic_sym_p(a)) { - a = macroexpand(pic, a, up, assoc_box); + a = macroexpand(pic, a, up, cxt); } if (pic_sym_p(a)) { pic_add_rename(pic, senv, pic_sym(a)); @@ -157,10 +157,9 @@ push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, pic_value ass } static pic_sym -translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) +translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { pic_sym rename; - pic_value x; if (! pic_interned_p(pic, sym)) { return sym; @@ -173,18 +172,17 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_bo 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)); + if (pic_dict_has(pic, cxt, sym)) { + return pic_sym(pic_dict_ref(pic, cxt, sym)); } 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))); + pic_dict_set(pic, cxt, sym, pic_sym_value(rename)); return rename; } } static pic_value -macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_value assoc_box) +macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt) { size_t ai = pic_gc_arena_preserve(pic); pic_value v, vs; @@ -194,7 +192,7 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu while (pic_pair_p(list)) { v = pic_car(pic, list); - vs = pic_cons(pic, macroexpand(pic, v, senv, assoc_box), vs); + vs = pic_cons(pic, macroexpand(pic, v, senv, cxt), vs); list = pic_cdr(pic, list); pic_gc_arena_restore(pic, ai); @@ -202,7 +200,7 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu pic_gc_protect(pic, list); } - list = macroexpand(pic, list, senv, assoc_box); + list = macroexpand(pic, list, senv, cxt); /* reverse the result */ pic_for_each (v, vs) { @@ -219,9 +217,9 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, pic_valu } static pic_value -macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, pic_value assoc_box) +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { - return pic_sym_value(translate(pic, sym, senv, assoc_box)); + return pic_sym_value(translate(pic, sym, senv, cxt)); } static pic_value @@ -307,7 +305,7 @@ 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_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { pic_value var, val; pic_sym sym, rename; @@ -318,7 +316,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, pic var = pic_cadr(pic, expr); if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, assoc_box); + var = macroexpand(pic, var, senv, cxt); } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); @@ -393,7 +391,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) } static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { pic_sym sym; pic_value formals; @@ -404,13 +402,13 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va formals = pic_cadr(pic, expr); if (pic_pair_p(formals)) { - struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, assoc_box); + struct pic_senv *in = push_scope(pic, pic_cdr(pic, formals), senv, cxt); pic_value a; /* defined symbol */ a = pic_car(pic, formals); if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv, assoc_box); + a = macroexpand(pic, a, senv, cxt); } if (! pic_sym_p(a)) { pic_error(pic, "binding to non-symbol object"); @@ -423,12 +421,12 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va /* 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))); + macroexpand_list(pic, pic_cadr(pic, expr), in, cxt), + macroexpand_list(pic, pic_cddr(pic, expr), in, cxt))); } if (! pic_sym_p(formals)) { - formals = macroexpand(pic, formals, senv, assoc_box); + formals = macroexpand(pic, formals, senv, cxt); } if (! pic_sym_p(formals)) { pic_error(pic, "binding to non-symbol object"); @@ -438,18 +436,18 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_va pic_add_rename(pic, senv, sym); } - return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, assoc_box)); + return pic_cons(pic, pic_sym_value(pic->sDEFINE), macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt)); } static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_value assoc_box) +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { - struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, assoc_box); + struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, cxt); 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))); + macroexpand_list(pic, pic_cadr(pic, expr), in, cxt), + macroexpand_list(pic, pic_cddr(pic, expr), in, cxt))); } static pic_value @@ -459,7 +457,7 @@ macroexpand_quote(pic_state *pic, pic_value 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, struct pic_dict *cxt) { pic_value v, args; @@ -488,11 +486,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, cxt); } 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, struct pic_dict *cxt) { #if DEBUG printf("[macroexpand] expanding... "); @@ -502,10 +500,10 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu switch (pic_type(expr)) { case PIC_TT_SC: { - return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, assoc_box); + return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt); } case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym(expr), senv, assoc_box); + return macroexpand_symbol(pic, pic_sym(expr), senv, cxt); } case PIC_TT_PAIR: { pic_value car; @@ -515,7 +513,7 @@ 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, cxt); if (pic_sym_p(car)) { pic_sym tag = pic_sym(car); @@ -529,27 +527,27 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu return macroexpand_export(pic, expr); } else if (tag == pic->sDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, senv, assoc_box); + return macroexpand_defsyntax(pic, expr, senv, cxt); } else if (tag == pic->sDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } else if (tag == pic->sLAMBDA) { - return macroexpand_lambda(pic, expr, senv, assoc_box); + return macroexpand_lambda(pic, expr, senv, cxt); } else if (tag == pic->sDEFINE) { - return macroexpand_define(pic, expr, senv, assoc_box); + return macroexpand_define(pic, expr, senv, cxt); } else if (tag == pic->sQUOTE) { 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, cxt); } } - 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, cxt)); } case PIC_TT_EOF: case PIC_TT_NIL: @@ -584,7 +582,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, pic_valu pic_value pic_macroexpand(pic_state *pic, pic_value expr) { - pic_value v, box; + pic_value v; #if DEBUG puts("before expand:"); @@ -592,9 +590,7 @@ pic_macroexpand(pic_state *pic, pic_value expr) puts(""); #endif - box = pic_box(pic, pic_nil_value()); - - v = macroexpand(pic, expr, pic->lib->senv, box); + v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic)); #if DEBUG puts("after expand:"); @@ -653,16 +649,16 @@ sc_identifier_p(pic_value obj) 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; + struct pic_dict *cxt; if (! (sc_identifier_p(x) && sc_identifier_p(y))) { return false; } - box = pic_box(pic, pic_nil_value()); + cxt = pic_dict_new(pic); - x = macroexpand(pic, x, e1, box); - y = macroexpand(pic, y, e2, box); + x = macroexpand(pic, x, e1, cxt); + y = macroexpand(pic, y, e2, cxt); return pic_eq_p(x, y); } @@ -719,14 +715,14 @@ er_macro_rename(pic_state *pic) { pic_sym sym; struct pic_senv *mac_env; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "m", &sym); 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); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - return pic_sym_value(translate(pic, sym, mac_env, assoc_box)); + return pic_sym_value(translate(pic, sym, mac_env, cxt)); } static pic_value @@ -735,7 +731,7 @@ er_macro_compare(pic_state *pic) pic_value a, b; struct pic_senv *use_env; pic_sym m, n; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "oo", &a, &b); @@ -743,10 +739,10 @@ er_macro_compare(pic_state *pic) 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); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - m = translate(pic, pic_sym(a), use_env, assoc_box); - n = translate(pic, pic_sym(b), use_env, assoc_box); + m = translate(pic, pic_sym(a), use_env, cxt); + n = translate(pic, pic_sym(b), use_env, cxt); return pic_bool_value(m == n); } @@ -754,8 +750,9 @@ er_macro_compare(pic_state *pic) static pic_value er_macro_call(pic_state *pic) { - pic_value expr, use_env, mac_env, box; + pic_value expr, use_env, mac_env; struct pic_proc *rename, *compare, *cb; + struct pic_dict *cxt; pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); @@ -766,19 +763,19 @@ er_macro_call(pic_state *pic) pic_error(pic, "unexpected type of argument 3"); } - box = pic_box(pic, pic_nil_value()); + cxt = pic_dict_new(pic); 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); + pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt)); 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); + pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt)); cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); @@ -804,14 +801,14 @@ ir_macro_inject(pic_state *pic) { pic_sym sym; struct pic_senv *use_env; - pic_value assoc_box; + struct pic_dict *cxt; 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); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - return pic_sym_value(translate(pic, sym, use_env, assoc_box)); + return pic_sym_value(translate(pic, sym, use_env, cxt)); } static pic_value @@ -820,7 +817,7 @@ ir_macro_compare(pic_state *pic) pic_value a, b; struct pic_senv *mac_env; pic_sym m, n; - pic_value assoc_box; + struct pic_dict *cxt; pic_get_args(pic, "oo", &a, &b); @@ -828,27 +825,27 @@ ir_macro_compare(pic_state *pic) 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); + cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - m = translate(pic, pic_sym(a), mac_env, assoc_box); - n = translate(pic, pic_sym(b), mac_env, assoc_box); + m = translate(pic, pic_sym(a), mac_env, cxt); + n = translate(pic, pic_sym(b), mac_env, cxt); 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) +ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir) { if (pic_sym_p(expr)) { pic_value r; - r = pic_sym_value(translate(pic, pic_sym(expr), use_env, assoc_box)); + r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt)); *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)); + ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir), + ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir)); } else { return expr; @@ -856,19 +853,19 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu } static pic_value -ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_value assoc_box, pic_value *ir) +ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, 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(translate(pic, pic_sym(expr), mac_env, assoc_box)); + return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt)); } 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)); + ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir), + ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir)); } else { return expr; @@ -878,8 +875,9 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_va static pic_value ir_macro_call(pic_state *pic) { - pic_value expr, use_env, mac_env, box; + pic_value expr, use_env, mac_env; struct pic_proc *inject, *compare, *cb; + struct pic_dict *cxt; pic_value ir = pic_nil_value(); pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); @@ -891,25 +889,25 @@ ir_macro_call(pic_state *pic) pic_error(pic, "unexpected type of argument 3"); } - box = pic_box(pic, pic_nil_value()); + cxt = pic_dict_new(pic); 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); + pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt)); 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); + pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt)); 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 = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &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); + expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir); return expr; } From 601b54ba1f42c2b15d467c8c025fa055eb00673c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 20:06:08 +0900 Subject: [PATCH 136/200] cosmetic changes --- src/macro.c | 108 ++++++++++++++++++++++++++-------------------------- 1 file changed, 54 insertions(+), 54 deletions(-) diff --git a/src/macro.c b/src/macro.c index 0cb7349f..3181dd22 100644 --- a/src/macro.c +++ b/src/macro.c @@ -11,31 +11,7 @@ #include "picrin/error.h" #include "picrin/dict.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); - } -} +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) @@ -94,35 +70,6 @@ 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 *, struct pic_dict *); - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - - v = macroexpand_node(pic, expr, senv, cxt); - - 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, struct pic_dict *cxt) { @@ -579,6 +526,19 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p UNREACHABLE(); } +static pic_value +macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + size_t ai = pic_gc_arena_preserve(pic); + pic_value v; + + v = macroexpand_node(pic, expr, senv, cxt); + + pic_gc_arena_restore(pic, ai); + pic_gc_protect(pic, v); + return v; +} + pic_value pic_macroexpand(pic_state *pic, pic_value expr) { @@ -601,6 +561,46 @@ pic_macroexpand(pic_state *pic, pic_value expr) return v; } +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); + } +} + +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 pic_macro_gensym(pic_state *pic) { From 6d20c0e3e01f78a4da09890503563b87268df0a7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 20:09:42 +0900 Subject: [PATCH 137/200] cosmetic changes again --- src/macro.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/macro.c b/src/macro.c index 3181dd22..5259a198 100644 --- a/src/macro.c +++ b/src/macro.c @@ -389,12 +389,15 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct static pic_value macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { - struct pic_senv *in = push_scope(pic, pic_cadr(pic, expr), senv, cxt); + pic_value formal, body; + struct pic_senv *in; - return pic_cons(pic, pic_sym_value(pic->sLAMBDA), - pic_cons(pic, - macroexpand_list(pic, pic_cadr(pic, expr), in, cxt), - macroexpand_list(pic, pic_cddr(pic, expr), in, cxt))); + in = push_scope(pic, pic_cadr(pic, expr), senv, cxt); + + formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt); + body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt); + + return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body)); } static pic_value From 631926aa96596d83e1b3b1923cb83dcbbde59c49 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 20:19:45 +0900 Subject: [PATCH 138/200] function reorder --- src/macro.c | 207 ++++++++++++++++++++++++++-------------------------- 1 file changed, 103 insertions(+), 104 deletions(-) diff --git a/src/macro.c b/src/macro.c index 5259a198..683c429b 100644 --- a/src/macro.c +++ b/src/macro.c @@ -128,41 +128,6 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c } } -static pic_value -macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt) -{ - 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, cxt), 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, cxt); - - /* 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_value macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { @@ -170,37 +135,9 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pi } static pic_value -macroexpand_deflibrary(pic_state *pic, pic_value expr) +macroexpand_quote(pic_state *pic, pic_value expr) { - struct pic_lib *prev = pic->lib; - pic_value v; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - pic_make_library(pic, pic_cadr(pic, expr)); - - pic_try { - pic_in_library(pic, pic_cadr(pic, expr)); - - pic_for_each (v, pic_cddr(pic, expr)) { - size_t ai = pic_gc_arena_preserve(pic); - - pic_eval(pic, v); - - pic_gc_arena_restore(pic, ai); - } - - pic_in_library(pic, prev->name); - } - pic_catch { - /* restores pic->lib even if an error occurs */ - pic_in_library(pic, prev->name); - pic_throw_error(pic, pic->err); - } - - return pic_none_value(); + return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -251,6 +188,39 @@ macroexpand_export(pic_state *pic, pic_value expr) return pic_none_value(); } +static pic_value +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)) { + 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 { + 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_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { @@ -337,6 +307,74 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) return pic_none_value(); } +static pic_value +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + pic_value v, args; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + puts(""); +#endif + + if (mac->senv == NULL) { /* legacy macro */ + args = pic_cdr(pic, expr); + } + else { + args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return macroexpand(pic, v, senv, cxt); +} + +static pic_value +macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt) +{ + 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, cxt), 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, cxt); + + /* 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_value macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { @@ -400,45 +438,6 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body)); } -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, struct pic_dict *cxt) -{ - pic_value v, args; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - if (mac->senv == NULL) { /* legacy macro */ - args = pic_cdr(pic, expr); - } - else { - args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); - } - - pic_try { - v = pic_apply(pic, mac->proc, args); - } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return macroexpand(pic, v, senv, cxt); -} - static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { From c57f8a5016c962c5da702f6943434e62ac44e6f5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 20:20:04 +0900 Subject: [PATCH 139/200] add pic_void macro --- include/picrin.h | 7 +++++++ src/macro.c | 8 ++------ 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 2bf9f9fd..e6846994 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -127,6 +127,13 @@ void pic_gc_run(pic_state *); pic_value pic_gc_protect(pic_state *, pic_value); size_t pic_gc_arena_preserve(pic_state *); void pic_gc_arena_restore(pic_state *, size_t); +#define pic_void(exec) \ + pic_void_(GENSYM(ai), exec) +#define pic_void_(ai,exec) do { \ + size_t ai = pic_gc_arena_preserve(pic); \ + exec; \ + pic_gc_arena_restore(pic, ai); \ + } while (0) pic_state *pic_open(int argc, char *argv[], char **envp); void pic_close(pic_state *); diff --git a/src/macro.c b/src/macro.c index 683c429b..1328581f 100644 --- a/src/macro.c +++ b/src/macro.c @@ -204,17 +204,13 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr) 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_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_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ pic_throw_error(pic, pic->err); } From 6cf4fe942a99f1a4806d30b5a45dbaaff1be308a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 20:32:26 +0900 Subject: [PATCH 140/200] rewrite iteration with recursion. since we have variable-length arena now, it is no longer required to avoid big arena consumption. --- src/macro.c | 36 ++++++++++-------------------------- 1 file changed, 10 insertions(+), 26 deletions(-) diff --git a/src/macro.c b/src/macro.c index 1328581f..541e0c92 100644 --- a/src/macro.c +++ b/src/macro.c @@ -337,38 +337,22 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct } static pic_value -macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv, struct pic_dict *cxt) +macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt) { size_t ai = pic_gc_arena_preserve(pic); - pic_value v, vs; + pic_value x, head, tail; - /* 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, cxt), 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, cxt); - - /* 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); + if (pic_pair_p(obj)) { + head = macroexpand(pic, pic_car(pic, obj), senv, cxt); + tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt); + x = pic_cons(pic, head, tail); + } else { + x = macroexpand(pic, obj, senv, cxt); } pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, list); - return list; + pic_gc_protect(pic, x); + return x; } static pic_value From e08ec23a9fca75d8a1f19b955cc9e19aa6dee91a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 20:39:34 +0900 Subject: [PATCH 141/200] s/formals/formal/g --- src/macro.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/macro.c b/src/macro.c index 541e0c92..2c800cc3 100644 --- a/src/macro.c +++ b/src/macro.c @@ -359,19 +359,19 @@ static pic_value macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { pic_sym sym; - pic_value formals; + pic_value formal; 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, cxt); + formal = pic_cadr(pic, expr); + if (pic_pair_p(formal)) { + struct pic_senv *in = push_scope(pic, pic_cdr(pic, formal), senv, cxt); pic_value a; /* defined symbol */ - a = pic_car(pic, formals); + a = pic_car(pic, formal); if (! pic_sym_p(a)) { a = macroexpand(pic, a, senv, cxt); } @@ -390,13 +390,13 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct macroexpand_list(pic, pic_cddr(pic, expr), in, cxt))); } - if (! pic_sym_p(formals)) { - formals = macroexpand(pic, formals, senv, cxt); + if (! pic_sym_p(formal)) { + formal = macroexpand(pic, formal, senv, cxt); } - if (! pic_sym_p(formals)) { + if (! pic_sym_p(formal)) { pic_error(pic, "binding to non-symbol object"); } - sym = pic_sym(formals); + sym = pic_sym(formal); if (! pic_find_rename(pic, senv, sym, NULL)) { pic_add_rename(pic, senv, sym); } From 1989a972cbd537e31df90690837fa6c910647b27 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 21:01:30 +0900 Subject: [PATCH 142/200] refactor macroexpand_define. make use of macroexpand_lambda function --- src/macro.c | 87 +++++++++++++++++++++++------------------------------ 1 file changed, 38 insertions(+), 49 deletions(-) diff --git a/src/macro.c b/src/macro.c index 2c800cc3..d9782f60 100644 --- a/src/macro.c +++ b/src/macro.c @@ -355,55 +355,6 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pi return x; } -static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) -{ - pic_sym sym; - pic_value formal; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - formal = pic_cadr(pic, expr); - if (pic_pair_p(formal)) { - struct pic_senv *in = push_scope(pic, pic_cdr(pic, formal), senv, cxt); - pic_value a; - - /* defined symbol */ - a = pic_car(pic, formal); - if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv, cxt); - } - 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, cxt), - macroexpand_list(pic, pic_cddr(pic, expr), in, cxt))); - } - - if (! pic_sym_p(formal)) { - formal = macroexpand(pic, formal, senv, cxt); - } - if (! pic_sym_p(formal)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(formal); - 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, cxt)); -} - static pic_value macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { @@ -418,6 +369,44 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body)); } +static pic_value +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + pic_sym sym; + pic_value formal, body, var, val; + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + formal = pic_cadr(pic, expr); + if (pic_pair_p(formal)) { + var = pic_car(pic, formal); + } else { + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + var = formal; + } + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv, cxt); + } + 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, cxt); + } else { + val = macroexpand(pic, pic_car(pic, body), senv, cxt); + } + return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); +} + static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { From 730cfc860147e3bd6c943467c88807c3e3104244 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 21:05:57 +0900 Subject: [PATCH 143/200] refactor macroexpand_lambda --- src/macro.c | 67 +++++++++++++++++++++++++---------------------------- 1 file changed, 31 insertions(+), 36 deletions(-) diff --git a/src/macro.c b/src/macro.c index d9782f60..6af79e51 100644 --- a/src/macro.c +++ b/src/macro.c @@ -11,8 +11,6 @@ #include "picrin/error.h" #include "picrin/dict.h" -static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); - pic_sym pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) { @@ -70,39 +68,6 @@ find_macro(pic_state *pic, pic_sym rename) return xh_val(e, struct pic_macro *); } -static struct pic_senv * -push_scope(pic_state *pic, pic_value formals, struct pic_senv *up, struct pic_dict *cxt) -{ - 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, cxt); - } - 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, cxt); - } - 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_sym translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { @@ -128,6 +93,8 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c } } +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); + static pic_value macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { @@ -360,8 +327,36 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct { pic_value formal, body; struct pic_senv *in; + pic_value a; - in = push_scope(pic, pic_cadr(pic, expr), senv, cxt); + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + in->up = senv; + xh_init_int(&in->renames, sizeof(pic_sym)); + + for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { + pic_value v = pic_car(pic, a); + + if (! pic_sym_p(v)) { + v = macroexpand(pic, v, senv, cxt); + } + if (! pic_sym_p(v)) { + pic_error(pic, "syntax error"); + } + pic_add_rename(pic, in, pic_sym(v)); + } + if (! pic_sym_p(a)) { + a = macroexpand(pic, a, senv, cxt); + } + 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, cxt); body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt); From 6c45bb3c5d2c777760c146154de96193a8fd3b00 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 22:36:30 +0900 Subject: [PATCH 144/200] support let-syntax --- include/picrin.h | 1 + src/init.c | 2 + src/macro.c | 284 +++++++++++++++++++++++++++-------------------- src/state.c | 2 + 4 files changed, 170 insertions(+), 119 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index e6846994..6b6629a5 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -81,6 +81,7 @@ typedef struct { pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO; + pic_sym sLET_SYNTAX, sLETREC_SYNTAX; pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT; pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; diff --git a/src/init.c b/src/init.c index 5770d819..b6051a3f 100644 --- a/src/init.c +++ b/src/init.c @@ -75,6 +75,8 @@ pic_init_core(pic_state *pic) pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/macro.c b/src/macro.c index 6af79e51..c9da6aee 100644 --- a/src/macro.c +++ b/src/macro.c @@ -184,125 +184,6 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr) return pic_none_value(); } -static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) -{ - pic_value var, val; - pic_sym sym, rename; - - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, cxt); - } - if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } - - val = pic_cadr(pic, pic_cdr(pic, expr)); - - 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), senv); - - return pic_none_value(); -} - -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_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) -{ - pic_value v, args; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - if (mac->senv == NULL) { /* legacy macro */ - args = pic_cdr(pic, expr); - } - else { - args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); - } - - pic_try { - v = pic_apply(pic, mac->proc, args); - } pic_catch { - pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return macroexpand(pic, v, senv, cxt); -} - static pic_value macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt) { @@ -402,6 +283,165 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); } +static pic_value +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + pic_value var, val; + pic_sym sym, rename; + + if (pic_length(pic, expr) != 3) { + pic_error(pic, "syntax error"); + } + + var = pic_cadr(pic, expr); + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv, cxt); + } + if (! pic_sym_p(var)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, senv, sym, &rename)) { + rename = pic_add_rename(pic, senv, sym); + } + + val = pic_cadr(pic, pic_cdr(pic, expr)); + + 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), senv); + + return pic_none_value(); +} + +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_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + struct pic_senv *in; + pic_value formal, v, var, val; + pic_sym sym, rename; + + in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); + in->up = senv; + xh_init_int(&in->renames, sizeof(pic_sym)); + + if (pic_length(pic, expr) < 2) { + pic_error(pic, "syntax error"); + } + + formal = pic_cadr(pic, expr); + if (! pic_list_p(formal)) { + pic_error(pic, "syntax error"); + } + pic_for_each (v, formal) { + var = pic_car(pic, v); + if (! pic_sym_p(var)) { + var = macroexpand(pic, var, senv, cxt); + } + if (! pic_sym_p(var)) { + pic_error(pic, "binding to non-symbol object"); + } + sym = pic_sym(var); + if (! pic_find_rename(pic, in, sym, &rename)) { + rename = pic_add_rename(pic, in, sym); + } + val = pic_eval(pic, pic_cadr(pic, v)); + if (! pic_proc_p(val)) { + pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var); + } + define_macro(pic, rename, pic_proc_ptr(val), senv); + } + return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); +} + +static pic_value +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +{ + pic_value v, args; + +#if DEBUG + puts("before expand-1:"); + pic_debug(pic, expr); + puts(""); +#endif + + if (mac->senv == NULL) { /* legacy macro */ + args = pic_cdr(pic, expr); + } + else { + args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); + } + + pic_try { + v = pic_apply(pic, mac->proc, args); + } pic_catch { + pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic)); + } + +#if DEBUG + puts("after expand-1:"); + pic_debug(pic, v); + puts(""); +#endif + + return macroexpand(pic, v, senv, cxt); +} + static pic_value macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) { @@ -445,6 +485,12 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p else if (tag == pic->sDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } + else if (tag == pic->sLET_SYNTAX) { + return macroexpand_let_syntax(pic, expr, senv, cxt); + } + /* else if (tag == pic->sLETREC_SYNTAX) { */ + /* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */ + /* } */ else if (tag == pic->sLAMBDA) { return macroexpand_lambda(pic, expr, senv, cxt); } diff --git a/src/state.c b/src/state.c index 63a25254..9db4986b 100644 --- a/src/state.c +++ b/src/state.c @@ -96,6 +96,8 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); register_core_symbol(pic, sDEFINE_MACRO, "define-macro"); + register_core_symbol(pic, sLET_SYNTAX, "let-syntax"); + register_core_symbol(pic, sLETREC_SYNTAX, "letrec-syntax"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sIMPORT, "import"); register_core_symbol(pic, sEXPORT, "export"); From fda89b16048f82b2768c08df80c22f75ade1b458 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sun, 13 Jul 2014 22:51:22 +0900 Subject: [PATCH 145/200] [bugfix] broken hygiene of cond expression --- piclib/built-in.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index e2131ab2..02b447fc 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -84,9 +84,9 @@ (if (if (>= (length (car clauses)) 2) (compare (r '=>) (cadar clauses)) #f) - (list (r 'let) (list (list 'x (caar clauses))) - (list (r 'if) 'x - (list (caddar clauses) 'x) + (list (r 'let) (list (list (r 'x) (caar clauses))) + (list (r 'if) (r 'x) + (list (caddar clauses) (r 'x)) (cons (r 'cond) (cdr clauses)))) (list (r 'if) (caar clauses) (cons (r 'begin) (cdar clauses)) From 5faa7cd46d5a9320c4cda221acdadc1088d191e4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 14 Jul 2014 10:08:11 +0900 Subject: [PATCH 146/200] leave core syntax keywords renamed --- include/picrin.h | 5 +++++ include/picrin/macro.h | 2 +- src/codegen.c | 16 ++++++++-------- src/init.c | 18 +++++++++--------- src/macro.c | 38 +++++++++++++++++++------------------- src/state.c | 20 ++++++++++++++++++++ 6 files changed, 62 insertions(+), 37 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 6b6629a5..2406e48f 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -87,6 +87,11 @@ typedef struct { pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; + pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; + pic_sym rDEFINE_SYNTAX, rDEFINE_MACRO; + pic_sym rLET_SYNTAX, rLETREC_SYNTAX; + pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT; + xhash syms; /* name to symbol */ xhash sym_names; /* symbol to name */ int sym_cnt; diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 151eb144..b733a5fe 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -42,7 +42,7 @@ pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); -void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym); +void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym); #if defined(__cplusplus) } diff --git a/src/codegen.c b/src/codegen.c index 8dd84b7a..a4d7e25b 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -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) { @@ -535,7 +535,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 { \ @@ -727,22 +727,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) { diff --git a/src/init.c b/src/init.c index b6051a3f..4fdba1e0 100644 --- a/src/init.c +++ b/src/init.c @@ -68,15 +68,15 @@ pic_init_core(pic_state *pic) /* load core syntaces */ pic->lib->senv = pic_null_syntactic_environment(pic); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX, pic->rLETREC_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/macro.c b/src/macro.c index c9da6aee..5ac2e4dc 100644 --- a/src/macro.c +++ b/src/macro.c @@ -104,7 +104,7 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pi static pic_value macroexpand_quote(pic_state *pic, pic_value expr) { - return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); + return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -242,7 +242,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt); body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt); - return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body)); + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); } static pic_value @@ -280,7 +280,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct } else { val = macroexpand(pic, pic_car(pic, body), senv, cxt); } - return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); + return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); } static pic_value @@ -406,7 +406,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st } define_macro(pic, rename, pic_proc_ptr(val), senv); } - return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); + return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); } static pic_value @@ -470,34 +470,34 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p 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) { + else if (tag == pic->rDEFINE_SYNTAX) { return macroexpand_defsyntax(pic, expr, senv, cxt); } - else if (tag == pic->sDEFINE_MACRO) { + else if (tag == pic->rDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } - else if (tag == pic->sLET_SYNTAX) { + else if (tag == pic->rLET_SYNTAX) { return macroexpand_let_syntax(pic, expr, senv, cxt); } /* else if (tag == pic->sLETREC_SYNTAX) { */ /* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */ /* } */ - else if (tag == pic->sLAMBDA) { + else if (tag == pic->rLAMBDA) { return macroexpand_lambda(pic, expr, senv, cxt); } - else if (tag == pic->sDEFINE) { + else if (tag == pic->rDEFINE) { return macroexpand_define(pic, expr, senv, cxt); } - else if (tag == pic->sQUOTE) { + else if (tag == pic->rQUOTE) { return macroexpand_quote(pic, expr); } @@ -582,17 +582,17 @@ pic_null_syntactic_environment(pic_state *pic) 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); + 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_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) { - pic_put_rename(pic, senv, sym, sym); + pic_put_rename(pic, senv, sym, rsym); if (pic->lib && pic->lib->senv == senv) { pic_export(pic, sym); @@ -944,7 +944,7 @@ pic_init_macro(pic_state *pic) pic_deflibrary ("(picrin macro)") { /* export define-macro syntax */ - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO); pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); diff --git a/src/state.c b/src/state.c index 9db4986b..cb01c754 100644 --- a/src/state.c +++ b/src/state.c @@ -118,6 +118,26 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sNOT, "not"); pic_gc_arena_restore(pic, ai); +#define register_renamed_symbol(pic,slot,name) do { \ + pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \ + } while (0) + + ai = pic_gc_arena_preserve(pic); + register_renamed_symbol(pic, rDEFINE, "define"); + register_renamed_symbol(pic, rLAMBDA, "lambda"); + register_renamed_symbol(pic, rIF, "if"); + register_renamed_symbol(pic, rBEGIN, "begin"); + register_renamed_symbol(pic, rSETBANG, "set!"); + register_renamed_symbol(pic, rQUOTE, "quote"); + register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax"); + register_renamed_symbol(pic, rDEFINE_MACRO, "define-macro"); + register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax"); + register_renamed_symbol(pic, rLETREC_SYNTAX, "letrec-syntax"); + register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); + register_renamed_symbol(pic, rIMPORT, "import"); + register_renamed_symbol(pic, rEXPORT, "export"); + pic_gc_arena_restore(pic, ai); + pic_init_core(pic); /* set library */ From 729162b69f43c794ff0347472ed708fac46810c1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 14 Jul 2014 10:09:23 +0900 Subject: [PATCH 147/200] unlock let-synatx test --- t/r7rs-tests.scm | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index da0a1cbb..ead83b4a 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -440,20 +440,20 @@ (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 () From bb427cf27579e58b26cc4bdd433bdc97a155958f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 13:42:19 +0900 Subject: [PATCH 148/200] style fix --- src/bool.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/bool.c b/src/bool.c index bb4fae82..fc00554d 100644 --- a/src/bool.c +++ b/src/bool.c @@ -28,11 +28,11 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) size_t i; struct pic_blob *u = pic_blob_ptr(x), *v = pic_blob_ptr(y); - if(u->len != v->len){ + if (u->len != v->len) { return false; } - for(i = 0; i < u->len; ++i){ - if(u->data[i] != v->data[i]) + for (i = 0; i < u->len; ++i) { + if (u->data[i] != v->data[i]) return false; } return true; @@ -41,11 +41,11 @@ pic_equal_p(pic_state *pic, pic_value x, pic_value y) size_t i; struct pic_vector *u = pic_vec_ptr(x), *v = pic_vec_ptr(y); - if(u->len != v->len){ + if (u->len != v->len) { return false; } - for(i = 0; i < u->len; ++i){ - if(! pic_equal_p(pic, u->data[i], v->data[i])) + for (i = 0; i < u->len; ++i) { + if (! pic_equal_p(pic, u->data[i], v->data[i])) return false; } return true; From 1d5fa803aacee4086ab2bcb539a3dc66b23a2317 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 17:51:27 +0900 Subject: [PATCH 149/200] add case-lambda --- piclib/built-in.scm | 45 +++++++++++++++++++++++++++++++++++++++++ t/r7rs-tests.scm | 49 ++++++++++++++++++++++----------------------- 2 files changed, 69 insertions(+), 25 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 02b447fc..36e2ab29 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1397,3 +1397,48 @@ (import (picrin syntax-rules)) (export syntax-rules) + +(define-library (scheme case-lambda) + (import (scheme base)) + + (define-syntax case-lambda + (syntax-rules () + ((case-lambda + (?a1 ?e1 ...) + ?clause1 ...) + (lambda args + (let ((l (length args))) + (case-lambda "CLAUSE" args l + (?a1 ?e1 ...) + ?clause1 ...)))) + ((case-lambda "CLAUSE" ?args ?l + ((?a1 ...) ?e1 ...) + ?clause1 ...) + (if (= ?l (length '(?a1 ...))) + (apply (lambda (?a1 ...) ?e1 ...) ?args) + (case-lambda "CLAUSE" ?args ?l + ?clause1 ...))) + ((case-lambda "CLAUSE" ?args ?l + ((?a1 . ?ar) ?e1 ...) + ?clause1 ...) + (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) + ?clause1 ...)) + ((case-lambda "CLAUSE" ?args ?l + (?a1 ?e1 ...) + ?clause1 ...) + (let ((?a1 ?args)) + ?e1 ...)) + ((case-lambda "CLAUSE" ?args ?l) + (error "Wrong number of arguments to CASE-LAMBDA.")) + ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...) + ?clause1 ...) + (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) + ?clause1 ...)) + ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) + ?clause1 ...) + (if (>= ?l ?k) + (apply (lambda ?al ?e1 ...) ?args) + (case-lambda "CLAUSE" ?args ?l + ?clause1 ...))))) + + (export case-lambda)) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index ead83b4a..802d7dcc 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -36,8 +36,7 @@ (scheme write) ; (scheme eval) (scheme process-context) -; (scheme case-lambda) - ) + (scheme case-lambda)) ;; R7RS test suite. Covers all procedures and syntax in the small ;; language except `delete-file'. Currently assumes full-unicode @@ -409,32 +408,32 @@ (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) From 6c68955dee479a869067eec9509d4adfdf7c6145 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 17:58:26 +0900 Subject: [PATCH 150/200] unlock tests about rational number literals --- t/r7rs-tests.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 802d7dcc..8eeac60b 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -637,11 +637,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)) @@ -649,7 +649,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)) @@ -763,8 +763,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)) @@ -817,7 +817,7 @@ (test 3.0 (truncate 3.5)) (test 4.0 (round 3.5)) -;; (test 4 (round 7/2)) +(test 4 (round 7/2)) (test 7 (round 7)) ;; (test 1/3 (rationalize (exact .3) 1/10)) From d85801e3968ae23b8e009619ee9ca6d6d4d6b483 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 17:58:46 +0900 Subject: [PATCH 151/200] rational number literal reads exact integer if possible --- src/read.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/read.c b/src/read.c index 3979755c..b64ad0dc 100644 --- a/src/read.c +++ b/src/read.c @@ -208,7 +208,11 @@ read_number(pic_state *pic, struct pic_port *port, char c) n = atoi(buf); next(port); read_uinteger(pic, port, next(port), buf); - return pic_float_value(n / (double)atoi(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)); From 64d757d46aa45c67e211b1b92e50ed86be2520cb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 18:04:53 +0900 Subject: [PATCH 152/200] r7rs-test: print all failed tests in the end --- t/r7rs-tests.scm | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 8eeac60b..0e818ca1 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -47,6 +47,8 @@ (define counter 0) (define failure-counter 0) +(define fails '()) + (define (print-statistics) (newline) (display "Test Result: ") @@ -58,7 +60,11 @@ (display "%)") (display " [PASS/TOTAL]") (display "") - (newline)) + (newline) + (for-each + (lambda (fail) + (display fail)) + fails)) (define (test-begin . o) (set! test-counter (+ test-counter 1))) @@ -85,15 +91,19 @@ ) ((not (equal? res expected)) (set! failure-counter (+ failure-counter 1)) - (display " FAIL: ") - (write 'expr) - (newline) - (display " expected ") - (write expected) - (display " but got ") - (write res) - (display "") - (newline))) + (let ((out (open-output-string))) + (display " FAIL: " out) + (write 'expr out) + (newline out) + (display " expected " out) + (write expected out) + (display " but got " out) + (write res out) + (display "" out) + (newline out) + (let ((str (get-output-string out))) + (set! fails (cons str fails)) + (display str))))) (set! counter (+ counter 1)))))) (newline) From 6dd6b0bc072acfbad603456e53104056508f6cfb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 18:33:45 +0900 Subject: [PATCH 153/200] update docs --- docs/lang.rst | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/lang.rst b/docs/lang.rst index 9e787548..6a68fed7 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 --------------------- From f02bac1d8848f6c1905d461cf128a4bba5ae57db Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 20:57:35 +0900 Subject: [PATCH 154/200] register function name to lambdas like (define foo (lambda ...)) --- src/codegen.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/codegen.c b/src/codegen.c index a4d7e25b..77e74e26 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -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 { From 443bd6e830d078acb8c4266bd52bb8e9de18c8e2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 20:59:29 +0900 Subject: [PATCH 155/200] initial array support --- piclib/CMakeLists.txt | 1 + piclib/picrin/array.scm | 55 +++++++++++++++++++++++++++++++++++++++++ t/array.scm | 24 ++++++++++++++++++ 3 files changed, 80 insertions(+) create mode 100644 piclib/picrin/array.scm create mode 100644 t/array.scm diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 49f1c4b3..aaf66fdd 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,5 +1,6 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/built-in.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm new file mode 100644 index 00000000..04167d6d --- /dev/null +++ b/piclib/picrin/array.scm @@ -0,0 +1,55 @@ +(define-library (picrin array) + (import (scheme base)) + + (define-record-type array + (create-array data size head tail) + array? + (data array-data set-array-data!) + (size array-size set-array-size!) + (head array-head set-array-head!) + (tail array-tail set-array-tail!)) + + (define (translate ary i) + (floor-remainder i (array-size ary))) + + (define (make-array) + (create-array (vector) 0 0 0)) + + (define (array-length ary) + (let ((size (- (array-tail ary) (array-head ary)))) + (translate ary size))) + + (define (array-rotate! ary) + (when (< (array-tail ary) (array-head ary)) + (let ((xs (vector-copy (array-data ary) 0 (array-head ary))) + (ys (vector-copy (array-data ary) (array-head ary)))) + (set-array-data! ary (vector-append ys xs)) + (set-array-tail! ary (array-length ary)) + (set-array-head! ary 0)))) + + (define (array-reserve! ary size) + (set! size (+ size 1)) ; capa == size - 1 + (when (< (array-size ary) size) + (array-rotate! ary) + (set-array-data! ary (vector-append (array-data ary) (make-vector (- size (array-size ary))))) + (set-array-size! ary size))) + + (define (array-ref ary i) + (let ((data (array-data ary))) + (vector-ref data (translate ary (+ (array-head ary) i))))) + + (define (array-set! ary i obj) + (let ((data (array-data ary))) + (vector-set! data (translate ary (+ (array-head ary) i)) obj))) + + (define (array-push! ary obj) + (array-reserve! ary (+ (array-length ary) 1)) + (array-set! ary (array-length ary) obj) + (set-array-tail! ary (translate ary (+ (array-tail ary) 1)))) + + (export make-array + array? + array-length + array-ref + array-set! + array-push!)) diff --git a/t/array.scm b/t/array.scm new file mode 100644 index 00000000..dc41f462 --- /dev/null +++ b/t/array.scm @@ -0,0 +1,24 @@ +(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-ref ary 0)) +(newline) +(write (array-ref ary 1)) +(newline) +(write (array-ref ary 2)) +(newline) + From 2da5d440a8ab26d71d9fe4173368881357d16376 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 21:26:08 +0900 Subject: [PATCH 156/200] more array functions --- piclib/picrin/array.scm | 22 ++++++++++++++++++++-- t/array.scm | 24 +++++++++++++++++++++--- 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index 04167d6d..deb9cc21 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -31,7 +31,9 @@ (set! size (+ size 1)) ; capa == size - 1 (when (< (array-size ary) size) (array-rotate! ary) - (set-array-data! ary (vector-append (array-data ary) (make-vector (- size (array-size ary))))) + (set-array-data! ary (vector-append + (array-data ary) + (make-vector (- size (array-size ary))))) (set-array-size! ary size))) (define (array-ref ary i) @@ -47,9 +49,25 @@ (array-set! ary (array-length ary) obj) (set-array-tail! ary (translate ary (+ (array-tail ary) 1)))) + (define (array-pop! ary) + (set-array-tail! ary (translate ary (- (array-tail ary) 1))) + (array-ref ary (array-length ary))) + + (define (array-shift! ary) + (set-array-head! ary (translate ary (+ (array-head ary) 1))) + (array-ref ary -1)) + + (define (array-unshift! ary obj) + (array-reserve! ary (+ (array-length ary) 1)) + (array-set! ary -1 obj) + (set-array-head! ary (translate ary (- (array-head ary) 1)))) + (export make-array array? array-length array-ref array-set! - array-push!)) + array-push! + array-pop! + array-shift! + array-unshift!)) diff --git a/t/array.scm b/t/array.scm index dc41f462..22593546 100644 --- a/t/array.scm +++ b/t/array.scm @@ -15,10 +15,28 @@ (array-push! ary 3) (write ary) (newline) -(write (array-ref ary 0)) +(write (array-pop! ary)) (newline) -(write (array-ref ary 1)) +(write (array-pop! ary)) (newline) -(write (array-ref ary 2)) +(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) From d358c8873da21e17de7182c5c38c7fdb46117d4b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 22:20:32 +0900 Subject: [PATCH 157/200] add array<->list converters --- piclib/picrin/array.scm | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index deb9cc21..f2926fac 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -12,9 +12,6 @@ (define (translate ary i) (floor-remainder i (array-size ary))) - (define (make-array) - (create-array (vector) 0 0 0)) - (define (array-length ary) (let ((size (- (array-tail ary) (array-head ary)))) (translate ary size))) @@ -36,6 +33,9 @@ (make-vector (- size (array-size ary))))) (set-array-size! ary size))) + (define (make-array . rest) + (create-array (vector) 0 0 0)) + (define (array-ref ary i) (let ((data (array-data ary))) (vector-ref data (translate ary (+ (array-head ary) i))))) @@ -62,7 +62,22 @@ (array-set! ary -1 obj) (set-array-head! ary (translate ary (- (array-head ary) 1)))) + (define (array->list ary) + (do ((i 0 (+ i 1)) + (x '() (cons (array-ref ary i) x))) + ((= i (array-length ary)) + (reverse x)))) + + (define (list->array list) + (let ((ary (make-array))) + (for-each (lambda (x) (array-push! ary x)) list) + ary)) + + (define (array . objs) + (list->array objs)) + (export make-array + array array? array-length array-ref @@ -70,4 +85,6 @@ array-push! array-pop! array-shift! - array-unshift!)) + array-unshift! + array->list + list->array)) From 4f5a92d921581b4b483145d14721a70d7587dcbf Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 22:20:45 +0900 Subject: [PATCH 158/200] rename array type; avoid variable conflict --- piclib/picrin/array.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index f2926fac..7fc6f050 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -1,7 +1,7 @@ (define-library (picrin array) (import (scheme base)) - (define-record-type array + (define-record-type array-type (create-array data size head tail) array? (data array-data set-array-data!) From 318475c14b0efe6f7d1635403e6ec54399689721 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 22:27:48 +0900 Subject: [PATCH 159/200] optional argument for make-array --- piclib/picrin/array.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index 7fc6f050..bc667ac8 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -34,7 +34,12 @@ (set-array-size! ary size))) (define (make-array . rest) - (create-array (vector) 0 0 0)) + (if (null? rest) + (make-array 0) + (let ((capacity (car rest)) + (ary (create-array (vector) 0 0 0))) + (array-reserve! ary capacity) + ary))) (define (array-ref ary i) (let ((data (array-data ary))) From 632529c9a5071a103e94d60ba3ba44a086c71398 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 22:45:04 +0900 Subject: [PATCH 160/200] add array-map and array-for-each --- piclib/picrin/array.scm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index bc667ac8..4f8295d5 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -81,6 +81,12 @@ (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? @@ -91,5 +97,7 @@ array-pop! array-shift! array-unshift! + array-map + array-for-each array->list list->array)) From fa0cde8d77112bb269958f9fc13003ff2c0051bf Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 23:09:20 +0900 Subject: [PATCH 161/200] publish call-with-{in,out}put-file --- piclib/built-in.scm | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 36e2ab29..8221653e 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1005,14 +1005,23 @@ (export call-with-port) +(define-library (scheme file) + (import (scheme base)) + + (define (call-with-input-file filename callback) + (call-with-port (open-input-file filename) callback)) + + (define (call-with-output-file filename callback) + (call-with-port (open-output-file filename) callback)) + + (export call-with-input-file + call-with-output-file)) + ;;; include syntax (import (scheme read) (scheme file)) -(define (call-with-input-file filename callback) - (call-with-port (open-input-file filename) callback)) - (define (read-many filename) (call-with-input-file filename (lambda (port) From 033b26d1e8671e685ff70a6052f9323c02191aca Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Tue, 15 Jul 2014 23:54:50 +0900 Subject: [PATCH 162/200] update docs --- docs/libs.rst | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/docs/libs.rst b/docs/libs.rst index 102a1b54..98686ec1 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -137,6 +137,70 @@ This expression is equivalent to ``(filter even? (iota 10))`` but it is more pro 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) ------------------- From b86d010b76ca276ae2e595c1d962084a744c3af3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:30:45 +0900 Subject: [PATCH 163/200] add letrec-syntax --- docs/lang.rst | 2 +- piclib/built-in.scm | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/docs/lang.rst b/docs/lang.rst index 6a68fed7..9c4152ff 100644 --- a/docs/lang.rst +++ b/docs/lang.rst @@ -58,7 +58,7 @@ section status comments 5.3.1 Top level definitions yes 5.3.2 Internal definitions yes TODO: interreferential definitions 5.3.3 Multiple-value definitions yes -5.4 Syntax definitions yes TODO: internal macro definition is not supported. +5.4 Syntax definitions yes 5.5 Recored-type definitions yes 5.6.1 Library Syntax incomplete In picrin, libraries can be reopend and can be nested. 5.6.2 Library example N/A diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 8221653e..c3c09059 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -292,6 +292,17 @@ `(,(r 'begin) ,@(cdar clauses))) ,(loop (cdr clauses)))))))))) + (define-syntax letrec-syntax + (er-macro-transformer + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) + (define-syntax syntax-error (er-macro-transformer (lambda (expr rename compare) @@ -317,6 +328,7 @@ and or cond case else => do when unless + letrec-syntax _ ... syntax-error)) @@ -629,6 +641,7 @@ and or cond case else => do when unless + letrec-syntax _ ... syntax-error) (export let-values From 8e114fae6b24b78c95c0d75e38695050f7d27b3c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:32:04 +0900 Subject: [PATCH 164/200] unlock letrec-syntax test --- t/r7rs-tests.scm | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 0e818ca1..eeac935e 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -464,24 +464,24 @@ (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 () From 6ee4d49a96853e352c449dadf36bf332fc730fd6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:46:30 +0900 Subject: [PATCH 165/200] Macro-generating macro may rename symbol that will be used as a newly introduced identifier --- src/macro.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/macro.c b/src/macro.c index 5ac2e4dc..1ad56a78 100644 --- a/src/macro.c +++ b/src/macro.c @@ -34,7 +34,12 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren { xh_entry *e; - UNUSED(pic); + if (! pic_interned_p(pic, sym)) { + if (rename != NULL) { + *rename = sym; + } + return true; + } if ((e = xh_get_int(&senv->renames, sym)) == NULL) { return false; @@ -73,9 +78,6 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c { pic_sym rename; - if (! pic_interned_p(pic, sym)) { - return sym; - } while (true) { if (pic_find_rename(pic, senv, sym, &rename)) { return rename; From bdcb83296eff967a930738735b8841de1b7cdea9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:47:25 +0900 Subject: [PATCH 166/200] update case-lambda impl --- piclib/built-in.scm | 57 +++++++++++++++++---------------------------- 1 file changed, 21 insertions(+), 36 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index c3c09059..0b94d488 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1425,42 +1425,27 @@ (define-syntax case-lambda (syntax-rules () - ((case-lambda - (?a1 ?e1 ...) - ?clause1 ...) + ((case-lambda (params body0 ...) ...) (lambda args - (let ((l (length args))) - (case-lambda "CLAUSE" args l - (?a1 ?e1 ...) - ?clause1 ...)))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 ...) ?e1 ...) - ?clause1 ...) - (if (= ?l (length '(?a1 ...))) - (apply (lambda (?a1 ...) ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "CLAUSE" ?args ?l - (?a1 ?e1 ...) - ?clause1 ...) - (let ((?a1 ?args)) - ?e1 ...)) - ((case-lambda "CLAUSE" ?args ?l) - (error "Wrong number of arguments to CASE-LAMBDA.")) - ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) - ?clause1 ...) - (if (>= ?l ?k) - (apply (lambda ?al ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))))) + (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)) From 40897e6351759be1a5a20d9d424f03518eb46b85 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 16:12:25 +0900 Subject: [PATCH 167/200] support character literal --- src/read.c | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/read.c b/src/read.c index b64ad0dc..f8836e44 100644 --- a/src/read.c +++ b/src/read.c @@ -300,12 +300,23 @@ read_boolean(pic_state *pic, struct pic_port *port, char c) 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'; expect(port, "lerm"); break; + case 'b': c = '\b'; expect(port, "ackspace"); break; + case 'd': c = 0x7F; expect(port, "elete"); break; + case 'e': c = 0x1B; expect(port, "scape"); break; + case 'n': c = peek(port) == 'e' ? (expect(port, "ewline"), '\n') : (expect(port, "ull"), '\0'); break; + case 'r': c = '\r'; expect(port, "eturn"); break; + case 's': c = ' '; expect(port, "pace"); break; + case 't': c = '\t'; expect(port, "ab"); break; + } + } - return pic_char_value(next(port)); + return pic_char_value(c); } static pic_value From ed01546f8e012be22c3643ee372cb6298b7a2192 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 20:42:12 +0900 Subject: [PATCH 168/200] add (picrin pretty-print) --- contrib/10.pretty-print/CMakeLists.txt | 1 + contrib/10.pretty-print/pretty-print.scm | 312 +++++++++++++++++++++++ 2 files changed, 313 insertions(+) create mode 100644 contrib/10.pretty-print/CMakeLists.txt create mode 100644 contrib/10.pretty-print/pretty-print.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)) From a727c913a3af2ccf9f540595fa237505c9c9aab6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 20:46:00 +0900 Subject: [PATCH 169/200] update docs --- docs/libs.rst | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/docs/libs.rst b/docs/libs.rst index 98686ec1..33928196 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -248,6 +248,16 @@ Note that dictionary is not a weak map; if you are going to make a highly memory 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) ------------- From a8751ab3bab9efec32565edeb8ec6b7f95d5f90f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 20:52:42 +0900 Subject: [PATCH 170/200] fix docs --- docs/libs.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/libs.rst b/docs/libs.rst index 33928196..f85938eb 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -49,7 +49,7 @@ Utility functions and syntaces for macro definition. - define-macro - gensym -- macroexpand expr +- macroexpand Old-fashioned macro. From 2b16aaded2008727e6c9fa93fe97e6bf696c1499 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 10:16:17 +0900 Subject: [PATCH 171/200] s/translate/make_identifier/g --- src/macro.c | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/macro.c b/src/macro.c index 1ad56a78..4624cccc 100644 --- a/src/macro.c +++ b/src/macro.c @@ -74,7 +74,7 @@ find_macro(pic_state *pic, pic_sym rename) } static pic_sym -translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) +make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { pic_sym rename; @@ -100,7 +100,7 @@ static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct p static pic_value macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) { - return pic_sym_value(translate(pic, sym, senv, cxt)); + return pic_sym_value(make_identifier(pic, sym, senv, cxt)); } static pic_value @@ -736,7 +736,7 @@ er_macro_rename(pic_state *pic) mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - return pic_sym_value(translate(pic, sym, mac_env, cxt)); + return pic_sym_value(make_identifier(pic, sym, mac_env, cxt)); } static pic_value @@ -755,8 +755,8 @@ er_macro_compare(pic_state *pic) use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - m = translate(pic, pic_sym(a), use_env, cxt); - n = translate(pic, pic_sym(b), use_env, cxt); + m = make_identifier(pic, pic_sym(a), use_env, cxt); + n = make_identifier(pic, pic_sym(b), use_env, cxt); return pic_bool_value(m == n); } @@ -822,7 +822,7 @@ ir_macro_inject(pic_state *pic) use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - return pic_sym_value(translate(pic, sym, use_env, cxt)); + return pic_sym_value(make_identifier(pic, sym, use_env, cxt)); } static pic_value @@ -841,8 +841,8 @@ ir_macro_compare(pic_state *pic) mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - m = translate(pic, pic_sym(a), mac_env, cxt); - n = translate(pic, pic_sym(b), mac_env, cxt); + m = make_identifier(pic, pic_sym(a), mac_env, cxt); + n = make_identifier(pic, pic_sym(b), mac_env, cxt); return pic_bool_value(m == n); } @@ -852,7 +852,7 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct p { if (pic_sym_p(expr)) { pic_value r; - r = pic_sym_value(translate(pic, pic_sym(expr), use_env, cxt)); + r = pic_sym_value(make_identifier(pic, pic_sym(expr), use_env, cxt)); *ir = pic_acons(pic, r, expr, *ir); return r; } @@ -874,7 +874,7 @@ ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct if (pic_test(r = pic_assq(pic, expr, *ir))) { return pic_cdr(pic, r); } - return pic_sym_value(translate(pic, pic_sym(expr), mac_env, cxt)); + return pic_sym_value(make_identifier(pic, pic_sym(expr), mac_env, cxt)); } else if (pic_pair_p(expr)) { return pic_cons(pic, From 9e7b4da56c207dbbf2f6df1c385c68edb80b6f32 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 10:21:00 +0900 Subject: [PATCH 172/200] add make-identifier function --- src/macro.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/macro.c b/src/macro.c index 4624cccc..16c7816c 100644 --- a/src/macro.c +++ b/src/macro.c @@ -940,6 +940,19 @@ pic_macro_ir_macro_transformer(pic_state *pic) return pic_obj_value(proc); } +static pic_value +pic_macro_make_identifier(pic_state *pic) +{ + pic_value obj; + pic_sym sym; + + pic_get_args(pic, "mo", &sym, &obj); + + pic_assert_type(pic, obj, senv); + + return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj), pic_dict_new(pic))); +} + void pic_init_macro(pic_state *pic) { @@ -955,5 +968,6 @@ pic_init_macro(pic_state *pic) 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); } } From b68813823f1487d11f6eaba371ea2b7a5266a462 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 11:30:44 +0900 Subject: [PATCH 173/200] improve pic_get_args error message --- src/vm.c | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/vm.c b/src/vm.c index 0063cb92..8a2430a0 100644 --- a/src/vm.c +++ b/src/vm.c @@ -115,7 +115,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *f = pic_int(v); break; default: - pic_error(pic, "pic_get_args: expected float or int"); + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); } i++; } @@ -141,7 +141,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *e = true; break; default: - pic_error(pic, "pic_get_args: expected float or int"); + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); } i++; } @@ -167,7 +167,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *e = true; break; default: - pic_error(pic, "pic_get_args: expected float or int"); + pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); } i++; } @@ -189,7 +189,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *k = pic_int(v); break; default: - pic_error(pic, "pic_get_args: expected int"); + pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); } i++; } @@ -206,23 +206,23 @@ pic_get_args(pic_state *pic, const char *format, ...) *str = pic_str_ptr(v); } else { - pic_error(pic, "pic_get_args: expected string"); + pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); } i++; } break; } case 'z': { - pic_value str; const char **cstr; + pic_value v; cstr = va_arg(ap, const char **); if (i < argc) { - str = GET_OPERAND(pic,i); - if (! pic_str_p(str)) { - pic_error(pic, "pic_get_args: expected string"); + v = GET_OPERAND(pic,i); + if (! pic_str_p(v)) { + pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); } - *cstr = pic_str_cstr(pic_str_ptr(str)); + *cstr = pic_str_cstr(pic_str_ptr(v)); i++; } break; @@ -238,7 +238,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *m = pic_sym(v); } else { - pic_error(pic, "pic_get_args: expected symbol"); + pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); } i++; } @@ -255,7 +255,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *vec = pic_vec_ptr(v); } else { - pic_error(pic, "pic_get_args: expected vector"); + pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v); } i++; } @@ -272,7 +272,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *b = pic_blob_ptr(v); } else { - pic_error(pic, "pic_get_args: expected bytevector"); + pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v); } i++; } @@ -289,7 +289,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *c = pic_char(v); } else { - pic_error(pic, "pic_get_args: expected char"); + pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); } i++; } @@ -306,7 +306,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *l = pic_proc_ptr(v); } else { - pic_error(pic, "pic_get_args, expected procedure"); + pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v); } i++; } @@ -323,7 +323,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *p = pic_port_ptr(v); } else { - pic_error(pic, "pic_get_args, expected port"); + pic_errorf(pic, "pic_get_args, expected port, but got ~s", v); } i++; } @@ -340,7 +340,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *d = pic_dict_ptr(v); } else { - pic_error(pic, "pic_get_args, expected dictionary"); + pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v); } i++; } From 378b5bb6a8205951c785dd362a4f4f18aa5cc355 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 11:30:58 +0900 Subject: [PATCH 174/200] dictionary-has? was missing --- src/dict.c | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/dict.c b/src/dict.c index d3eb895b..1ba9d565 100644 --- a/src/dict.c +++ b/src/dict.c @@ -109,6 +109,17 @@ pic_dict_dict_set(pic_state *pic) 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) { @@ -155,6 +166,7 @@ pic_init_dict(pic_state *pic) pic_deflibrary ("(picrin dictionary)") { 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); From 5d9242f5b52059d696fc230d8aadbc5bce94edc4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 11:32:30 +0900 Subject: [PATCH 175/200] rewrite make-syntactic-closure in scheme --- piclib/built-in.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 55 insertions(+), 1 deletion(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 0b94d488..5b220ca9 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -36,7 +36,61 @@ ;;; hygienic macros (define-library (picrin macro) - (import (scheme base)) + (import (scheme base) + (picrin dictionary)) + + (define (memq obj list) + (if (null? list) + #f + (if (eq? obj (car list)) + list + (memq obj (cdr list))))) + + (define (list->vector proc 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 proc vector) + (define (go i) + (if (= i (vector-length vector)) + '() + (cons (vector-ref vector i) + (go (+ i 1))))) + (go 0)) + + (define (vector-map proc expr) + (list->vector (map proc (vector->list expr)))) + + (define (walk proc expr) + (if (null? expr) + '() + (if (pair? expr) + (cons (proc (car expr)) + (walk proc (cdr expr))) + (if (vector? expr) + (vector-map proc expr) + (proc expr))))) + + (define (make-syntactic-closure form free env) + (define cache (make-dictionary)) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (if (memq atom free) + atom + (if (dictionary-has? cache atom) + (dictionary-ref cache atom) + (begin + (define id (make-identifier atom env)) + (dictionary-set! cache atom id) + id))))))) (define (sc-macro-transformer f) (lambda (expr use-env mac-env) From 73a6eaf9da5c54f8fd3af3d973f90ef67c660c30 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 11:32:41 +0900 Subject: [PATCH 176/200] rewrite er-macro-transformer in scheme --- piclib/built-in.scm | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 5b220ca9..764b282c 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -92,6 +92,28 @@ (dictionary-set! cache atom id) id))))))) + (define (er-macro-transformer f) + (lambda (expr use-env mac-env) + + (define cache (make-dictionary)) + + (define (rename sym) + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define id (make-identifier sym mac-env)) + (dictionary-set! cache sym id) + id))) + + (define (compare sym1 sym2) + (if (symbol? sym1) + (if (symbol? sym2) + (identifier=? use-env sym1 use-env sym2) + #f) + #f)) + + (f expr rename compare))) + (define (sc-macro-transformer f) (lambda (expr use-env mac-env) (make-syntactic-closure mac-env '() (f expr use-env)))) From cf509a4922bb906c99038a3f7c735d7b9de3cc71 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 11:32:52 +0900 Subject: [PATCH 177/200] [bugfix] move define-auxiliary-syntax to the beginning. This made mac-env and use-env of cond expression different --- piclib/built-in.scm | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 764b282c..8269cbf0 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -131,6 +131,20 @@ (scheme cxr) (picrin macro)) + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax else) + (define-auxiliary-syntax =>) + (define-auxiliary-syntax _) + (define-auxiliary-syntax ...) + (define-auxiliary-syntax unquote) + (define-auxiliary-syntax unquote-splicing) + (define-syntax let (er-macro-transformer (lambda (expr r compare) @@ -384,21 +398,6 @@ (lambda (expr rename compare) (apply error (cdr expr))))) - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - `(,(r 'define-syntax) ,(cadr expr) - (,(r 'sc-macro-transformer) - (,(r 'lambda) (expr env) - (,(r 'error) "invalid use of auxiliary syntax"))))))) - - (define-auxiliary-syntax else) - (define-auxiliary-syntax =>) - (define-auxiliary-syntax _) - (define-auxiliary-syntax ...) - (define-auxiliary-syntax unquote) - (define-auxiliary-syntax unquote-splicing) - (export let let* letrec letrec* quasiquote unquote unquote-splicing and or From 5e8c4af84b6ae8d86fea4b2d852b40d7d8fc21a7 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:39:28 +0900 Subject: [PATCH 178/200] fix bugs introduced in prev commit --- piclib/built-in.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 8269cbf0..ed3fcde2 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -46,7 +46,7 @@ list (memq obj (cdr list))))) - (define (list->vector proc list) + (define (list->vector list) (define vector (make-vector (length list))) (define (go list i) (if (null? list) @@ -56,7 +56,7 @@ (go (cdr list) (+ i 1))))) (go list 0)) - (define (vector->list proc vector) + (define (vector->list vector) (define (go i) (if (= i (vector-length vector)) '() @@ -71,7 +71,7 @@ (if (null? expr) '() (if (pair? expr) - (cons (proc (car expr)) + (cons (walk proc (car expr)) (walk proc (cdr expr))) (if (vector? expr) (vector-map proc expr) From 2e35f03f351f7909c5ff70ae2b0550f9a88a95f0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:40:18 +0900 Subject: [PATCH 179/200] remove type check guards in compare function --- piclib/built-in.scm | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index ed3fcde2..9ab0dd83 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -106,11 +106,7 @@ id))) (define (compare sym1 sym2) - (if (symbol? sym1) - (if (symbol? sym2) - (identifier=? use-env sym1 use-env sym2) - #f) - #f)) + (identifier=? use-env sym1 use-env sym2)) (f expr rename compare))) From c0b83759a84fc42bdf0481421fbcc5426e03a62d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:40:45 +0900 Subject: [PATCH 180/200] re-implement ir-macro-transformer in scheme --- piclib/built-in.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 9ab0dd83..e3093dcb 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -110,6 +110,54 @@ (f expr rename compare))) + (define (ir-macro-transformer f) + (lambda (expr use-env mac-env) + + (define protects (make-dictionary)) + + (define (wrap expr) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (begin + (define id (make-identifier atom use-env)) + (dictionary-set! protects id atom) ; lookup *atom* from id + id))) + expr)) + + (define (unwrap expr) + (define cache (make-dictionary)) + (walk + (lambda (atom) + (if (not (symbol? atom)) + atom + (if (dictionary-has? protects atom) + (dictionary-ref protects atom) + (if (dictionary-has? cache atom) + (dictionary-ref cache atom) + (begin + ;; implicit renaming + (define id (make-identifier atom mac-env)) + (dictionary-set! cache atom id) + id))))) + expr)) + + (define cache (make-dictionary)) + + (define (inject sym) + (if (dictionary-has? cache sym) + (dictionary-ref cache sym) + (begin + (define id (make-identifier sym use-env)) + (dictionary-set! cache sym id) + id))) + + (define (compare sym1 sym2) + (identifier=? mac-env sym1 mac-env sym2)) + + (unwrap (f (wrap expr) inject compare)))) + (define (sc-macro-transformer f) (lambda (expr use-env mac-env) (make-syntactic-closure mac-env '() (f expr use-env)))) From f4d68d691bfb08354895bf6f6d54455c6075e0e0 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:43:17 +0900 Subject: [PATCH 181/200] remove c impls of ir/er macros --- piclib/built-in.scm | 20 ++-- src/macro.c | 218 -------------------------------------------- 2 files changed, 11 insertions(+), 227 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index e3093dcb..51cfa5f5 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -92,6 +92,14 @@ (dictionary-set! cache atom id) id))))))) + (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) @@ -158,16 +166,10 @@ (unwrap (f (wrap expr) inject compare)))) - (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)) + rsc-macro-transformer + er-macro-transformer + ir-macro-transformer)) ;;; core syntaces (define-library (picrin core-syntax) diff --git a/src/macro.c b/src/macro.c index 16c7816c..8be145f6 100644 --- a/src/macro.c +++ b/src/macro.c @@ -724,222 +724,6 @@ pic_macro_identifier_eq_p(pic_state *pic) return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y)); } -static pic_value -er_macro_rename(pic_state *pic) -{ - pic_sym sym; - struct pic_senv *mac_env; - struct pic_dict *cxt; - - pic_get_args(pic, "m", &sym); - - mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); - cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - - return pic_sym_value(make_identifier(pic, sym, mac_env, cxt)); -} - -static pic_value -er_macro_compare(pic_state *pic) -{ - pic_value a, b; - struct pic_senv *use_env; - pic_sym m, n; - struct pic_dict *cxt; - - 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)); - cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - - m = make_identifier(pic, pic_sym(a), use_env, cxt); - n = make_identifier(pic, pic_sym(b), use_env, cxt); - - return pic_bool_value(m == n); -} - -static pic_value -er_macro_call(pic_state *pic) -{ - pic_value expr, use_env, mac_env; - struct pic_proc *rename, *compare, *cb; - struct pic_dict *cxt; - - 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"); - } - - cxt = pic_dict_new(pic); - - 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, pic_obj_value(cxt)); - - 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, pic_obj_value(cxt)); - - 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; - struct pic_dict *cxt; - - pic_get_args(pic, "m", &sym); - - use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); - cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - - return pic_sym_value(make_identifier(pic, sym, use_env, cxt)); -} - -static pic_value -ir_macro_compare(pic_state *pic) -{ - pic_value a, b; - struct pic_senv *mac_env; - pic_sym m, n; - struct pic_dict *cxt; - - 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)); - cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2)); - - m = make_identifier(pic, pic_sym(a), mac_env, cxt); - n = make_identifier(pic, pic_sym(b), mac_env, cxt); - - return pic_bool_value(m == n); -} - -static pic_value -ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir) -{ - if (pic_sym_p(expr)) { - pic_value r; - r = pic_sym_value(make_identifier(pic, pic_sym(expr), use_env, cxt)); - *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, cxt, ir), - ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir)); - } - else { - return expr; - } -} - -static pic_value -ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, 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(make_identifier(pic, pic_sym(expr), mac_env, cxt)); - } - else if (pic_pair_p(expr)) { - return pic_cons(pic, - ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir), - ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir)); - } - else { - return expr; - } -} - -static pic_value -ir_macro_call(pic_state *pic) -{ - pic_value expr, use_env, mac_env; - struct pic_proc *inject, *compare, *cb; - struct pic_dict *cxt; - 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"); - } - - cxt = pic_dict_new(pic); - - 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, pic_obj_value(cxt)); - - 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, pic_obj_value(cxt)); - - 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), cxt, &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), cxt, &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); -} - static pic_value pic_macro_make_identifier(pic_state *pic) { @@ -966,8 +750,6 @@ pic_init_macro(pic_state *pic) pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc); pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); - pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer); - pic_defun(pic, "ir-macro-transformer", pic_macro_ir_macro_transformer); pic_defun(pic, "make-identifier", pic_macro_make_identifier); } } From bb9be2c628233dbad2c8f295a716509f2f868f76 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:45:09 +0900 Subject: [PATCH 182/200] remove c impl of make-syntactic-closure --- src/macro.c | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/src/macro.c b/src/macro.c index 8be145f6..c6a5c286 100644 --- a/src/macro.c +++ b/src/macro.c @@ -637,17 +637,6 @@ pic_macro_macroexpand(pic_state *pic) return pic_macroexpand(pic, expr); } -static struct pic_sc * -sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - struct pic_sc *sc; - - sc = (struct pic_sc *)pic_obj_alloc(pic, sizeof(struct pic_sc), PIC_TT_SC); - sc->expr = expr; - sc->senv = senv; - return sc; -} - static bool sc_identifier_p(pic_value obj) { @@ -677,23 +666,6 @@ sc_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_ return pic_eq_p(x, y); } -static pic_value -pic_macro_make_sc(pic_state *pic) -{ - pic_value senv, free_vars, expr; - struct pic_sc *sc; - - pic_get_args(pic, "ooo", &senv, &free_vars, &expr); - - if (! pic_senv_p(senv)) - pic_error(pic, "make-syntactic-closure: senv required"); - - /* just ignore free_vars for now */ - sc = sc_new(pic, expr, pic_senv_ptr(senv)); - - return pic_obj_value(sc); -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -747,7 +719,6 @@ pic_init_macro(pic_state *pic) pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); - pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc); pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); pic_defun(pic, "make-identifier", pic_macro_make_identifier); From e5511027e8eae660f81f144200cab86ca1871101 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:58:08 +0900 Subject: [PATCH 183/200] add type check guards to comparators --- piclib/built-in.scm | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 51cfa5f5..c3323516 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -113,8 +113,12 @@ (dictionary-set! cache sym id) id))) - (define (compare sym1 sym2) - (identifier=? use-env sym1 use-env sym2)) + (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))) @@ -161,8 +165,12 @@ (dictionary-set! cache sym id) id))) - (define (compare sym1 sym2) - (identifier=? mac-env sym1 mac-env sym2)) + (define (compare x y) + (if (not (symbol? x)) + #f + (if (not (symbol? y)) + #f + (identifier=? mac-env x mac-env y)))) (unwrap (f (wrap expr) inject compare)))) From 8781b9a6aaa7ecc50d15b8f9418b315723d1005c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:58:45 +0900 Subject: [PATCH 184/200] publish pic_identifier_p and pic_identifier_eq_p --- include/picrin/macro.h | 3 +++ src/macro.c | 57 ++++++++++++++++++------------------------ 2 files changed, 27 insertions(+), 33 deletions(-) diff --git a/include/picrin/macro.h b/include/picrin/macro.h index b733a5fe..31fe5983 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -38,6 +38,9 @@ struct pic_sc { struct pic_senv *pic_null_syntactic_environment(pic_state *); +bool pic_identifier_p(pic_state *pic, pic_value obj); +bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym); + pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); diff --git a/src/macro.c b/src/macro.c index c6a5c286..859bdeb5 100644 --- a/src/macro.c +++ b/src/macro.c @@ -615,6 +615,25 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) 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) +{ + struct pic_dict *cxt; + + cxt = pic_dict_new(pic); + + x = make_identifier(pic, x, e1, cxt); + y = make_identifier(pic, y, e2, cxt); + + return x == y; +} + static pic_value pic_macro_gensym(pic_state *pic) { @@ -637,35 +656,6 @@ pic_macro_macroexpand(pic_state *pic) return pic_macroexpand(pic, expr); } -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) -{ - struct pic_dict *cxt; - - if (! (sc_identifier_p(x) && sc_identifier_p(y))) { - return false; - } - - cxt = pic_dict_new(pic); - - x = macroexpand(pic, x, e1, cxt); - y = macroexpand(pic, y, e2, cxt); - - return pic_eq_p(x, y); -} - static pic_value pic_macro_identifier_p(pic_state *pic) { @@ -673,16 +663,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"); @@ -693,7 +684,7 @@ 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 From 6cc37281d63e9bd0b73adb9c85240c5b88d0c666 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 13:59:21 +0900 Subject: [PATCH 185/200] remove pic_tt_sc type --- include/picrin/macro.h | 9 --------- include/picrin/value.h | 3 --- src/codegen.c | 1 - src/gc.c | 9 --------- src/macro.c | 3 --- src/write.c | 5 ----- 6 files changed, 30 deletions(-) diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 31fe5983..023c2785 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -21,15 +21,6 @@ struct pic_macro { struct pic_senv *senv; }; -struct pic_sc { - PIC_OBJECT_HEADER - pic_value expr; - struct pic_senv *senv; -}; - -#define pic_sc_p(v) (pic_type(v) == PIC_TT_SC) -#define pic_sc_ptr(v) ((struct pic_sc *)pic_ptr(v)) - #define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO) #define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v)) diff --git a/include/picrin/value.h b/include/picrin/value.h index d6a07e20..e8eb7342 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -111,7 +111,6 @@ enum pic_tt { PIC_TT_CONT, PIC_TT_SENV, PIC_TT_MACRO, - PIC_TT_SC, PIC_TT_LIB, PIC_TT_VAR, PIC_TT_IREP, @@ -256,8 +255,6 @@ pic_type_repr(enum pic_tt tt) return "cont"; case PIC_TT_PROC: return "proc"; - case PIC_TT_SC: - return "sc"; case PIC_TT_SENV: return "senv"; case PIC_TT_MACRO: diff --git a/src/codegen.c b/src/codegen.c index 77e74e26..d098842e 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -826,7 +826,6 @@ 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: diff --git a/src/gc.c b/src/gc.c index 97532671..21aebb9e 100644 --- a/src/gc.c +++ b/src/gc.c @@ -461,12 +461,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } break; } - case PIC_TT_SC: { - struct pic_sc *sc = (struct pic_sc *)obj; - gc_mark(pic, sc->expr); - gc_mark_object(pic, (struct pic_object *)sc->senv); - break; - } case PIC_TT_LIB: { struct pic_lib *lib = (struct pic_lib *)obj; gc_mark(pic, lib->name); @@ -641,9 +635,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) case PIC_TT_MACRO: { break; } - case PIC_TT_SC: { - break; - } case PIC_TT_LIB: { struct pic_lib *lib = (struct pic_lib *)obj; xh_destroy(&lib->exports); diff --git a/src/macro.c b/src/macro.c index 859bdeb5..d8398523 100644 --- a/src/macro.c +++ b/src/macro.c @@ -454,9 +454,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p #endif switch (pic_type(expr)) { - case PIC_TT_SC: { - return macroexpand(pic, pic_sc_ptr(expr)->expr, pic_sc_ptr(expr)->senv, cxt); - } case PIC_TT_SYMBOL: { return macroexpand_symbol(pic, pic_sym(expr), senv, cxt); } diff --git a/src/write.c b/src/write.c index 4aae7e44..9ced3904 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; From 6104a69e2b4114a646a6e064728b466892379477 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:10:38 +0900 Subject: [PATCH 186/200] generate identifier for unbound symbol in context-free --- src/macro.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/macro.c b/src/macro.c index d8398523..ae41f951 100644 --- a/src/macro.c +++ b/src/macro.c @@ -86,13 +86,7 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_d break; senv = senv->up; } - if (pic_dict_has(pic, cxt, sym)) { - return pic_sym(pic_dict_ref(pic, cxt, sym)); - } else { - rename = pic_gensym(pic, sym); - pic_dict_set(pic, cxt, sym, pic_sym_value(rename)); - return rename; - } + return pic_gensym(pic, sym); } static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); From 5b41b979d9ca258f3582afac190f1f56f32bac92 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:11:33 +0900 Subject: [PATCH 187/200] [bugfix] abuse compare of er-macro --- piclib/built-in.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index c3323516..379208a7 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1418,7 +1418,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) '())) From 0fb9e18735031e0e1dcc569c9c741a978a3ba858 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:14:14 +0900 Subject: [PATCH 188/200] cxt objects are no longer used --- src/macro.c | 86 +++++++++++++++++++++++++---------------------------- 1 file changed, 41 insertions(+), 45 deletions(-) diff --git a/src/macro.c b/src/macro.c index ae41f951..49fbe345 100644 --- a/src/macro.c +++ b/src/macro.c @@ -74,7 +74,7 @@ find_macro(pic_state *pic, pic_sym rename) } static pic_sym -make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) +make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) { pic_sym rename; @@ -89,12 +89,12 @@ make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_d return pic_gensym(pic, sym); } -static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *, struct pic_dict *); +static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); static pic_value -macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *cxt) +macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) { - return pic_sym_value(make_identifier(pic, sym, senv, cxt)); + return pic_sym_value(make_identifier(pic, sym, senv)); } static pic_value @@ -181,17 +181,17 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr) } static pic_value -macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt) +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, cxt); - tail = macroexpand_list(pic, pic_cdr(pic, obj), senv, cxt); + 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, cxt); + x = macroexpand(pic, obj, senv); } pic_gc_arena_restore(pic, ai); @@ -200,7 +200,7 @@ macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pi } static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) { pic_value formal, body; struct pic_senv *in; @@ -218,7 +218,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_value v = pic_car(pic, a); if (! pic_sym_p(v)) { - v = macroexpand(pic, v, senv, cxt); + v = macroexpand(pic, v, senv); } if (! pic_sym_p(v)) { pic_error(pic, "syntax error"); @@ -226,7 +226,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_add_rename(pic, in, pic_sym(v)); } if (! pic_sym_p(a)) { - a = macroexpand(pic, a, senv, cxt); + a = macroexpand(pic, a, senv); } if (pic_sym_p(a)) { pic_add_rename(pic, in, pic_sym(a)); @@ -235,14 +235,14 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_error(pic, "syntax error"); } - formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt); - body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt); + 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, struct pic_dict *cxt) +macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) { pic_sym sym; pic_value formal, body, var, val; @@ -261,7 +261,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct var = formal; } if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, cxt); + var = macroexpand(pic, var, senv); } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); @@ -272,15 +272,15 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct } 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, cxt); + 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, cxt); + val = macroexpand(pic, pic_car(pic, body), senv); } - return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); + 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, struct pic_dict *cxt) +macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) { pic_value var, val; pic_sym sym, rename; @@ -291,7 +291,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, str var = pic_cadr(pic, expr); if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, cxt); + var = macroexpand(pic, var, senv); } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); @@ -366,7 +366,7 @@ macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv) } static pic_value -macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv) { struct pic_senv *in; pic_value formal, v, var, val; @@ -387,7 +387,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st pic_for_each (v, formal) { var = pic_car(pic, v); if (! pic_sym_p(var)) { - var = macroexpand(pic, var, senv, cxt); + var = macroexpand(pic, var, senv); } if (! pic_sym_p(var)) { pic_error(pic, "binding to non-symbol object"); @@ -402,11 +402,11 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st } define_macro(pic, rename, pic_proc_ptr(val), senv); } - return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); + return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in)); } static pic_value -macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) { pic_value v, args; @@ -435,11 +435,11 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct puts(""); #endif - return macroexpand(pic, v, senv, cxt); + return macroexpand(pic, v, senv); } static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) { #if DEBUG printf("[macroexpand] expanding... "); @@ -449,7 +449,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p switch (pic_type(expr)) { case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym(expr), senv, cxt); + return macroexpand_symbol(pic, pic_sym(expr), senv); } case PIC_TT_PAIR: { pic_value car; @@ -459,7 +459,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); } - car = macroexpand(pic, pic_car(pic, expr), senv, cxt); + car = macroexpand(pic, pic_car(pic, expr), senv); if (pic_sym_p(car)) { pic_sym tag = pic_sym(car); @@ -473,33 +473,33 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p return macroexpand_export(pic, expr); } else if (tag == pic->rDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, senv, cxt); + return macroexpand_defsyntax(pic, expr, senv); } else if (tag == pic->rDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } else if (tag == pic->rLET_SYNTAX) { - return macroexpand_let_syntax(pic, expr, senv, cxt); + return macroexpand_let_syntax(pic, expr, senv); } /* else if (tag == pic->sLETREC_SYNTAX) { */ - /* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */ + /* return macroexpand_letrec_syntax(pic, expr, senv); */ /* } */ else if (tag == pic->rLAMBDA) { - return macroexpand_lambda(pic, expr, senv, cxt); + return macroexpand_lambda(pic, expr, senv); } else if (tag == pic->rDEFINE) { - return macroexpand_define(pic, expr, senv, cxt); + return macroexpand_define(pic, expr, senv); } else if (tag == pic->rQUOTE) { return macroexpand_quote(pic, expr); } if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_macro(pic, mac, expr, senv, cxt); + return macroexpand_macro(pic, mac, expr, senv); } } - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv, cxt)); + return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); } case PIC_TT_EOF: case PIC_TT_NIL: @@ -532,12 +532,12 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p } static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) +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, cxt); + v = macroexpand_node(pic, expr, senv); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, v); @@ -555,7 +555,7 @@ pic_macroexpand(pic_state *pic, pic_value expr) puts(""); #endif - v = macroexpand(pic, expr, pic->lib->senv, pic_dict_new(pic)); + v = macroexpand(pic, expr, pic->lib->senv); #if DEBUG puts("after expand:"); @@ -615,12 +615,8 @@ pic_identifier_p(pic_state *pic, pic_value obj) bool pic_identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_sym x, struct pic_senv *e2, pic_sym y) { - struct pic_dict *cxt; - - cxt = pic_dict_new(pic); - - x = make_identifier(pic, x, e1, cxt); - y = make_identifier(pic, y, e2, cxt); + x = make_identifier(pic, x, e1); + y = make_identifier(pic, y, e2); return x == y; } @@ -688,7 +684,7 @@ pic_macro_make_identifier(pic_state *pic) pic_assert_type(pic, obj, senv); - return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj), pic_dict_new(pic))); + return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); } void From e9c84536bd85ff8d663f51b95182daaefeacffed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:17:47 +0900 Subject: [PATCH 189/200] fix #160 --- contrib/20.for/piclib/for.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/contrib/20.for/piclib/for.scm b/contrib/20.for/piclib/for.scm index d37afd9f..3befa0ba 100644 --- a/contrib/20.for/piclib/for.scm +++ b/contrib/20.for/piclib/for.scm @@ -1,7 +1,6 @@ (define-library (picrin control list) (import (scheme base) - (picrin control) - (scheme write)) + (picrin control)) (define-syntax for (syntax-rules () From b99bddcad03ec0d8a2d216b84bb06a53f9810957 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:22:53 +0900 Subject: [PATCH 190/200] rename built-in.scm to prelude.scm --- piclib/CMakeLists.txt | 2 +- piclib/{built-in.scm => prelude.scm} | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename piclib/{built-in.scm => prelude.scm} (100%) diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index aaf66fdd..b32b3690 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,5 +1,5 @@ list(APPEND PICLIB_SCHEME_LIBS - ${PROJECT_SOURCE_DIR}/piclib/built-in.scm + ${PROJECT_SOURCE_DIR}/piclib/prelude.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm diff --git a/piclib/built-in.scm b/piclib/prelude.scm similarity index 100% rename from piclib/built-in.scm rename to piclib/prelude.scm From 98bb47dfb685149690b964f7aed7c18e0bace754 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 10:04:06 +0900 Subject: [PATCH 191/200] remove pic_papply --- include/picrin/proc.h | 2 -- src/proc.c | 30 ------------------------------ 2 files changed, 32 deletions(-) diff --git a/include/picrin/proc.h b/include/picrin/proc.h index 039a4384..e6d9fdbc 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -59,8 +59,6 @@ int pic_proc_cv_size(pic_state *, struct pic_proc *); pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t); void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value); -struct pic_proc *pic_papply(pic_state *, struct pic_proc *, pic_value); - #if defined(__cplusplus) } #endif diff --git a/src/proc.c b/src/proc.c index cfb9bcbb..c96f0e62 100644 --- a/src/proc.c +++ b/src/proc.c @@ -99,36 +99,6 @@ pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v) 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; -} - static pic_value pic_proc_proc_p(pic_state *pic) { From f46114ca034cee7e5088cb5b36628d8f09878792 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 10:08:58 +0900 Subject: [PATCH 192/200] [experimental] use attributes for cv implementation --- src/proc.c | 24 +++--------------------- 1 file changed, 3 insertions(+), 21 deletions(-) diff --git a/src/proc.c b/src/proc.c index c96f0e62..d7f391b0 100644 --- a/src/proc.c +++ b/src/proc.c @@ -61,42 +61,24 @@ pic_proc_attr(pic_state *pic, struct pic_proc *proc) void pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size) { - struct pic_env *env; - - if (proc->env != NULL) { - pic_error(pic, "env slot already in use"); - } - 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 0; } pic_value pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i) { - if (proc->env == NULL) { - pic_error(pic, "no closed env"); - } - return proc->env->regs[i]; + return pic_dict_ref(pic, pic_proc_attr(pic, proc), i); /* FIXME */ } void pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v) { - if (proc->env == NULL) { - pic_error(pic, "no closed env"); - } - proc->env->regs[i] = v; + pic_dict_set(pic, pic_proc_attr(pic, proc), i, v); /* FIXME */ } static pic_value From cb3c4e8e22bad715552662993cf8ced11b2da478 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 10:13:18 +0900 Subject: [PATCH 193/200] remove use of pic_proc_cv_init --- include/picrin/proc.h | 2 -- src/cont.c | 2 -- src/proc.c | 11 ----------- 3 files changed, 15 deletions(-) diff --git a/include/picrin/proc.h b/include/picrin/proc.h index e6d9fdbc..d72ddc04 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -54,8 +54,6 @@ pic_sym pic_proc_name(struct pic_proc *); struct pic_dict *pic_proc_attr(pic_state *, struct pic_proc *); /* closed variables accessor */ -void pic_proc_cv_init(pic_state *, struct pic_proc *, size_t); -int pic_proc_cv_size(pic_state *, struct pic_proc *); pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t); void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value); diff --git a/src/cont.c b/src/cont.c index f84e55c7..f76a6695 100644 --- a/src/cont.c +++ b/src/cont.c @@ -245,7 +245,6 @@ 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)); return pic_apply1(pic, proc, pic_obj_value(c)); @@ -267,7 +266,6 @@ 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)); return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); diff --git a/src/proc.c b/src/proc.c index d7f391b0..bd11bcf4 100644 --- a/src/proc.c +++ b/src/proc.c @@ -58,17 +58,6 @@ pic_proc_attr(pic_state *pic, struct pic_proc *proc) return proc->attr; } -void -pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size) -{ -} - -int -pic_proc_cv_size(pic_state *pic, struct pic_proc *proc) -{ - return 0; -} - pic_value pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i) { From 4714df48f0712c251aedd1b9099f1eaf76d73b3f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:28:36 +0900 Subject: [PATCH 194/200] s/pic_proc_attr/pic_attr/g --- include/picrin/proc.h | 2 +- src/proc.c | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/include/picrin/proc.h b/include/picrin/proc.h index d72ddc04..40dfc46c 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -51,7 +51,7 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en pic_sym pic_proc_name(struct pic_proc *); -struct pic_dict *pic_proc_attr(pic_state *, struct pic_proc *); +struct pic_dict *pic_attr(pic_state *, struct pic_proc *); /* closed variables accessor */ pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t); diff --git a/src/proc.c b/src/proc.c index bd11bcf4..e3694a25 100644 --- a/src/proc.c +++ b/src/proc.c @@ -50,7 +50,7 @@ pic_proc_name(struct pic_proc *proc) } struct pic_dict * -pic_proc_attr(pic_state *pic, struct pic_proc *proc) +pic_attr(pic_state *pic, struct pic_proc *proc) { if (proc->attr == NULL) { proc->attr = pic_dict_new(pic); @@ -61,13 +61,13 @@ pic_proc_attr(pic_state *pic, struct pic_proc *proc) pic_value pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i) { - return pic_dict_ref(pic, pic_proc_attr(pic, proc), i); /* FIXME */ + return pic_dict_ref(pic, pic_attr(pic, proc), i); /* FIXME */ } void pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v) { - pic_dict_set(pic, pic_proc_attr(pic, proc), i, v); /* FIXME */ + pic_dict_set(pic, pic_attr(pic, proc), i, v); /* FIXME */ } static pic_value @@ -166,7 +166,7 @@ pic_proc_attribute(pic_state *pic) pic_get_args(pic, "l", &proc); - return pic_obj_value(pic_proc_attr(pic, proc)); + return pic_obj_value(pic_attr(pic, proc)); } void From c601dbf27e50514a5ec51ef95e1cfb3781e08575 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:31:26 +0900 Subject: [PATCH 195/200] rename pic_proc_cv_ref to pic_attr_ref --- include/picrin/proc.h | 6 ++---- src/cont.c | 6 +++--- src/proc.c | 8 ++++---- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/include/picrin/proc.h b/include/picrin/proc.h index 40dfc46c..b91960de 100644 --- a/include/picrin/proc.h +++ b/include/picrin/proc.h @@ -52,10 +52,8 @@ struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_en pic_sym pic_proc_name(struct pic_proc *); struct pic_dict *pic_attr(pic_state *, struct pic_proc *); - -/* closed variables accessor */ -pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t); -void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value); +pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *); +void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value); #if defined(__cplusplus) } diff --git a/src/cont.c b/src/cont.c index f76a6695..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,7 +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_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)); } @@ -266,7 +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_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/proc.c b/src/proc.c index e3694a25..84967224 100644 --- a/src/proc.c +++ b/src/proc.c @@ -59,15 +59,15 @@ pic_attr(pic_state *pic, struct pic_proc *proc) } 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) { - return pic_dict_ref(pic, pic_attr(pic, proc), i); /* FIXME */ + 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) { - pic_dict_set(pic, pic_attr(pic, proc), i, v); /* FIXME */ + pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v); } static pic_value From 32174d7855e70660e28964944b1d192225483ace Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:38:18 +0900 Subject: [PATCH 196/200] remove box --- include/picrin/box.h | 28 ---------------------------- include/picrin/value.h | 3 --- src/box.c | 30 ------------------------------ src/codegen.c | 1 - src/gc.c | 8 -------- src/macro.c | 1 - src/write.c | 3 --- 7 files changed, 74 deletions(-) delete mode 100644 include/picrin/box.h delete mode 100644 src/box.c diff --git a/include/picrin/box.h b/include/picrin/box.h deleted file mode 100644 index f9826eed..00000000 --- a/include/picrin/box.h +++ /dev/null @@ -1,28 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_BOX_H__ -#define PICRIN_BOX_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_box { - PIC_OBJECT_HEADER - pic_value value; -}; - -#define pic_box_p(v) (pic_type(v) == PIC_TT_BOX) -#define pic_box_ptr(v) ((struct pic_box *)pic_ptr(v)) - -pic_value pic_box(pic_state *, pic_value); -pic_value pic_unbox(pic_state *, pic_value); -void pic_set_box(pic_state *, pic_value, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/value.h b/include/picrin/value.h index e8eb7342..283bac28 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -115,7 +115,6 @@ enum pic_tt { PIC_TT_VAR, PIC_TT_IREP, PIC_TT_DATA, - PIC_TT_BOX, PIC_TT_DICT }; @@ -267,8 +266,6 @@ pic_type_repr(enum pic_tt tt) return "irep"; case PIC_TT_DATA: return "data"; - case PIC_TT_BOX: - return "box"; case PIC_TT_DICT: return "dict"; } 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 d098842e..df4c0239 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -830,7 +830,6 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) 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/gc.c b/src/gc.c index 21aebb9e..aa2d383d 100644 --- a/src/gc.c +++ b/src/gc.c @@ -494,11 +494,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; @@ -656,9 +651,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/macro.c b/src/macro.c index 49fbe345..636a968e 100644 --- a/src/macro.c +++ b/src/macro.c @@ -524,7 +524,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) 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); } diff --git a/src/write.c b/src/write.c index 9ced3904..61551b1a 100644 --- a/src/write.c +++ b/src/write.c @@ -330,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; From 2758c55e3ea515092cea07a929a2e3010bd4f4c5 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:41:00 +0900 Subject: [PATCH 197/200] remove box.h include --- src/gc.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/gc.c b/src/gc.c index aa2d383d..d77393c8 100644 --- a/src/gc.c +++ b/src/gc.c @@ -19,7 +19,6 @@ #include "picrin/lib.h" #include "picrin/var.h" #include "picrin/data.h" -#include "picrin/box.h" #include "picrin/dict.h" #if GC_DEBUG From 690bdcb83dbced37237dab15413ae5e52354bef1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:43:25 +0900 Subject: [PATCH 198/200] add srfi 111 --- piclib/CMakeLists.txt | 1 + piclib/srfi/111.scm | 8 ++++++++ 2 files changed, 9 insertions(+) create mode 100644 piclib/srfi/111.scm diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index b32b3690..6898de1b 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -8,4 +8,5 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/srfi/43.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/60.scm ${PROJECT_SOURCE_DIR}/piclib/srfi/95.scm + ${PROJECT_SOURCE_DIR}/piclib/srfi/111.scm ) diff --git a/piclib/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!)) From f66bea4e97e37045fa4a593584521feb3867859b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:47:50 +0900 Subject: [PATCH 199/200] add close-syntax --- piclib/prelude.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/piclib/prelude.scm b/piclib/prelude.scm index 379208a7..3b84c974 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -92,6 +92,9 @@ (dictionary-set! cache atom id) id))))))) + (define (close-syntax form env) + (make-syntactic-closure form '() env)) + (define (sc-macro-transformer f) (lambda (expr use-env mac-env) (make-syntactic-closure mac-env '() (f expr use-env)))) @@ -174,7 +177,9 @@ (unwrap (f (wrap expr) inject compare)))) - (export sc-macro-transformer + (export make-syntactic-closure + close-syntax + sc-macro-transformer rsc-macro-transformer er-macro-transformer ir-macro-transformer)) From 124ad994b288aba3d3e32b8d66b54814f5e37e81 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 17 Jul 2014 16:49:28 +0900 Subject: [PATCH 200/200] update docs --- docs/libs.rst | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/docs/libs.rst b/docs/libs.rst index f85938eb..ced52fd2 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -53,10 +53,15 @@ Utility functions and syntaces for macro definition. Old-fashioned macro. -- make-syntactic-closure - identifier? - identifier=? +- make-syntactic-closure +- close-syntax + +- sc-macro-transformer +- rsc-macro-transformer + Syntactic closures. - er-macro-transformer