move core syntaxes

piclib/picrin/base.scm

@@ -214,4 +214,257 @@
   (export write
           write-simple
           write-shared
-          display))
+          display)
+
+  (define-syntax syntax-error
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (apply error (cdr expr)))))
+
+  (define-syntax define-auxiliary-syntax
+    (er-macro-transformer
+     (lambda (expr r c)
+       (list (r 'define-syntax) (cadr expr)
+             (list (r 'lambda) '_
+                   (list (r 'error) "invalid use of auxiliary syntax"))))))
+
+  (define-auxiliary-syntax else)
+  (define-auxiliary-syntax =>)
+  (define-auxiliary-syntax _)
+  (define-auxiliary-syntax ...)
+  (define-auxiliary-syntax unquote)
+  (define-auxiliary-syntax unquote-splicing)
+
+  (define-syntax let
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (if (symbol? (cadr expr))
+           (begin
+             (define name     (car (cdr expr)))
+             (define bindings (car (cdr (cdr expr))))
+             (define body     (cdr (cdr (cdr expr))))
+             (list (r 'let) '()
+                   (list (r 'define) name
+                         (cons (r 'lambda) (cons (map car bindings) body)))
+                   (cons name (map cadr bindings))))
+           (begin
+             (set! bindings (cadr expr))
+             (set! body (cddr expr))
+             (cons (cons (r 'lambda) (cons (map car bindings) body))
+                   (map cadr bindings)))))))
+
+  (define-syntax cond
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((clauses (cdr expr)))
+         (if (null? clauses)
+             #f
+             (begin
+               (define clause (car clauses))
+               (if (compare (r 'else) (car clause))
+                   (cons (r 'begin) (cdr clause))
+                   (if (if (>= (length clause) 2)
+                           (compare (r '=>) (list-ref clause 1))
+                           #f)
+                       (list (r 'let) (list (list (r 'x) (car clause)))
+                             (list (r 'if) (r 'x)
+                                   (list (list-ref clause 2) (r 'x))
+                                   (cons (r 'cond) (cdr clauses))))
+                       (list (r 'if) (car clause)
+                             (cons (r 'begin) (cdr clause))
+                             (cons (r 'cond) (cdr clauses)))))))))))
+
+  (define-syntax and
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((exprs (cdr expr)))
+         (cond
+          ((null? exprs)
+           #t)
+          ((= (length exprs) 1)
+           (car exprs))
+          (else
+           (list (r 'let) (list (list (r 'it) (car exprs)))
+                 (list (r 'if) (r 'it)
+                       (cons (r 'and) (cdr exprs))
+                       (r 'it)))))))))
+
+  (define-syntax or
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((exprs (cdr expr)))
+         (cond
+          ((null? exprs)
+           #t)
+          ((= (length exprs) 1)
+           (car exprs))
+          (else
+           (list (r 'let) (list (list (r 'it) (car exprs)))
+                 (list (r 'if) (r 'it)
+                       (r 'it)
+                       (cons (r 'or) (cdr exprs))))))))))
+
+  (define-syntax quasiquote
+    (ir-macro-transformer
+     (lambda (form inject compare)
+
+       (define (quasiquote? form)
+         (and (pair? form) (compare (car form) 'quasiquote)))
+
+       (define (unquote? form)
+         (and (pair? form) (compare (car form) 'unquote)))
+
+       (define (unquote-splicing? form)
+         (and (pair? form) (pair? (car form))
+              (compare (car (car form)) 'unquote-splicing)))
+
+       (define (qq depth expr)
+         (cond
+          ;; unquote
+          ((unquote? expr)
+           (if (= depth 1)
+               (car (cdr expr))
+               (list 'list
+                     (list 'quote (inject 'unquote))
+                     (qq (- depth 1) (car (cdr expr))))))
+          ;; unquote-splicing
+          ((unquote-splicing? expr)
+           (if (= depth 1)
+               (list 'append
+                     (car (cdr (car expr)))
+                     (qq depth (cdr expr)))
+               (list 'cons
+                     (list 'list
+                           (list 'quote (inject 'unquote-splicing))
+                           (qq (- depth 1) (car (cdr (car expr)))))
+                     (qq depth (cdr expr)))))
+          ;; quasiquote
+          ((quasiquote? expr)
+           (list 'list
+                 (list 'quote (inject 'quasiquote))
+                 (qq (+ depth 1) (car (cdr expr)))))
+          ;; list
+          ((pair? expr)
+           (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))))
+
+       (let ((x (cadr form)))
+         (qq 1 x)))))
+
+  (define-syntax let*
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((bindings (cadr form))
+             (body (cddr form)))
+         (if (null? bindings)
+             `(,(r 'let) () ,@body)
+             `(,(r 'let) ((,(caar bindings)
+                           ,@(cdar bindings)))
+               (,(r 'let*) (,@(cdr bindings))
+                ,@body)))))))
+
+  (define-syntax letrec*
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((bindings (cadr form))
+             (body (cddr form)))
+         (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
+               (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
+           `(,(r 'let) (,@vars)
+             ,@initials
+             ,@body))))))
+
+  (define-syntax letrec
+    (er-macro-transformer
+     (lambda (form rename compare)
+       `(,(rename 'letrec*) ,@(cdr form)))))
+
+  (define-syntax do
+    (er-macro-transformer
+     (lambda (form r compare)
+       (let ((bindings (car (cdr form)))
+             (finish   (car (cdr (cdr form))))
+             (body     (cdr (cdr (cdr form)))))
+         `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
+                                        (list (car x) (cadr x)))
+                                      bindings)
+           (,(r 'if) ,(car finish)
+            (,(r 'begin) ,@(cdr finish))
+            (,(r 'begin) ,@body
+             (,(r 'loop) ,@(map (lambda (x)
+                                  (if (null? (cddr x))
+                                      (car x)
+                                      (car (cddr x))))
+                                bindings)))))))))
+
+  (define-syntax when
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (let ((test (cadr expr))
+             (body (cddr expr)))
+         `(,(rename 'if) ,test
+              (,(rename 'begin) ,@body)
+              #f)))))
+
+  (define-syntax unless
+    (er-macro-transformer
+     (lambda (expr rename compare)
+       (let ((test (cadr expr))
+             (body (cddr expr)))
+         `(,(rename 'if) ,test
+              #f
+              (,(rename 'begin) ,@body))))))
+
+  (define-syntax case
+    (er-macro-transformer
+     (lambda (expr r compare)
+       (let ((key (cadr expr))
+             (clauses (cddr expr)))
+         `(,(r 'let) ((,(r 'key) ,key))
+            ,(let loop ((clauses clauses))
+               (if (null? clauses)
+                   #f
+                   (begin
+                     (define clause (car clauses))
+                     `(,(r 'if) ,(if (compare (r 'else) (car clause))
+                                     '#t
+                                     `(,(r 'or)
+                                       ,@(map (lambda (x)
+                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
+                                              (car clause))))
+                       ,(if (compare (r '=>) (list-ref clause 1))
+                            `(,(list-ref clause 2) ,(r 'key))
+                            `(,(r 'begin) ,@(cdr clause)))
+                       ,(loop (cdr clauses)))))))))))
+
+  (define-syntax 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 let-syntax
+    (er-macro-transformer
+     (lambda (form r c)
+       `(,(r 'letrec-syntax) ,@(cdr form)))))
+
+  (export let let* letrec letrec*
+          quasiquote unquote unquote-splicing
+          and or
+          cond case else =>
+          do when unless
+          let-syntax letrec-syntax
+          include
+          _ ... syntax-error))

piclib/scheme/base.scm

@@ -10,266 +10,8 @@
           begin
           define-syntax)
 
-  ;; call/cc
-
-  (define real-callcc call-with-current-continuation)
-
-  (set! call-with-current-continuation
-        (lambda (f)
-          (real-callcc
-           (lambda (c)
-             (f (lambda args (apply continue c args)))))))
-
-  (define call/cc call-with-current-continuation)
-
-  (export call/cc)
-
   ;; core syntax
 
-  (define-syntax syntax-error
-    (er-macro-transformer
-     (lambda (expr rename compare)
-       (apply error (cdr expr)))))
-
-  (define-syntax define-auxiliary-syntax
-    (er-macro-transformer
-     (lambda (expr r c)
-       (list (r 'define-syntax) (cadr expr)
-             (list (r 'lambda) '_
-                   (list (r 'error) "invalid use of auxiliary syntax"))))))
-
-  (define-auxiliary-syntax else)
-  (define-auxiliary-syntax =>)
-  (define-auxiliary-syntax _)
-  (define-auxiliary-syntax ...)
-  (define-auxiliary-syntax unquote)
-  (define-auxiliary-syntax unquote-splicing)
-
-  (define-syntax let
-    (er-macro-transformer
-     (lambda (expr r compare)
-       (if (symbol? (cadr expr))
-           (begin
-             (define name     (car (cdr expr)))
-             (define bindings (car (cdr (cdr expr))))
-             (define body     (cdr (cdr (cdr expr))))
-             (list (r 'let) '()
-                   (list (r 'define) name
-                         (cons (r 'lambda) (cons (map car bindings) body)))
-                   (cons name (map cadr bindings))))
-           (begin
-             (set! bindings (cadr expr))
-             (set! body (cddr expr))
-             (cons (cons (r 'lambda) (cons (map car bindings) body))
-                   (map cadr bindings)))))))
-
-  (define-syntax cond
-    (er-macro-transformer
-     (lambda (expr r compare)
-       (let ((clauses (cdr expr)))
-         (if (null? clauses)
-             #f
-             (begin
-               (define clause (car clauses))
-               (if (compare (r 'else) (car clause))
-                   (cons (r 'begin) (cdr clause))
-                   (if (if (>= (length clause) 2)
-                           (compare (r '=>) (list-ref clause 1))
-                           #f)
-                       (list (r 'let) (list (list (r 'x) (car clause)))
-                             (list (r 'if) (r 'x)
-                                   (list (list-ref clause 2) (r 'x))
-                                   (cons (r 'cond) (cdr clauses))))
-                       (list (r 'if) (car clause)
-                             (cons (r 'begin) (cdr clause))
-                             (cons (r 'cond) (cdr clauses)))))))))))
-
-  (define-syntax and
-    (er-macro-transformer
-     (lambda (expr r compare)
-       (let ((exprs (cdr expr)))
-         (cond
-          ((null? exprs)
-           #t)
-          ((= (length exprs) 1)
-           (car exprs))
-          (else
-           (list (r 'let) (list (list (r 'it) (car exprs)))
-                 (list (r 'if) (r 'it)
-                       (cons (r 'and) (cdr exprs))
-                       (r 'it)))))))))
-
-  (define-syntax or
-    (er-macro-transformer
-     (lambda (expr r compare)
-       (let ((exprs (cdr expr)))
-         (cond
-          ((null? exprs)
-           #t)
-          ((= (length exprs) 1)
-           (car exprs))
-          (else
-           (list (r 'let) (list (list (r 'it) (car exprs)))
-                 (list (r 'if) (r 'it)
-                       (r 'it)
-                       (cons (r 'or) (cdr exprs))))))))))
-
-  (define-syntax quasiquote
-    (ir-macro-transformer
-     (lambda (form inject compare)
-
-       (define (quasiquote? form)
-         (and (pair? form) (compare (car form) 'quasiquote)))
-
-       (define (unquote? form)
-         (and (pair? form) (compare (car form) 'unquote)))
-
-       (define (unquote-splicing? form)
-         (and (pair? form) (pair? (car form))
-              (compare (car (car form)) 'unquote-splicing)))
-
-       (define (qq depth expr)
-         (cond
-          ;; unquote
-          ((unquote? expr)
-           (if (= depth 1)
-               (car (cdr expr))
-               (list 'list
-                     (list 'quote (inject 'unquote))
-                     (qq (- depth 1) (car (cdr expr))))))
-          ;; unquote-splicing
-          ((unquote-splicing? expr)
-           (if (= depth 1)
-               (list 'append
-                     (car (cdr (car expr)))
-                     (qq depth (cdr expr)))
-               (list 'cons
-                     (list 'list
-                           (list 'quote (inject 'unquote-splicing))
-                           (qq (- depth 1) (car (cdr (car expr)))))
-                     (qq depth (cdr expr)))))
-          ;; quasiquote
-          ((quasiquote? expr)
-           (list 'list
-                 (list 'quote (inject 'quasiquote))
-                 (qq (+ depth 1) (car (cdr expr)))))
-          ;; list
-          ((pair? expr)
-           (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))))
-
-       (let ((x (cadr form)))
-         (qq 1 x)))))
-
-  (define-syntax let*
-    (er-macro-transformer
-     (lambda (form r compare)
-       (let ((bindings (cadr form))
-             (body (cddr form)))
-         (if (null? bindings)
-             `(,(r 'let) () ,@body)
-             `(,(r 'let) ((,(caar bindings)
-                           ,@(cdar bindings)))
-               (,(r 'let*) (,@(cdr bindings))
-                ,@body)))))))
-
-  (define-syntax letrec*
-    (er-macro-transformer
-     (lambda (form r compare)
-       (let ((bindings (cadr form))
-             (body (cddr form)))
-         (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
-               (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
-           `(,(r 'let) (,@vars)
-             ,@initials
-             ,@body))))))
-
-  (define-syntax letrec
-    (er-macro-transformer
-     (lambda (form rename compare)
-       `(,(rename 'letrec*) ,@(cdr form)))))
-
-  (define-syntax do
-    (er-macro-transformer
-     (lambda (form r compare)
-       (let ((bindings (car (cdr form)))
-             (finish   (car (cdr (cdr form))))
-             (body     (cdr (cdr (cdr form)))))
-         `(,(r 'let) ,(r 'loop) ,(map (lambda (x)
-                                        (list (car x) (cadr x)))
-                                      bindings)
-           (,(r 'if) ,(car finish)
-            (,(r 'begin) ,@(cdr finish))
-            (,(r 'begin) ,@body
-             (,(r 'loop) ,@(map (lambda (x)
-                                  (if (null? (cddr x))
-                                      (car x)
-                                      (car (cddr x))))
-                                bindings)))))))))
-
-  (define-syntax when
-    (er-macro-transformer
-     (lambda (expr rename compare)
-       (let ((test (cadr expr))
-             (body (cddr expr)))
-         `(,(rename 'if) ,test
-              (,(rename 'begin) ,@body)
-              #f)))))
-
-  (define-syntax unless
-    (er-macro-transformer
-     (lambda (expr rename compare)
-       (let ((test (cadr expr))
-             (body (cddr expr)))
-         `(,(rename 'if) ,test
-              #f
-              (,(rename 'begin) ,@body))))))
-
-  (define-syntax case
-    (er-macro-transformer
-     (lambda (expr r compare)
-       (let ((key (cadr expr))
-             (clauses (cddr expr)))
-         `(,(r 'let) ((,(r 'key) ,key))
-            ,(let loop ((clauses clauses))
-               (if (null? clauses)
-                   #f
-                   (begin
-                     (define clause (car clauses))
-                     `(,(r 'if) ,(if (compare (r 'else) (car clause))
-                                     '#t
-                                     `(,(r 'or)
-                                       ,@(map (lambda (x)
-                                                `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
-                                              (car clause))))
-                       ,(if (compare (r '=>) (list-ref clause 1))
-                            `(,(list-ref clause 2) ,(r 'key))
-                            `(,(r 'begin) ,@(cdr clause)))
-                       ,(loop (cdr clauses)))))))))))
-
-  (define-syntax 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 let-syntax
-    (er-macro-transformer
-     (lambda (form r c)
-       `(,(r 'letrec-syntax) ,@(cdr form)))))
-
   (import (scheme file))
 
   (define-syntax include