diff --git a/lib/meta-7.scm b/lib/meta-7.scm index 2851bdf1..2f6dea68 100644 --- a/lib/meta-7.scm +++ b/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 (export ...) (import ...) ...)" 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) diff --git a/lib/rnrs/base.sld b/lib/rnrs/base.sld new file mode 100644 index 00000000..d092d8ce --- /dev/null +++ b/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? + 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? + 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)))))