Merge branch 'prelude-refactoring'

piclib/CMakeLists.txt

@@ -1,7 +1,12 @@
 list(APPEND PICLIB_SCHEME_LIBS
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm # the only dependency prelude requires
   ${PROJECT_SOURCE_DIR}/piclib/prelude.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
+  ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm

piclib/picrin/macro.scm

@@ -0,0 +1,158 @@
+;;; Hygienic Macros
+
+(define-library (picrin macro)
+  (import (scheme base)
+          (picrin dictionary))
+
+  ;; assumes no derived expressions are provided yet
+
+  (define (memq obj list)
+    (if (null? list)
+        #f
+        (if (eq? obj (car list))
+            list
+            (memq obj (cdr list)))))
+
+  (define (list->vector list)
+    (define vector (make-vector (length list)))
+    (define (go list i)
+      (if (null? list)
+          vector
+          (begin
+            (vector-set! vector i (car list))
+            (go (cdr list) (+ i 1)))))
+    (go list 0))
+
+  (define (vector->list vector)
+    (define (go i)
+      (if (= i (vector-length vector))
+          '()
+          (cons (vector-ref vector i)
+                (go (+ i 1)))))
+    (go 0))
+
+  (define (vector-map proc expr)
+    (list->vector (map proc (vector->list expr))))
+
+  (define (walk proc expr)
+    (if (null? expr)
+        '()
+        (if (pair? expr)
+            (cons (walk proc (car expr))
+                  (walk proc (cdr expr)))
+            (if (vector? expr)
+                (vector-map proc expr)
+                (proc expr)))))
+
+  (define (make-syntactic-closure env free form)
+    (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)))))
+     form))
+
+  (define (close-syntax form env)
+    (make-syntactic-closure env '() form))
+
+  (define-syntax capture-syntactic-environment
+    (lambda (form use-env mac-env)
+      (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
+
+  (define (sc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure mac-env '() (f expr use-env))))
+
+  (define (rsc-macro-transformer f)
+    (lambda (expr use-env mac-env)
+      (make-syntactic-closure use-env '() (f expr mac-env))))
+
+  (define (er-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define cache (make-dictionary))
+
+      (define (rename sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym mac-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? use-env x use-env y))))
+
+      (f expr rename compare)))
+
+  (define (ir-macro-transformer f)
+    (lambda (expr use-env mac-env)
+
+      (define protects (make-dictionary))
+
+      (define (wrap expr)
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (begin
+                 (define id (make-identifier atom use-env))
+                 (dictionary-set! protects id atom) ; lookup *atom* from id
+                 id)))
+         expr))
+
+      (define (unwrap expr)
+        (define cache (make-dictionary))
+        (walk
+         (lambda (atom)
+           (if (not (symbol? atom))
+               atom
+               (if (dictionary-has? protects atom)
+                   (dictionary-ref protects atom)
+                   (if (dictionary-has? cache atom)
+                       (dictionary-ref cache atom)
+                       (begin
+                         ;; implicit renaming
+                         (define id (make-identifier atom mac-env))
+                         (dictionary-set! cache atom id)
+                         id)))))
+         expr))
+
+      (define cache (make-dictionary))
+
+      (define (inject sym)
+        (if (dictionary-has? cache sym)
+            (dictionary-ref cache sym)
+            (begin
+              (define id (make-identifier sym use-env))
+              (dictionary-set! cache sym id)
+              id)))
+
+      (define (compare x y)
+        (if (not (symbol? x))
+            #f
+            (if (not (symbol? y))
+                #f
+                (identifier=? mac-env x mac-env y))))
+
+      (unwrap (f (wrap expr) inject compare))))
+
+  (export make-syntactic-closure
+          close-syntax
+          capture-syntactic-environment
+          sc-macro-transformer
+          rsc-macro-transformer
+          er-macro-transformer
+          ir-macro-transformer))

piclib/prelude.scm

@@ -1,201 +1,13 @@
-;;; Appendix A. Standard Libraries CxR
-(define-library (scheme cxr)
-  (import (scheme base))
-
-  (define (caaar p) (car (caar p)))
-  (define (caadr p) (car (cadr p)))
-  (define (cadar p) (car (cdar p)))
-  (define (caddr p) (car (cddr p)))
-  (define (cdaar p) (cdr (caar p)))
-  (define (cdadr p) (cdr (cadr p)))
-  (define (cddar p) (cdr (cdar p)))
-  (define (cdddr p) (cdr (cddr p)))
-  (define (caaaar p) (caar (caar p)))
-  (define (caaadr p) (caar (cadr p)))
-  (define (caadar p) (caar (cdar p)))
-  (define (caaddr p) (caar (cddr p)))
-  (define (cadaar p) (cadr (caar p)))
-  (define (cadadr p) (cadr (cadr p)))
-  (define (caddar p) (cadr (cdar p)))
-  (define (cadddr p) (cadr (cddr p)))
-  (define (cdaaar p) (cdar (caar p)))
-  (define (cdaadr p) (cdar (cadr p)))
-  (define (cdadar p) (cdar (cdar p)))
-  (define (cdaddr p) (cdar (cddr p)))
-  (define (cddaar p) (cddr (caar p)))
-  (define (cddadr p) (cddr (cadr p)))
-  (define (cdddar p) (cddr (cdar p)))
-  (define (cddddr p) (cddr (cddr p)))
-
-  (export caaar caadr cadar caddr
-          cdaar cdadr cddar cdddr
-          caaaar caaadr caadar caaddr
-          cadaar cadadr caddar cadddr
-          cdaaar cdaadr cdadar cdaddr
-          cddaar cddadr cdddar cddddr))
-
-;;; hygienic macros
-(define-library (picrin macro)
-  (import (scheme base)
-          (picrin dictionary))
-
-  (define (memq obj list)
-    (if (null? list)
-        #f
-        (if (eq? obj (car list))
-            list
-            (memq obj (cdr list)))))
-
-  (define (list->vector list)
-    (define vector (make-vector (length list)))
-    (define (go list i)
-      (if (null? list)
-          vector
-          (begin
-            (vector-set! vector i (car list))
-            (go (cdr list) (+ i 1)))))
-    (go list 0))
-
-  (define (vector->list vector)
-    (define (go i)
-      (if (= i (vector-length vector))
-          '()
-          (cons (vector-ref vector i)
-                (go (+ i 1)))))
-    (go 0))
-
-  (define (vector-map proc expr)
-    (list->vector (map proc (vector->list expr))))
-
-  (define (walk proc expr)
-    (if (null? expr)
-        '()
-        (if (pair? expr)
-            (cons (walk proc (car expr))
-                  (walk proc (cdr expr)))
-            (if (vector? expr)
-                (vector-map proc expr)
-                (proc expr)))))
-
-  (define (make-syntactic-closure env free form)
-    (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)))))
-     form))
-
-  (define (close-syntax form env)
-    (make-syntactic-closure env '() form))
-
-  (define-syntax capture-syntactic-environment
-    (lambda (form use-env mac-env)
-      (list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
-
-  (define (sc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure mac-env '() (f expr use-env))))
-
-  (define (rsc-macro-transformer f)
-    (lambda (expr use-env mac-env)
-      (make-syntactic-closure use-env '() (f expr mac-env))))
-
-  (define (er-macro-transformer f)
-    (lambda (expr use-env mac-env)
-
-      (define cache (make-dictionary))
-
-      (define (rename sym)
-        (if (dictionary-has? cache sym)
-            (dictionary-ref cache sym)
-            (begin
-              (define id (make-identifier sym mac-env))
-              (dictionary-set! cache sym id)
-              id)))
-
-      (define (compare x y)
-        (if (not (symbol? x))
-            #f
-            (if (not (symbol? y))
-                #f
-                (identifier=? use-env x use-env y))))
-
-      (f expr rename compare)))
-
-  (define (ir-macro-transformer f)
-    (lambda (expr use-env mac-env)
-
-      (define protects (make-dictionary))
-
-      (define (wrap expr)
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (begin
-                 (define id (make-identifier atom use-env))
-                 (dictionary-set! protects id atom) ; lookup *atom* from id
-                 id)))
-         expr))
-
-      (define (unwrap expr)
-        (define cache (make-dictionary))
-        (walk
-         (lambda (atom)
-           (if (not (symbol? atom))
-               atom
-               (if (dictionary-has? protects atom)
-                   (dictionary-ref protects atom)
-                   (if (dictionary-has? cache atom)
-                       (dictionary-ref cache atom)
-                       (begin
-                         ;; implicit renaming
-                         (define id (make-identifier atom mac-env))
-                         (dictionary-set! cache atom id)
-                         id)))))
-         expr))
-
-      (define cache (make-dictionary))
-
-      (define (inject sym)
-        (if (dictionary-has? cache sym)
-            (dictionary-ref cache sym)
-            (begin
-              (define id (make-identifier sym use-env))
-              (dictionary-set! cache sym id)
-              id)))
-
-      (define (compare x y)
-        (if (not (symbol? x))
-            #f
-            (if (not (symbol? y))
-                #f
-                (identifier=? mac-env x mac-env y))))
-
-      (unwrap (f (wrap expr) inject compare))))
-
-  (export make-syntactic-closure
-          close-syntax
-          capture-syntactic-environment
-          sc-macro-transformer
-          rsc-macro-transformer
-          er-macro-transformer
-          ir-macro-transformer))
-
 ;;; core syntaces
 (define-library (picrin core-syntax)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro))
 
+  (define-syntax syntax-error
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (apply error (cdr expr)))))
+
   (define-syntax define-auxiliary-syntax
     (er-macro-transformer
      (lambda (expr r c)
@@ -215,9 +27,9 @@
      (lambda (expr r compare)
        (if (symbol? (cadr expr))
            (begin
-             (define name (cadr expr))
+             (define name     (car (cdr expr)))
-             (define bindings (caddr expr))
+             (define bindings (car (cdr (cdr expr))))
-             (define body (cdddr expr))
+             (define body     (cdr (cdr (cdr expr))))
              (list (r 'let) '()
                    (list (r 'define) name
                          (cons (r 'lambda) (cons (map car bindings) body)))
@@ -234,23 +46,20 @@
        (let ((clauses (cdr expr)))
          (if (null? clauses)
              #f
-             (if (compare (r 'else) (caar clauses))
+             (begin
-                 (cons (r 'begin) (cdar clauses))
+               (define clause (car clauses))
-                 (if (if (>= (length (car clauses)) 2)
+               (if (compare (r 'else) (car clause))
-                         (compare (r '=>) (cadar clauses))
+                   (cons (r 'begin) (cdr clause))
+                   (if (if (>= (length clause) 2)
+                           (compare (r '=>) (list-ref clause 1))
                            #f)
-                     (list (r 'let) (list (list (r 'x) (caar clauses)))
+                       (list (r 'let) (list (list (r 'x) (car clause)))
                              (list (r 'if) (r 'x)
-                                 (list (caddar clauses) (r 'x))
+                                   (list (list-ref clause 2) (r 'x))
                                    (cons (r 'cond) (cdr clauses))))
-                     (list (r 'if) (caar clauses)
+                       (list (r 'if) (car clause)
-                           (cons (r 'begin) (cdar clauses))
+                             (cons (r 'begin) (cdr clause))
-                           (cons (r 'cond) (cdr clauses))))))))))
+                             (cons (r 'cond) (cdr clauses)))))))))))
-
-  (define (single? list)
-    (if (pair? list)
-        (null? (cdr list))
-        #f))
 
   (define-syntax and
     (er-macro-transformer
@@ -259,7 +68,7 @@
          (cond
           ((null? exprs)
            #t)
-          ((single? exprs)
+          ((= (length exprs) 1)
            (car exprs))
           (else
            (list (r 'let) (list (list (r 'it) (car exprs)))
@@ -274,7 +83,7 @@
          (cond
           ((null? exprs)
            #t)
-          ((single? exprs)
+          ((= (length exprs) 1)
            (car exprs))
           (else
            (list (r 'let) (list (list (r 'it) (car exprs)))
@@ -282,15 +91,6 @@
                        (r 'it)
                        (cons (r 'or) (cdr exprs))))))))))
 
-  (define (quasiquote? form compare?)
-    (and (pair? form) (compare? (car form) 'quasiquote)))
-
-  (define (unquote? form compare?)
-    (and (pair? form) (compare? (car form) 'unquote)))
-
-  (define (unquote-splicing? form compare?)
-    (and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
-
   (define (list->vector list)
     (let ((vector (make-vector (length list))))
       (let loop ((list list) (i 0))
@@ -311,17 +111,27 @@
     (ir-macro-transformer
      (lambda (form inject compare)
 
+       (define (quasiquote? form)
+         (and (pair? form) (compare (car form) 'quasiquote)))
+
+       (define (unquote? form)
+         (and (pair? form) (compare (car form) 'unquote)))
+
+       (define (unquote-splicing? form)
+         (and (pair? form) (pair? (car form))
+              (compare (car (car form)) 'unquote-splicing)))
+
        (define (qq depth expr)
          (cond
           ;; unquote
-          ((unquote? expr compare)
+          ((unquote? expr)
            (if (= depth 1)
                (car (cdr expr))
                (list 'list
                      (list 'quote (inject 'unquote))
                      (qq (- depth 1) (car (cdr expr))))))
           ;; unquote-splicing
-          ((unquote-splicing? expr compare)
+          ((unquote-splicing? expr)
            (if (= depth 1)
                (list 'append
                      (car (cdr (car expr)))
@@ -332,7 +142,7 @@
                            (qq (- depth 1) (car (cdr (car expr)))))
                      (qq depth (cdr expr)))))
           ;; quasiquote
-          ((quasiquote? expr compare)
+          ((quasiquote? expr)
            (list 'list
                  (list 'quote (inject 'quasiquote))
                  (qq (+ depth 1) (car (cdr expr)))))
@@ -395,9 +205,9 @@
   (define-syntax do
     (er-macro-transformer
      (lambda (form r compare)
-       (let ((bindings (cadr form))
+       (let ((bindings (car (cdr form)))
-             (finish (caddr form))
+             (finish   (car (cdr (cdr form))))
-             (body (cdddr form)))
+             (body     (cdr (cdr (cdr form)))))
          `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
                                         (list (car x) (cadr x)))
                                       bindings)
@@ -437,15 +247,18 @@
             ,(let loop ((clauses clauses))
                (if (null? clauses)
                    #f
-                   `(,(r 'if) ,(if (compare (r 'else) (caar clauses))
+                   (begin
+                     (define clause (car clauses))
+                     `(,(r 'if) ,(if (compare (r 'else) (car clause))
                                      '#t
                                      `(,(r 'or)
-                                     ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
+                                       ,@(map (lambda (x)
-                                            (caar clauses))))
+                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
-                     ,(if (compare (r '=>) (cadar clauses))
+                                              (car clause))))
-                          `(,(caddar clauses) ,(r 'key))
+                       ,(if (compare (r '=>) (list-ref clause 1))
-                          `(,(r 'begin) ,@(cdar clauses)))
+                            `(,(list-ref clause 2) ,(r 'key))
-                        ,(loop (cdr clauses))))))))))
+                            `(,(r 'begin) ,@(cdr clause)))
+                       ,(loop (cdr clauses)))))))))))
 
   (define-syntax letrec-syntax
     (er-macro-transformer
@@ -458,11 +271,6 @@
                    formal)
             ,@body)))))
 
-  (define-syntax syntax-error
-    (er-macro-transformer
-     (lambda (expr rename compare)
-       (apply error (cdr expr)))))
-
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or
@@ -471,13 +279,20 @@
           letrec-syntax
           _ ... syntax-error))
 
+(import (picrin core-syntax))
+
+(export let let* letrec letrec*
+        quasiquote unquote unquote-splicing
+        and or
+        cond case else =>
+        do when unless
+        letrec-syntax
+        _ ... syntax-error)
 
 ;;; multiple value
-(define-library (picrin multiple-value)
+(define-library (picrin values)
   (import (scheme base)
-          (scheme cxr)
+          (picrin macro))
-          (picrin macro)
-          (picrin core-syntax))
 
   (define-syntax let*-values
     (er-macro-transformer
@@ -522,18 +337,6 @@
        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)
@@ -548,10 +351,15 @@
               (formal* (walk uniq formal))
               (exprs   (cddr form)))
          `(begin
-            ,@(predefines (flatten formal))
+            ,@(map
+               (lambda (var) `(define ,var #f))
+               (flatten formal))
             (call-with-values (lambda () ,@exprs)
               (lambda ,formal*
-                ,@(assigns (flatten formal) (flatten formal*)))))))))
+                ,@(map
+                   (lambda (var val) `(set! ,var ,val))
+                   (flatten formal)
+                   (flatten formal*)))))))))
 
   (export let-values
           let*-values
@@ -560,9 +368,7 @@
 ;;; parameter
 (define-library (picrin parameter)
   (import (scheme base)
-          (scheme cxr)
           (picrin macro)
-          (picrin core-syntax)
           (picrin var)
           (picrin attribute)
           (picrin dictionary))
@@ -630,9 +436,7 @@
 ;;; Record Type
 (define-library (picrin record)
   (import (scheme base)
-	  (scheme cxr)
+          (picrin macro))
-	  (picrin macro)
-          (picrin core-syntax))
 
   (define record-marker (list 'record-marker))
 
@@ -737,9 +541,9 @@
   (define-syntax define-record-field
     (ir-macro-transformer
      (lambda (form inject compare?)
-       (let ((type (cadr form))
+       (let ((type      (car (cdr form)))
-	     (field-tag (caddr form))
+	     (field-tag (car (cdr (cdr form))))
-	     (acc-mod (cdddr form)))
+	     (acc-mod   (cdr (cdr (cdr form)))))
 	 (if (= 1 (length acc-mod))
 	     `(define ,(car acc-mod)
 		(record-accessor ,type ',field-tag))
@@ -753,9 +557,9 @@
     (ir-macro-transformer
      (lambda (form inject compare?)
        (let ((type (cadr form))
-	     (constructor (caddr form))
+	     (constructor (car (cdr (cdr form))))
-	     (predicate (cadddr form))
+	     (predicate   (car (cdr (cdr (cdr form)))))
-	     (field-tag (cddddr form)))
+	     (field-tag   (cdr (cdr (cdr (cdr form))))))
 	 `(begin
 	    (define ,type
 	      (make-record-type ',type ',(cdr constructor)))
@@ -768,22 +572,13 @@
 		 `(define-record-field ,type ,(car x) ,(cadr x) ,@(cddr x)))
 	       field-tag))))))
 
-  (export define-record-type vector?))
+  (export define-record-type))
 
 (import (picrin macro)
-        (picrin core-syntax)
+        (picrin values)
-        (picrin multiple-value)
         (picrin parameter)
         (picrin record))
 
-(export let let* letrec letrec*
-        quasiquote unquote unquote-splicing
-        and or
-        cond case else =>
-        do when unless
-        letrec-syntax
-        _ ... syntax-error)
-
 (export let-values
         let*-values
         define-values)
@@ -791,8 +586,7 @@
 (export make-parameter
         parameterize)
 
-(export vector?                         ; override definition
+(export define-record-type)
-        define-record-type)
 
 (define (every pred list)
   (if (null? list)
@@ -1158,25 +952,13 @@
 
 (export call-with-port)
 
-(define-library (scheme file)
-  (import (scheme base))
-
-  (define (call-with-input-file filename callback)
-    (call-with-port (open-input-file filename) callback))
-
-  (define (call-with-output-file filename callback)
-    (call-with-port (open-output-file filename) callback))
-
-  (export call-with-input-file
-          call-with-output-file))
-
 ;;; include syntax
 
 (import (scheme read)
         (scheme file))
 
 (define (read-many filename)
-  (call-with-input-file filename
+  (call-with-port (open-input-file filename)
     (lambda (port)
       (let loop ((expr (read port)) (exprs '()))
         (if (eof-object? expr)
@@ -1192,52 +974,9 @@
 
 (export include)
 
-;;; Appendix A. Standard Libraries Lazy
-(define-library (scheme lazy)
-  (import (scheme base)
-	  (picrin macro))
-
-  (define-record-type promise
-    (make-promise% done obj)
-    promise?
-    (done promise-done? promise-done!)
-    (obj promise-value promise-value!))
-
-  (define-syntax delay-force
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(make-promise% #f (lambda () ,expr))))))
-
-  (define-syntax delay
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(delay-force (make-promise% #t ,expr))))))
-
-  (define (promise-update! new old)
-    (promise-done! old (promise-done? new))
-    (promise-value! old (promise-value new)))
-
-  (define (force promise)
-    (if (promise-done? promise)
-	(promise-value promise)
-	(let ((promise* ((promise-value promise))))
-	  (unless (promise-done? promise)
-		  (promise-update! promise* promise))
-	  (force promise))))
-
-  (define (make-promise obj)
-    (if (promise? obj)
-	obj
-	(make-promise% #t obj)))
-
-  (export delay-force delay force make-promise promise?))
-
 ;;; syntax-rules
 (define-library (picrin syntax-rules)
   (import (scheme base)
-	  (scheme cxr)
           (picrin macro))
 
   ;;; utility functions
@@ -1511,9 +1250,9 @@
 	       ((compare (car clauses) 'mismatch)
 		`(,_syntax-error "invalid rule"))
 	       (else
-		(let ((vars (car (car clauses)))
+		(let ((vars (list-ref (car clauses) 0))
-		      (match (cadr (car clauses)))
+		      (match (list-ref (car clauses) 1))
-		      (expand (caddr (car clauses))))
+		      (expand (list-ref (car clauses) 2)))
 		  `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
 			  (,_let ((result (,_call/cc (,_lambda (exit) ,match))))
 				 (,_if result
@@ -1544,9 +1283,9 @@
 
        (let ((form (normalize-form form)))
 	 (if form
-	     (let ((ellipsis (cadr form))
+	     (let ((ellipsis (list-ref form 1))
-		   (literals (caddr form))
+		   (literals (list-ref form 2))
-		   (rules (cdddr form)))
+		   (rules (list-tail form 3)))
 	       (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
 				   rules)))
 		 `(,_er-macro-transformer
@@ -1560,32 +1299,3 @@
 (import (picrin syntax-rules))
 (export syntax-rules)
 
-(define-library (scheme case-lambda)
-  (import (scheme base))
-
-  (define-syntax case-lambda
-    (syntax-rules ()
-      ((case-lambda (params body0 ...) ...)
-       (lambda args
-         (let ((len (length args)))
-           (letrec-syntax
-               ((cl (syntax-rules ::: ()
-                      ((cl)
-                       (error "no matching clause"))
-                      ((cl ((p :::) . body) . rest)
-                       (if (= len (length '(p :::)))
-                           (apply (lambda (p :::)
-                                    . body)
-                                  args)
-                           (cl . rest)))
-                      ((cl ((p ::: . tail) . body)
-                           . rest)
-                       (if (>= len (length '(p :::)))
-                           (apply
-                            (lambda (p ::: . tail)
-                              . body)
-                            args)
-                           (cl . rest))))))
-             (cl (params body0 ...) ...)))))))
-
-  (export case-lambda))

piclib/scheme/case-lambda.scm

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

piclib/scheme/cxr.scm

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

piclib/scheme/file.scm

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

piclib/scheme/lazy.scm

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