declare core syntaces individually separate from (scheme base)

piclib/built-in.scm

@@ -1,14 +1,16 @@
 ;;; hygienic macros
+(define-library (picrin macro)
+  (import (scheme base))
 
-(define (sc-macro-transformer f)
+  (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)
+  (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)
+  (define (er-macro-transformer f)
     (lambda (expr use-env mac-env)
       (define (rename identifier)
         (make-syntactic-closure mac-env '() identifier))
@@ -16,13 +18,13 @@
         (identifier=? use-env x use-env y))
       (make-syntactic-closure use-env '() (f expr rename compare))))
 
-(define (walk f obj)
+  (define (walk f obj)
     (if (pair? obj)
         (cons (walk f (car obj))
               (walk f (cdr obj)))
         (f obj)))
 
-(define (ir-macro-transformer f)
+  (define (ir-macro-transformer f)
     (lambda (expr use-env mac-env)
       (define (inject identifier)
         (make-syntactic-closure use-env '() identifier))
@@ -32,48 +34,30 @@
         (walk (lambda (x) (if (symbol? x) (inject x) x)) expr))
       (make-syntactic-closure mac-env '() (f renamed inject compare))))
 
-;;; Core syntaxes
+  (export sc-macro-transformer
+          rsc-macro-transformer
+          er-macro-transformer
+          ir-macro-transformer))
 
-(define (list . args)
-  args)
+;;; core syntaces
+(define-library (picrin core-syntax)
+  (import (scheme base)
+          (picrin macro))
 
-(define (caar p)
-  (car (car p)))
+  (define (list . args) args)
 
-(define (cadr p)
-  (car (cdr p)))
+  (define (caar p) (car (car p)))
+  (define (cadr p) (car (cdr p)))
+  (define (cdar p) (cdr (car p)))
+  (define (cddr p) (cdr (cdr p)))
 
-(define (cdar p)
-  (cdr (car p)))
-
-(define (cddr p)
-  (cdr (cdr p)))
-
-(define (any pred list)
+  (define (map f list)
     (if (null? list)
-      #f
-      ((lambda (it)
-	 (if it
-	     it
-	     (any pred (cdr list))))
-       (pred (car list)))))
-
-(define (map f list . lists)
-  (define (single-map f list)
-    (if (null? list)
-	'()
+        list
         (cons (f (car list))
               (map f (cdr list)))))
-  (define (multiple-map f lists)
-    (if (any null? lists)
-	'()
-	(cons (apply f (single-map car lists))
-	      (multiple-map f (single-map cdr lists)))))
-  (if (null? lists)
-      (single-map f list)
-      (multiple-map f (cons list lists))))
 
-(define-macro (let bindings . body)
+  (define-macro (let bindings . body)
     (if (symbol? bindings)
         (begin
           (define name bindings)
@@ -92,7 +76,7 @@
         (cons (cons 'lambda (cons (map car bindings) body))
               (map cadr bindings))))
 
-(define-macro (cond . clauses)
+  (define-macro (cond . clauses)
     (if (null? clauses)
         #f
         (let ((c (car clauses)))
@@ -101,14 +85,14 @@
                 (if-false (cons 'cond (cdr clauses))))
             (list 'if test if-true if-false)))))
 
-(define-macro (and . exprs)
+  (define-macro (and . exprs)
     (if (null? exprs)
         #t
         (let ((test (car exprs))
               (if-true (cons 'and (cdr exprs))))
           (list 'if test if-true #f))))
 
-(define-macro (or . exprs)
+  (define-macro (or . exprs)
     (if (null? exprs)
         #f
         (let ((test (car exprs))
@@ -116,13 +100,13 @@
           (list 'let (list (list 'it test))
                 (list 'if 'it 'it if-false)))))
 
-(define (append xs ys)
+  (define (append xs ys)
     (if (null? xs)
         ys
         (cons (car xs)
               (append (cdr xs) ys))))
 
-(define-macro (quasiquote x)
+  (define-macro (quasiquote x)
     (cond
      ((symbol? x) (list 'quote x))
      ((pair? x)
@@ -136,7 +120,7 @@
                  (list 'quasiquote (cdr x))))))
      (#t x)))
 
-(define-macro (let* bindings . body)
+  (define-macro (let* bindings . body)
     (if (null? bindings)
         `(let () ,@body)
         `(let ((,(caar bindings)
@@ -144,17 +128,17 @@
            (let* (,@(cdr bindings))
              ,@body))))
 
-(define-macro (letrec bindings . body)
+  (define-macro (letrec bindings . body)
     (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
           (initials (map (lambda (v) `(set! ,@v)) bindings)))
       `(let (,@vars)
          (begin ,@initials)
          ,@body)))
 
-(define-macro (letrec* . args)
+  (define-macro (letrec* . args)
     `(letrec ,@args))
 
-(define-macro (do bindings finish . body)
+  (define-macro (do bindings finish . body)
     `(let loop ,(map (lambda (x)
                        (list (car x) (cadr x)))
                      bindings)
@@ -167,13 +151,13 @@
                                bindings)))
            (begin ,@(cdr finish)))))
 
-(define-macro (when test . exprs)
+  (define-macro (when test . exprs)
     (list 'if test (cons 'begin exprs) #f))
 
-(define-macro (unless test . exprs)
+  (define-macro (unless test . exprs)
     (list 'if test #f (cons 'begin exprs)))
 
-(define-syntax define-auxiliary-syntax
+  (define-syntax define-auxiliary-syntax
     (ir-macro-transformer
      (lambda (expr i c)
        `(define-syntax ,(cadr expr)
@@ -181,12 +165,53 @@
            (lambda (expr env)
              (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-auxiliary-syntax else)
+  (define-auxiliary-syntax =>)
+  (define-auxiliary-syntax _)
+  (define-auxiliary-syntax ...)
+  (define-auxiliary-syntax unquote)
+  (define-auxiliary-syntax unquote-splicing)
+
+  (export let let* letrec letrec*
+          quasiquote unquote unquote-splicing
+          and or
+          cond else =>
+          do
+          when unless
+          _ ...))
+
+(import (picrin macro)
+        (picrin core-syntax))
+
+(define (list . args)
+  args)
+
+(define (caar p)
+  (car (car p)))
+
+(define (cadr p)
+  (car (cdr p)))
+
+(define (cdar p)
+  (cdr (car p)))
+
+(define (cddr p)
+  (cdr (cdr p)))
+
+(define (append xs ys)
+  (if (null? xs)
+      ys
+      (cons (car xs)
+            (append (cdr xs) ys))))
+
+(define (any pred list)
+  (if (null? list)
+      #f
+      ((lambda (it)
+	 (if it
+	     it
+	     (any pred (cdr list))))
+       (pred (car list)))))
 
 (define (every pred list)
   (if (null? list)
@@ -383,7 +408,11 @@
 
 (define-macro (define-char-transitive-predicate name op)
   `(define (,name . cs)
-     (apply ,op (map char->integer cs))))
+     (letrec ((map (lambda (f list)
+                     (if (null? list)
+                         list
+                         (cons (f (car list)) (map f (cdr list)))))))
+       (apply ,op (map char->integer cs)))))
 
 (define-char-transitive-predicate char=? =)
 (define-char-transitive-predicate char<? <)
@@ -561,6 +590,21 @@
 
 ;;; 6.10 control features
 
+(define (map f list . lists)
+  (define (single-map f list)
+    (if (null? list)
+	'()
+	(cons (f (car list))
+	      (map f (cdr list)))))
+  (define (multiple-map f lists)
+    (if (any null? lists)
+	'()
+	(cons (apply f (single-map car lists))
+	      (multiple-map f (single-map cdr lists)))))
+  (if (null? lists)
+      (single-map f list)
+      (multiple-map f (cons list lists))))
+
 (define (for-each f list . lists)
   (define (single-for-each f list)
     (if (null? list)