Add basic R6RS library support and (rnrs base) library

lib/meta-7.scm

@@ -355,6 +355,71 @@
 (define-syntax define-library define-library-transformer)
 (define-syntax module define-library-transformer)
 
+(define r6rs-library-transformer
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (symbolic-id=? id_1 id_2)
+       (eq? (strip-syntactic-closures id_1)
+            (strip-syntactic-closures id_2)))
+     (define (clean-up-r6rs-library-name name)
+       (define (srfi-number->exact-integer component)
+         (if (symbol? component)
+             (let* ((symbol-name (symbol->string component))
+                    (maybe-number-as-string (substring symbol-name 1)))
+               (if (and (char=? (string-ref symbol-name 0) #\:)
+                        (every char-numeric?
+                               (string->list maybe-number-as-string)))
+                   (string->number maybe-number-as-string)
+                   #f))
+             #f))
+       (apply append
+              (map
+               (lambda (component)
+                 (cond ((list? component) ; ignore version numbers
+                        '())
+                       ((srfi-number->exact-integer component) => list)
+                       (else (list component))))
+               name)))
+     (define (clean-up-r6rs-import import-spec)
+       (cond ((identifier? import-spec) import-spec)
+             ((member (car import-spec)
+                      '(only except prefix rename)
+                      symbolic-id=?)
+              (cons (car import-spec)
+                    (cons (clean-up-r6rs-library-name (cadr import-spec))
+                          (cddr import-spec))))
+             ((member (car import-spec)
+                      '(library for)
+                      symbolic-id=?)
+              (clean-up-r6rs-library-name (cadr import-spec)))
+             (else (clean-up-r6rs-library-name import-spec))))
+
+     (if (not (symbolic-id=? (car expr) 'library))
+       (error "r6rs-library-transformer: I expect to process declarations called library, but this was a new one to me" (car expr) 'library))
+     (if (not (and (list? expr)
+                   (>= (length expr) 3)
+                   (list? (list-ref expr 1))
+                   (list? (list-ref expr 2))
+                   (symbolic-id=? (car (list-ref expr 2)) 'export)
+                   (list? (list-ref expr 3))
+                   (symbolic-id=? (car (list-ref expr 3)) 'import)))
+       (error "r6rs-library-transformer: the form of a library declaration is (library <name> (export <export-spec> ...) (import <import-spec> ...) <defexpr> ...)" expr))
+     (let ((library-name (clean-up-r6rs-library-name (list-ref expr 1)))
+           (exports (cdr (list-ref expr 2)))
+           (imports (map clean-up-r6rs-import (cdr (list-ref expr 3))))
+           (body (cddr (cddr expr)))
+
+           (_define-library (rename 'define-library))
+           (_export (rename 'export))
+           (_import (rename 'import))
+           (_begin (rename 'begin)))
+       `(,_define-library ,library-name
+          (,_export ,@exports)
+          (,_import ,@imports)
+          (,_begin ,@body))))))
+
+(define-syntax library r6rs-library-transformer)
+
 (define-syntax pop-this-path
   (er-macro-transformer
    (lambda (expr rename compare)

lib/rnrs/base.sld

@@ -0,0 +1,231 @@
+(library (rnrs base)
+  (export *
+          +
+          -
+          ...
+          /
+          <
+          <=
+          =
+          =>
+          >
+          >=
+          _
+          abs
+          acos
+          and
+          angle
+          append
+          apply
+          asin
+          assert
+          assertion-violation
+          atan
+          begin
+          boolean=?
+          boolean?
+          caaaar
+          caaadr
+          caaar
+          caadar
+          caaddr
+          caadr
+          caar
+          cadaar
+          cadadr
+          cadar
+          caddar
+          cadddr
+          caddr
+          cadr
+          call-with-current-continuation
+          call-with-values
+          call/cc
+          car
+          case
+          cdaaar
+          cdaadr
+          cdaar
+          cdadar
+          cdaddr
+          cdadr
+          cdar
+          cddaar
+          cddadr
+          cddar
+          cdddar
+          cddddr
+          cdddr
+          cddr
+          cdr
+          ceiling
+          char->integer
+          char<=?
+          char<?
+          char=?
+          char>=?
+          char>?
+          char?
+          complex?
+          cond
+          cons
+          cos
+          define
+          define-syntax
+          denominator
+          div
+          div-and-mod
+          div0
+          div0-and-mod0
+          dynamic-wind
+          else
+          eq?
+          equal?
+          eqv?
+          error
+          even?
+          exact
+          exact-integer-sqrt
+          exact?
+          exp
+          expt
+          finite?
+          floor
+          for-each
+          gcd
+          identifier-syntax
+          if
+          imag-part
+          inexact
+          inexact?
+          infinite?
+          integer->char
+          integer-valued?
+          integer?
+          lambda
+          lcm
+          length
+          let
+          let*
+          let*-values
+          let-syntax
+          let-values
+          letrec
+          letrec*
+          letrec-syntax
+          list
+          list->string
+          list->vector
+          list-ref
+          list-tail
+          list?
+          log
+          magnitude
+          make-polar
+          make-rectangular
+          make-string
+          make-vector
+          map
+          max
+          min
+          mod
+          mod0
+          nan?
+          negative?
+          not
+          null?
+          number->string
+          number?
+          numerator
+          odd?
+          or
+          pair?
+          positive?
+          procedure?
+          quasiquote
+          quote
+          rational-valued?
+          rational?
+          rationalize
+          real-part
+          real-valued?
+          real?
+          reverse
+          round
+          set!
+          sin
+          sqrt
+          string
+          string->list
+          string->number
+          string->symbol
+          string-append
+          string-copy
+          string-for-each
+          string-length
+          string-ref
+          string<=?
+          string<?
+          string=?
+          string>=?
+          string>?
+          string?
+          substring
+          symbol->string
+          symbol=?
+          symbol?
+          syntax-rules
+          tan
+          truncate
+          unquote
+          unquote-splicing
+          values
+          vector
+          vector->list
+          vector-fill!
+          vector-for-each
+          vector-length
+          vector-map
+          vector-ref
+          vector-set!
+          vector?
+          zero?)
+  (import (rename (scheme base)
+                  (error r7rs:error))
+          (scheme cxr)
+          (scheme inexact)
+          (scheme complex)
+          (rename (srfi 141)
+                  (euclidean-quotient div)
+                  (euclidean-remainder mod)
+                  (euclidean/ div-and-mod)
+                  (balanced-quotient div0)
+                  (balanced-remainder mod0)
+                  (balanced/ div0-and-mod0))
+          (except (chibi ast) error)
+          (chibi show))
+
+  (define-syntax assert
+    (syntax-rules ()
+      ((_ expr)
+         (if (not expr)
+             (assertion-violation #f "assertion failed" (quote expr))))))
+
+  ;; for now, errors and assertion violations are the same until we
+  ;; work out what to do about SRFI 35/(rnrs conditions) support
+  (define (error who message . irritants)
+    (define full-message
+      (if who
+          (show #f (written who) ": " message)
+          message))
+    (apply r7rs:error full-message irritants))
+  (define assertion-violation error)
+
+  (define (real-valued? n) (zero? (imag-part n)))
+  (define (rational-valued? n)
+    (and (real-valued? n)
+         (not (nan? n))
+         (not (infinite? n))))
+  (define (integer-valued? n)
+    (and (rational-valued? n)
+         (integer? (real-part n)))))