[Initial Commit atsmyles@earthlink.net**20080503205457] addfile ./compat-gambit.scm hunk ./compat-gambit.scm 1 +;;;=============================================================================== +;;; +;;; Gambit compatibility file: +;;; +;;; Uncomment the appropriate LOAD command in macros-core.scm +;;; +;;; Most written by Arthur T Smyles. Derived from compat-r5rs.scm +;;;=============================================================================== + +;; A numeric string that uniquely identifies this run in the universe + +(define (ex:unique-token) + (number->string (inexact->exact (floor (time->seconds (current-time)))))) + +;; The letrec black hole and corresponding setter. + +(define ex:undefined #!void) +(define ex:undefined-set! 'set!) + +;; Single-character symbol prefixes. +;; No builtins may start with one of these. +;; If they do, select different values here. + +(define ex:guid-prefix "&") +(define ex:free-prefix "~") + +;; Just give this damn thing a binding + + ; (lambda args (apply error 'assertion-violation args))) + +;(define pretty-print write) + +;; These are only partial implementations for specific use cases needed. +;; Full implementations should be provided by host implementation. + +(define (memp proc ls) + (cond ((null? ls) #f) + ((pair? ls) (if (proc (car ls)) + ls + (memp proc (cdr ls)))) + (else (assertion-violation 'memp "Invalid argument" ls)))) + +(define (filter p? lst) + (if (null? lst) + '() + (if (p? (car lst)) + (cons (car lst) + (filter p? (cdr lst))) + (filter p? (cdr lst))))) + +(define (for-all proc l . ls) + (or (null? l) + (and (apply proc (car l) (map car ls)) + (apply for-all proc (cdr l) (map cdr ls))))) + +;; The best we can do in r5rs is make these no-ops +; gambit already defines these +;(define (file-exists? fn) #f) +;(define (delete-file fn) (values)) + +(define (make-record-type-descriptor name parent uid sealed? opaque? fields) + (define (parse-fields fields) + (let* ((field-count (vector-length fields)) + (result (make-vector (* field-count 3)))) + (let process-fields ((i 0)) + (if (not (< i field-count)) result + ;gambit has other attributes of fields such as if they are printable and it's contribution to equality + (let* ((field (vector-ref fields i)) + (mutable? (if (eq? 'mutable (car field)) 0 2)) + (field-name (cadr field)) + (j (* i 3))) + (vector-set! result j field-name) + (vector-set! result (+ j 1) mutable?) + (vector-set! result (+ j 2) #f); used for setting initial value + (process-fields (+ i 1))))))) + + + (let* ((flags (##fixnum.+ (if opaque? 1 0) (if sealed? 0 2))) + (uid (if uid uid (make-uninterned-symbol (symbol->string name))))) + + (##structure ##type-type uid name flags parent (parse-fields fields)))) + +(define record-type-descriptor? ##type?) +(define (record-type-name rtd) (if (record-type-descriptor? rtd) (##type-name rtd))) +(define (record-type-parent rtd) (if (record-type-descriptor? rtd) (##type-parent rtd))) +(define (record-type-uid rtd) (if (record-type-descriptor? rtd) (##type-id rtd))) +(define (record-type-sealed? rtd) (not (fxbit-set? (##type-flags rtd) 1))) +(define (record-type-opaque? rtd) (fxbit-set? (##type-flags rtd) 0)) +(define (record-type-generative? rtd) (uninterned-symbol? (record-type-uid rtd))) + +(define (record-type-field-names rtd) + (let* ((fields (##type-fields rtd)) + (field-count (/ (vector-length fields) 3)) + (result (make-vector field-count))) + (loop process-field-names ((i 0)) + (if (< i result-length) + (begin + (vector-set! result i (vector-ref fields (* i 3))) + (process-field-names (+ i 1))) + result)))) + + +(define (record-field-mutable? rtd k) + (if (record-type-descriptor? rtd) + (cond + ;k doesn't need to be incremented in this case + ((integer? k) (fxbit-set? (vector-ref (##type-fields rtd) (+ (* k 3) 1)) 1)) + ((symbol? k) + ((names (record-type-field-names rtd)) + (n (memq n names)) + (if n (record-field-mutable? rtd (- (length names) (length n))))))))) + + + +(define-record-type record-constructor-descriptor + (make-record-constructor-descriptor rtd parent-constructor-descriptor protocol) + record-constructor-descriptor? + (rtd record-constructor-rtd) + (parent-constructor-descriptor record-constructor-parent) + (protocol record-constructor-protocol)) + + +;TODO This needs work to fully follow spec +(define (record-constructor rtc) + (define (make-record-constructor rtd pcd protocol) + (cond + ((and pcd protocol) (error "don't know how to deal with that yet")) + (pcd (error "currently can't handle parent-constructor-descriptors")) + (protocol (protocol (make-record-constructor rtd #f #f))) + (else (lambda fields (apply ##structure rtd fields))))) + (if (record-type-descriptor? rtc) (make-record-constructor rtc #f #f) + (make-record-constructor (record-constructor-rtd rtc) + (record-constructor-parent rtc) + (record-constructor-protocol rtc)))) + + +(define (record-predicate rtd) + (let ((uid (record-type-uid rtd))) + (if (record-type-sealed? rtd) + (lambda (obj) (##structure-direct-instance-of? obj uid)) + (lambda (obj) (##structure-instance-of? obj uid))))) + + +(define (record-accessor rtd k) + (cond + ((integer? k) + (let ((k (+ k 1))) + (if (record-type-sealed? rtd) + (lambda (obj) (##structure-direct-ref obj k rtd #f)) + (lambda (obj) (##structure-ref obj k rtd #f))))) + ((symbol? k) + ((names (record-type-field-names rtd)) + (n (memq n names)) + (if n (record-accessor rtd (- (length names) (length n)))))))) + + +(define (record-mutator rtd k) + (if (record-field-mutable? rtd k) + (cond + ((integer? k) + (let ((k (+ k 1))) + (if (record-type-sealed? rtd) + (lambda (obj value) (##structure-direct-set! obj value k rtd #f)) + (lambda (obj value) (##structure-set! obj value k rtd #f))))) + ((symbol? k) + (let* ((names (record-type-field-names rtd)) + (n (memq n names))) + (if n (record-mutator rtd (- (length names) (length n))))))))) + + +(define (record? obj) + (and (structure? obj) (not (record-type-opaque? (##structure-type obj))))) + +(define (record-rtd obj) + (if (record? obj) (##structure-type obj) + ;TODO raise exception + )) + +;extra, used by code outside of r6rs +;procdural creation of conditions. the fields is just a list of fields. name and parent are the same as +;make-record-type-descriptor + +(define (make-condition-type name parent fields) + (make-record-type-descriptor name parent #f #f #f (list->vector (map (lambda (x) (list 'immutable x)) + (vector->list fields))))) + +;used to create your own simple conditions +(define &condition (make-condition-type '&condition #f '#())) +(define &compound (make-condition-type '&compound &condition '#(conditions))) +(define &serious (make-condition-type '&serious &condition '#())) +(define &violation (make-condition-type '&violation &serious '#())) +(define &assertion (make-condition-type '&assertion &violation '#())) +(define &who (make-condition-type '&who &condition '#(who))) +(define &message (make-condition-type '&message &condition '#(message))) +(define &irritants (make-condition-type '&irritants &condition '#(irritants))) +(define &syntax (make-condition-type '&syntax &violation '#(form subform))) +(define &trace (make-condition-type '&trace &condition '#(trace))) + +;need to define raise for your implementation + +(define condition + (let ((constructor (record-constructor &compound))) + (lambda conditions + (cond + ((and (pair? conditions) (null? (cdr conditions))) (car conditions)) + (else (constructor conditions)))))) + +(define (simple-conditions condition) + (let ((compound? (record-predicate &compound)) + (conditions (record-accessor &compound 0))) + (lambda (condition) + (cond + ((compound? condition) (conditions condition)) + (else (list condition)))))) + +(define make-who-condition (record-constructor &who)) +(define make-message-condition (record-constructor &message)) +(define make-irritants-condition (record-constructor &irritants)) +(define make-syntax-violation (record-constructor &syntax)) +;constructors for conditions with no fields are treated like singletons +(define make-assertion-violation + (let ((assertion-violation ((record-constructor &assertion)))) + (lambda () assertion-violation))) + +(define (assertion-violation who message . irritants) + (raise + (if who + (condition (make-who-condition who) + (make-message-condition message) + (make-irritants-condition irritants) + (make-assertion-violation)) + (condition (make-message-condition message) + (make-irritants-condition irritants) + (make-assertion-violation))))) addfile ./compile hunk ./compile 1 +#!/usr/bin/env gsi +; vim: syntax=scheme +(load "/usr/lib/syntax-case") +;directories +(define tmp-dir (string-append "/tmp/r6rs-expand-" (number->string (inexact->exact (floor (time->seconds (current-time))))))) +;prefix is just the directory it's under. +(define gambit-libraries-prefix "gambit") +(define srfi-libraries-prefix "srfi") +(define standard-libraries-prefix "rnrs") +(define misc-libraries-prefix "") +(define gambit-compiler "gambit-compiler") +(define result-path "~/.gambit/lib") + +(define (display* . args) + (for-each (lambda (x) (display x)) args) + (newline)) + +(define (path-expand* dir . files) + (map (lambda (x) (path-expand x dir)) files)) + +(define gambit-libraries + (path-expand* "libs/gambit/" "io.readtable.scm" "io.scm" "threads.scm" "time.scm" "will.scm" "exceptions.scm" "files.scm" "programs.scm" "extensions.scm" "bytevectors.scm" "debug.scm")) + +(define srfi-libraries + (path-expand* "libs/srfi/" "srfi-0.scm" "srfi-2.scm" "srfi-21.scm" "srfi-18.scm" "srfi-23.scm" "srfi-27.scm" "srfi-39.scm" "srfi-4.scm" "srfi-6.scm" "srfi-8.scm" "srfi-88.scm" "srfi-89.scm" "srfi-9.scm")) + +(define standard-libraries-base (path-expand* "libs/rnrs/" "core.scm" "exceptions.scm" "records.scm" "conditions.scm" "base.scm")) + +(define standard-libraries + (path-expand* "libs/rnrs/" "syntax-case.scm" "control.scm" "arithmetic.scm" "bytevectors.scm" "io.scm" "unicode.scm" "files.scm" "lists.scm" "sorting.scm" "programs.scm" "rnrs.scm" "mutable.scm" "eval.scm" "r5rs.scm" "load.scm")) + +(define misc-libraries (path-expand* "libs/" "r5rs.scm" "ieee.scm" "renaming.scm")) + + + +(define (expand-all files from-dir prefix to-dir) + (let ((to-files (map (lambda (x) (path-expand (string-append prefix "-" x) to-dir)) files)) + (from-files (map (lambda (x) (path-expand x from-dir)) files))) + (for-each ex:expand-file from-files to-files) + to-files)) + +(create-directory tmp-dir) +(display* "generating r6rs. This may take a while. Coffee break!") +(load "compat-gambit.scm") +(load "runtime.scm") +(load "expander.scm") +(let ((libraries-file (path-expand "libraries.exp" tmp-dir)) + (expander-file (path-expand "expander.exp" tmp-dir)) + (result-file (path-expand "r6rs.exp" tmp-dir)) + (files->string (lambda (files) (apply string-append + (map (lambda (file) (string-append file " ")) files))))) + (display* "expanding libraries") + (apply ex:expand-file* libraries-file (append gambit-libraries standard-libraries-base standard-libraries srfi-libraries misc-libraries)) + (display* "expanding expander") + (ex:expand-r5rs-file "expander.scm" expander-file (ex:environment '(rnrs base))) + + (display* "cat all these files together") + (shell-command (string-append "cat " + (path-expand "compat-gambit.scm") " " + (path-expand "runtime.scm") " " + libraries-file " " + expander-file " " + "> " result-file)) + + (display* "now compile with gsc") + (shell-command (string-append gambit-compiler " " result-file)) + (rename-file (path-expand "r6rs.o1" tmp-dir) (path-expand "r6rs.o1" result-path)) + (for-each (lambda (file) (delete-file (path-expand file tmp-dir))) + (directory-files tmp-dir)) + (delete-directory tmp-dir) +) +(display* "done") + addfile ./expander.scm hunk ./expander.scm 1 + + +;;;================================================================================= +;;; +;;; R6RS Macros and R6RS libraries: +;;; +;;; Copyright (c) 2006 Andre van Tonder +;;; +;;; Copyright statement at http://srfi.schemers.org/srfi-process.html +;;; +;;;================================================================================= +;;; +;;;================================================================================= +;;; +;;; PORTING COMMENTS: +;;; +;;;================================================================================= +;;; +;;; The file compat-*.scm has to be loaded before loading this expander. +;;; +;;; Compat-*.scm should supply whatever is missing from your implementation of +;;; the following. +;;; +;;; NOTE: A purely r5rs approximation is provided that can be used +;;; as a customization template. +;;; +;;; - Procedures assertion-violation, memp, filter, for-all, pretty-print, +;;; file-exists? and delete-file. +;;; - Procedures make-record-type-descriptor, make-record-constructor-descriptor, +;;; record-constructor, record-predicate and record-accessor. +;;; - Procedure (ex:unique-token) that provides a numeric GUID string once per run. +;;; - Single-character string ex:guid-prefix. No builtin may start with this. +;;; - Single-character string ex:free-prefix. No builtin may start with this. +;;; - Value ex:undefined representing the letrec black hole value. +;;; - Symbol ex:undefined-set! representing the corresponding setter. +;;; +;;; HOOKS: +;;; ------ +;;; +;;; For compiler and REPL integration, see the procedures +;;; +;;; - ex:repl : Use this as REPL evaluator. See description below. +;;; - ex:expand-file : Use this to expand a file containing libraries and/or +;;; toplevel programs before loading into an r5rs-type system +;;; or feeding result to an r5rs-type compiler. +;;; Suitable for separate compilation. +;;; - ex:run-r6rs-sequence : Evaluates a sequence of forms of the format +;;; * | * . +;;; The environment is separate from the +;;; interactive REPL environment and does not persist +;;; between invocations of run-r6rs-sequence. +;;; For importing and evaluating stuff in the persistent +;;; interactive environment, ex:REPL should be used instead. +;;; - ex:run-r6rs-program : Same as ex:run-r6rs-sequence, except that it reads the +;;; input from a file. +;;; - ex:expand-r5rs-file : For expanding r5rs-like toplevel files in a given environment. +;;; Mainly provided so this expander can expand itself, but may +;;; have other uses. See the documentation below where the +;;; procedure is defined. See also the note below on +;;; metacircularity. +;;; +;;; COMPILATION: +;;; ------------ +;;; +;;; Example compilation scripts can be seen in examples.scm. +;;; The expander expands everything to r5rs toplevel definitions +;;; and expressions, so the expanded code should be compilable +;;; with an r5rs compiler. +;;; +;;; REPL: +;;; ----- +;;; +;;; Example REPL interaction can be seen in examples.scm. +;;; +;;; The REPL goes beyond r6rs to allow incremental development in +;;; a toplevel environment. +;;; The developer can freely change, replace and make new toplevel +;;; definitions, evaluate toplevel expressions, enter libraries and +;;; at the prompt, as well as import libraries +;;; into the toplevel environment. +;;; +;;; EX:REPL evaluates a sequence of library definitions, commands, and top-level +;;; import forms in the interactive environment. The semantics for +;;; evaluating libraries in and importing bindings into the interactive +;;; environment is consistent with the ERR5RS proposal at +;;; http://scheme-punks.cyber-rush.org/wiki/index.php?title=ERR5RS:Libraries. +;;; Bindings in the interactive environment persist between invocations +;;; of REPL. +;;; +;;; An example session where I do all these things is in examples.scm. +;;; All an integrator would need to do is to automate the call to +;;; ex:repl in the development system so users don't have to type +;;; (ex:repl '( )) at each prompt. +;;; +;;; FORMAT OF EXPANDED CODE: +;;; ------------------------ +;;; +;;; We expand internal and library definitions, as well as letrec and letrec* +;;; completely to lambda and set! (or more accurately, whatever ex:undefined-set! +;;; is set to). This seems to be the preferred input format for Larceny. +;;; It would be very easy to abstract or change, but we don't bother for now +;;; until implementors other than Larceny show a serious interest. +;;; +;;; METACIRCULARITY AND BOOTSTRAPPING: +;;; ---------------------------------- +;;; +;;; This section is mostly of interest for r5rs non-compliant systems. +;;; +;;; The expander relies on r5rs (or r6rs) syntax-rules and letrec-syntax +;;; and should run in a correct r5rs system, but if you don't have +;;; r5rs macros, you may bootstrap it by expanding the expander itself +;;; first on an R5RS system. +;;; Here is how to do it: +;;; +;;; (load "compat-mzscheme.scm") ; for example bootstrapping from mzscheme +;;; (load "runtime.scm") +;;; (load "expander.scm") +;;; (ex:expand-file "standard-libraries.scm" "standard-libraries.exp") +;;; (ex:expand-r5rs-file "expander.scm" "expander.exp" (ex:environment '(rnrs base))) +;;; +;;; The expanded (.exp) files are vanilla Scheme and can then be run on the target +;;; system as follows: +;;; +;;; (load "compat-chez.scm") ; for example +;;; (load "runtime.scm") +;;; (load "standard-libraries.exp") +;;; (load "expander.exp") +;;; +;;; SIZE OF OBJECT CODE: +;;; -------------------- +;;; +;;; The minimal runtime prerequisites has been separated into a small +;;; include file runtime.scm, which is all that needs to be present for +;;; executing an expanded program that does not contain runtime +;;; uses the exports of (rnrs syntax-case) or (rnrs eval). +;;; See examples.scm for demonstrations of this. +;;; +;;; Expanded libraries may contain identifier environment information +;;; and visit code that could adversely affect the runtime binary size. +;;; This is not a big problem, for several reasons: +;;; First, note that this information is only present in libraries that +;;; define macros. +;;; Second, the size of the environments saved in the object code can +;;; usually be reduced dramatically by using 'only' imports. +;;; Third, the environments, as well as the visit code, can be discarded +;;; completely from the runtime image of a fully expanded program not +;;; using (rnrs syntax-case) or (rnrs eval) at runtime. It is very +;;; easy to write a little build script that does this. +;;; +;;; The only reason for including this information now in the object code +;;; of a library is to support separate compilation, so one can expand a +;;; library in one session and use macros from the /expanded/ library to +;;; expand another library or program in a new session. The customization +;;; to get rid of separate compilation, if desired, would be trivial. + +;;================================================================================= +;; +;; IMPORTS: +;; +;;================================================================================= +;; +;; The include file runtime.scm has to be loaded before loading this expander +;; +;;================================================================================= +;; +;; EXPORTS: +;; +;;================================================================================= + +;; Direct exports: + +(define ex:make-variable-transformer #f) +(define ex:identifier? #f) +(define ex:bound-identifier=? #f) +(define ex:free-identifier=? #f) +(define ex:generate-temporaries #f) +(define ex:datum->syntax #f) +(define ex:syntax->datum #f) +(define ex:environment #f) +(define ex:environment-bindings #f) +(define ex:eval #f) +(define ex:syntax-violation #f) + +;; System exports: + +(define ex:expand-file #f) +;;;ATS added this +(define ex:expand-file* #f) +(define ex:repl #f) +(define ex:expand-r5rs-file #f) +(define ex:run-r6rs-sequence #f) +(define ex:run-r6rs-program #f) + +;; Indirect exports: + +(define ex:invalid-form #f) +(define ex:register-macro! #f) +(define ex:syntax-rename #f) +(define ex:map-while #f) +(define ex:dotted-length #f) +(define ex:dotted-butlast #f) +(define ex:dotted-last #f) +(define ex:uncompress #f) +(define ex:free=? #f) + +(letrec-syntax + ;; Not everyone has the same parameter API: + + ((fluid-let + (syntax-rules () + ((fluid-let () be ...) + (begin be ...)) + ((fluid-let ((p0 e0) (p e) ...) be ...) + (let ((saved p0)) + (set! p0 e0) + (call-with-values (lambda () + (fluid-let ((p e) ...) be ...)) + (lambda results + (set! p0 saved) + (apply values results))))))) + + ;; A trivial but extremely useful s-expression matcher. + ;; Implements a subset of Wright's matcher's patterns. + ;; Includes additional (syntax id) pattern that matches + ;; if input is identifier? and free=? to 'id. + + (match + (syntax-rules () + ((match (op arg ...) clause ...) + (let ((x (op arg ...))) + (match x clause ...))) + ((match x) + (ex:invalid-form x)) + ((match x (pat e ...) clause ...) + (matcher "base" pat "done" x (e ...) (lambda () (match x clause ...)))))) + + (matcher + (syntax-rules (- ___ ? syntax) + ((matcher "base" () k arg ...) + (matcher k (lambda (x sk fk) (if (null? x) (sk) (fk))) () arg ...)) + ((matcher "base" - k arg ...) + (matcher k (lambda (x sk fk) (sk)) () arg ...)) + ((matcher "base" (syntax id) k arg ...) + (matcher k + (lambda (x sk fk) + (if (ex:free=? x 'id) (sk) (fk))) + () + arg ...)) + ((matcher "base" (? pred? p) k arg ...) + (matcher "base" p "predicate" pred? k arg ...)) + ((matcher "predicate" code vars pred? k arg ...) + (matcher k + (lambda (x sk fk) + (if (pred? x) + (code x sk fk) + (fk))) + vars + arg ...)) + ((matcher "base" (p1 ___ tailp ...) k arg ...) + (matcher "base" p1 "ellipses" (tailp ...) k arg ...)) + ((matcher "ellipses" code vars (tailp ...) k arg ...) + (matcher k + (lambda (x sk fk) + (let loop ((x x) + (result '())) + (define (match-tail) + (match x + ((tailp ...) + (apply sk (if (null? result) + (map (lambda (ignore) '()) 'vars) + (apply map list (reverse result))))) + (- (fk)))) + (cond ((null? x) (match-tail)) + ((pair? x) + (code (car x) + (lambda car-vars + (loop (cdr x) (cons car-vars result))) + match-tail)) + (else (fk))))) + vars + arg ...)) + ((matcher "base" (p1 . p2) k arg ...) + (matcher "base" p1 "pair" p2 k arg ...)) + ((matcher "pair" car-code car-vars p2 k arg ...) + (matcher "base" p2 "pair-done" car-code car-vars k arg ...)) + ((matcher "pair-done" cdr-code (cdr-var ...) car-code (car-var ...) k arg ...) + (matcher k + (lambda (x sk fk) + (if (pair? x) + (car-code (car x) + (lambda (car-var ...) + (cdr-code (cdr x) + (lambda (cdr-var ...) + (sk car-var ... cdr-var ...)) + fk)) + fk) + (fk))) + (car-var ... cdr-var ...) + arg ...)) + ((matcher "base" #(p ___) k arg ...) + (matcher "base" (p ___) "vector" k arg ...)) + ((matcher "vector" list-code vars k arg ...) + (matcher k + (lambda (x sk fk) + (if (vector? x) + (list-code (vector->list x) + sk + fk) + (fk))) + vars + arg ...)) + ((matcher "base" id k arg ...) + (matcher k (lambda (x sk fk) (sk x)) (id) arg ...)) + ((matcher "done" code vars x (e ...) fk) + (code x (lambda vars e ...) fk))))) + + (let* (;;========================================================================== + ;; + ;; Dynamic parameters: + ;; + ;;========================================================================== + + ;; toplevel REPL bindings to be initialized later + (*toplevel-env* #f) + ;; current lexical environment to be initialized later + (*usage-env* #f) + ;; current phase + (*phase* 0) + ;; current color for painting identifiers upon renaming to be initialized + (*color* #f) + ;; global table mapping of keyword to object + (*macro-table* '()) + ;; maps of reflected environment to actual + (*env-table* '()) + ;; current library name as list of symbols or '() for toplevel + (*current-library* '()) + ;; car of this records bindings already referenced in current body + ;; for detecting when later definitions may violate lexical scope + (*used* (list '())) + ;; history trace for error reporting + (*trace* '()) + ;; whether expanded library introduces identifiers via syntax + ;; expressions - if not, save lots of space by not including + ;; env-table in object code + (*syntax-reflected* #f) + + ;;========================================================================== + ;; + ;; Identifiers: + ;; + ;;========================================================================== + + ;; ::= + ;; ::= ( ...) + ;; ::= ( ...) + ;; ::= + ;; ::= ( ...) | #f + ;; + ;; where + ;; : The symbolic name of the identifier in the source. + ;; : Each time an introduced identifier is renamed, a fresh + ;; color gets prepended to its . + ;; : List of reflected transformer environments. + ;; The environment (env-reify (car )) was the + ;; usage environment valid during expansion of any (syntax id) + ;; expression whose evaluation introduced this identifier, while + ;; (cdr ) are in turn the reflected + ;; of the original id. + ;; : Integer that keeps track of shifts in phases + ;; between transformer and usage sites of identifier. + ;; : Library name if identifier was introduced by evaluation of + ;; a (syntax ...) expression, otherwise #f. + ;; The empty name '() is used for toplevel. + + (:identifier + (make-record-type-descriptor 'identifier #f #f #f #f + '#((immutable name) + (immutable colors) + (immutable transformer-envs) + (immutable displacement) + (immutable maybe-library)))) + (make-identifier + (record-constructor (make-record-constructor-descriptor :identifier #f #f)))) + + ;; We sequenced stuff in the let* above because r5rs internal + ;; definitions use letrec semantics and cannot be used for sequencing. + + (define identifier? (record-predicate :identifier)) + (define id-name (record-accessor :identifier 0)) + (define id-colors (record-accessor :identifier 1)) + (define id-transformer-envs (record-accessor :identifier 2)) + (define id-displacement (record-accessor :identifier 3)) + (define id-maybe-library (record-accessor :identifier 4)) + + + (define (id-library id) + (or (id-maybe-library id) + *current-library*)) + + (define (bound-identifier=? x y) + (check x identifier? 'bound-identifier=?) + (check y identifier? 'bound-identifier=?) + (and (eq? (id-name x) + (id-name y)) + (equal? (id-colors x) + (id-colors y)))) + + ;; As required by r6rs, when this returns, the result is #t + ;; if and only if the two identifiers resolve to the same binding. + ;; It also treats unbound identifiers specially. + ;; As allowed by R6RS, included phase checking of arguments. + ;; An out of phase error is raised if the comparison succeeds but + ;; either argument is out of phase. This is sufficient to ensure + ;; that literals such as ... in syntax-case are used in the correct phase. + ;; For more dicussion on this choice, see the readme and the examples file. + + (define (free-identifier=? x y) + (check x identifier? 'free-identifier=?) + (check y identifier? 'free-identifier=?) + (let ((bx (binding x)) + (by (binding y))) + (let ((result (if bx + (and by + (eq? (binding-name bx) + (binding-name by))) + (and (not by) + (eq? (id-name x) + (id-name y)))))) + (and result + bx + (begin (check-binding-level x bx) + (check-binding-level y by))) + ;; A later definition in the same body can only change + ;; #t to #f, so only record usage in that case. + (and result + (register-use! x bx) + (register-use! y by)) + result))) + + ;; For internal use + + (define (free=? x symbol) + (and (identifier? x) + (let ((bx (binding x))) + (let ((result + (and bx + (eq? (binding-name bx) symbol)))) + (and result + bx + (check-binding-level x bx)) + (and result + (register-use! x bx)) + result)))) + + ;;========================================================================== + ;; + ;; Infrastructure for generated names: + ;; + ;;========================================================================== + + ;; Generate-guid returns a fresh symbol that has a globally + ;; unique external representation and is read-write invariant. + ;; Your local gensym will probably not satisfy both conditions. + ;; Prefix makes it disjoint from all builtins. + ;; Uniqueness is important for incremental and separate expansion. + + (define generate-guid + (let ((token (ex:unique-token)) + (ticks 0)) + (lambda (symbol) + (set! ticks (+ ticks 1)) + (string->symbol + (string-append ex:guid-prefix + (symbol->string symbol) + "~" + token + "~" + (number->string ticks)))))) + + ;; Used to generate user program toplevel names. + ;; Prefix makes it disjoint from all builtins. + ;; Prefix makes it disjoint from output of generate-guid. + ;; Must be read-write invariant. + + (define (make-free-name symbol) + (string->symbol (string-append ex:free-prefix (symbol->string symbol)))) + + ;;========================================================================= + ;; + ;; Colors to paint identifiers with: + ;; + ;;========================================================================= + + ;; Returns ::= globally unique symbol + + (define (generate-color) + (generate-guid 'c)) + + ;;========================================================================= + ;; + ;; Bindings: + ;; + ;;========================================================================= + + ;; ::= (variable ( ...) ) + ;; | (macro ( ...) #f ) + ;; | (pattern-variable ( ...) ) + ;; | #f (out of context binding from another library) + ;; ::= #t | #f + ;; ::= 0 | 1 | 2 | ... + ;; ::= uniquely identifying binding. + ;; is used for free-identifier=? comparison. + ;; For variable and pattern variable bindings, it is the same + ;; as the symbol emitted for the binding in the object code. + ;; For macro bindings, it is the key for looking up the transformer + ;; in the global macro table. + + (define (make-binding type name levels content library) + (list type name levels content library)) + + (define (binding-type b) (car b)) + (define (binding-name b) (cadr b)) + (define (binding-levels b) (caddr b)) + (define (binding-mutable? b) (cadddr b)) + (define (binding-dimension b) (cadddr b)) + (define (binding-library b) (car (cddddr b))) + (define (binding-mutable-set! b x) (set-car! (cdddr b) x)) + + ;; Looks up binding first in usage environment and + ;; then in attached transformer environments. + ;; Toplevel forward references are treated specially. + ;; Returns | #f if unbound. + + (define (binding id) + (let ((name (id-name id))) + (let loop ((env *usage-env*) + (envs (id-transformer-envs id)) + (colors (id-colors id))) + (or (env-lookup (cons name colors) env) + (and (pair? envs) + (loop (env-reify (car envs)) + (cdr envs) + (cdr colors))))))) + + ;;========================================================================= + ;; + ;; Mapping in environment: (( ...) . ) + ;; + ;;========================================================================= + + ;; Generates a local mapping at the current meta-level + ;; that can be added to the usage environment. + + (define (make-local-mapping type id content) + (cons (cons (id-name id) + (id-colors id)) + (make-binding type + (generate-guid (id-name id)) + (list (source-level id)) + content + *current-library*))) + + ;; Toplevel binding forms use as binding name the free name + ;; so that source-level forward references will work in REPL. + ;; If identifier is macro-generated, bind it with a fresh name. + ;; This ensures that generated toplevel defines are not visible + ;; from toplevel source code, thus approximating the behaviour + ;; of generated internal definitions. + + (define (make-toplevel-mapping type id content) + (if (null? (id-colors id)) + (cons (cons (id-name id) + (id-colors id)) + (make-binding type + (make-free-name (id-name id)) + '(0) + content + *current-library*)) + (make-local-mapping type id content))) + + ;;========================================================================= + ;; + ;; Infrastructure for binding levels: + ;; + ;;========================================================================= + + (define (source-level id) + (- *phase* (id-displacement id))) + + (define (check-binding-level id binding) + (if binding + (or (memv (source-level id) + (binding-levels binding)) + (syntax-violation + "invalid reference" + (string-append "Attempt to use binding of " (symbol->string (id-name id)) + " in library (" (list->string (id-library id) " ") + ") at invalid level " (number->string (source-level id)) + ". Binding is only available at levels: " + (list->string (binding-levels binding) " ")) + id)) + (or (and (null? (id-library id)) + (= *phase* 0)) + (syntax-violation + "invalid reference" + (string-append "No binding available for " (symbol->string (id-name id)) + " in library (" (list->string (id-library id) " ") ")") + + id)))) + + ;;========================================================================= + ;; + ;; Environments: + ;; + ;;========================================================================= + + ;; An environment is a list of frames. + ;; + ;; ::= ( ...) + ;; ::= (list (( . ) ...)) + ;; + ;; Keys must be comparable with equal? and unique in each frame. + ;; Frames can be added, or the leftmost frame can be destructively + ;; updated in the case of binding constructs such as bodies where + ;; definitions are incrementally discovered. + + (define (make-null-env) '()) + (define (make-unit-env) (env-extend '() (make-null-env))) + + ;; Adds a new frame containing mappings to env. + + (define (env-extend mappings env) + (cons (list mappings) env)) + + ;; Destructively extends the leftmost frame in env. + + (define (env-extend! mappings env) + (let ((frame (car env))) + (set-car! frame (append mappings (car frame))))) + + ;; Returns | #f + + (define (env-lookup key env) + (and (pair? env) + (or (let ((probe (assoc key (caar env)))) + (and probe + (or (cdr probe) + (syntax-violation + #f "Out of context reference to identifier" (car key))))) + (env-lookup key (cdr env))))) + + ;; Is id already bound in leftmost frame? + + (define (duplicate? id env) + (assoc (cons (id-name id) + (id-colors id)) + (caar env))) + + ;; Returns a single-symbol representing an + ;; environment that can be included in object code. + + (define (env-reflect env) + (cond ((and (not (null? *env-table*)) ; +++ + (eq? env (cdar *env-table*))) ; +++ + (caar *env-table*)) ; +++ + (else + (let ((key (generate-guid 'env))) + (set! *env-table* + (cons (cons key env) + *env-table*)) + key)))) + + ;; The inverse of the above. + + (define (env-reify key-or-env) + (if (symbol? key-or-env) + (cdr (assq key-or-env *env-table*)) + key-or-env)) + + ;; This makes a much smaller external representation of an + ;; environment table by factoring shared structure. + + (define (compress env-table) + (let ((frame-table '()) + (count 0)) + (for-each (lambda (entry) + (for-each (lambda (frame) + (if (not (assq frame frame-table)) + (begin + (set! frame-table (cons (cons frame count) frame-table)) + (set! count (+ 1 count))))) + (cdr entry))) + env-table) + (cons (map (lambda (env-entry) + (cons (car env-entry) + (map (lambda (frame) + (cdr (assq frame frame-table))) + (cdr env-entry)))) + env-table) + (map (lambda (frame-entry) + (cons (cdr frame-entry) + (list (map (lambda (mapping) + (cons (car mapping) + (let ((binding (cdr mapping))) + (case (binding-type binding) + ;; Pattern variable bindings can never be + ;; used in client, so don't waste space. + ;; Should really do the same with all local + ;; bindings, but there are usually much less + ;; of them, so don't bother for now. + ((pattern-variable) #f) ; +++ + (else binding))))) + (caar frame-entry))))) + frame-table)))) + + (define (uncompress compressed-env-table) + (map (lambda (env-entry) + (cons (car env-entry) + (map (lambda (frame-abbrev) + (cdr (assv frame-abbrev (cdr compressed-env-table)))) + (cdr env-entry)))) + (car compressed-env-table))) + + ;;========================================================================= + ;; + ;; Syntax-reflect and syntax-rename: + ;; + ;; This is the basic building block of the implicit renaming mechanism for + ;; maintaining hygiene. Syntax-reflect generates the expanded code for + ;; (syntax id), including the expand-time environment in the + ;; external representation. It expands to syntax-rename, which performs + ;; the implicit renaming when this expanded code is eventually run. + ;; The displacement computations calculate the difference between the + ;; usage phase and the transformer phase. + ;; + ;;========================================================================= + + (define (syntax-reflect id) + (set! *syntax-reflected* #t) + `(ex:syntax-rename ',(id-name id) + ',(id-colors id) + ',(cons (env-reflect *usage-env*) + (id-transformer-envs id)) + ,(- (- *phase* (id-displacement id)) 1) + ',(id-library id))) + + (define (syntax-rename name colors transformer-envs transformer-phase source-library) + (make-identifier name + (cons *color* colors) + transformer-envs + (- *phase* transformer-phase) + source-library)) + + ;;===================================================================== + ;; + ;; Capture and sexp <-> syntax conversions: + ;; + ;;===================================================================== + + (define (datum->syntax tid datum) + (check tid identifier? 'datum->syntax) + (sexp-map (lambda (leaf) + (cond ((symbol? leaf) + (make-identifier leaf + (id-colors tid) + (id-transformer-envs tid) + (id-displacement tid) + (id-maybe-library tid))) + (else leaf))) + datum)) + + (define (syntax->datum exp) + (sexp-map (lambda (leaf) + (cond ((identifier? leaf) (id-name leaf)) + ((symbol? leaf) + (assertion-violation 'syntax->datum "A symbol is not a valid syntax object" leaf)) + (else leaf))) + exp)) + + ;; Fresh identifiers: + + (define (generate-temporaries ls) + (check ls list? 'generate-temporaries) + (map (lambda (ignore) + (make-identifier 'temp + (list (generate-color)) + (list (make-null-env)) + *phase* + #f)) + ls)) + + ;; For use internally as in the explicit renaming system. + + (define (rename type symbol) + (make-identifier symbol + (list *color*) + (list (env-extend + (list (cons (cons symbol '()) + (make-binding type symbol '(0) #f '()))) + (make-null-env))) + *phase* + #f)) + + ;;========================================================================= + ;; + ;; Macro objects: + ;; + ;;========================================================================= + + ;; Expanders are system macros that fully expand + ;; their arguments to core Scheme, while + ;; transformers and variable transformers are + ;; user macros. + + ;; ::= expander | transformer | variable-transformer + + (define (make-macro type proc) + (list type proc)) + (define macro-type car) + (define macro-proc cadr) + + (define (make-expander proc) (make-macro 'expander proc)) + (define (make-transformer proc) (make-macro 'transformer proc)) + (define (make-variable-transformer proc) (make-macro 'variable-transformer proc)) + + (define (make-user-macro procedure-or-macro) + (if (procedure? procedure-or-macro) + (make-transformer procedure-or-macro) + procedure-or-macro)) + + ;; Returns . + + (define (binding->macro binding t) + (cond ((assq (binding-name binding) *macro-table*) => cdr) + (else + (syntax-violation + #f "Reference to macro keyword out of context" t)))) + + ;; Registering macro. + + (define (register-macro! binding-name procedure-or-macro) + (set! *macro-table* (cons (cons binding-name (make-user-macro procedure-or-macro)) + *macro-table*))) + + ;; Calls a macro with a new color. + + (define (invoke-macro macro t) + (set! *color* (generate-color)) + ((macro-proc macro) t)) + + ;;========================================================================= + ;; + ;; Expander dispatch: + ;; + ;;========================================================================= + + (define (expand t) + (fluid-let ((*trace* (cons t *trace*))) + (let ((binding (operator-binding t))) + (cond (binding (case (binding-type binding) + ((macro) + (let ((macro (binding->macro binding t))) + (let ((expanded-once (invoke-macro macro t))) + (case (macro-type macro) + ((expander) expanded-once) + (else + (expand expanded-once)))))) + ((variable) + (check-implicit-import-of-mutable binding t) + (if (list? t) + (cons (binding-name binding) + (map expand (cdr t))) + (binding-name binding))) + ((pattern-variable) + (syntax-violation #f "Pattern variable used outside syntax template" t)))) + ((list? t) (map expand t)) + ((identifier? t) (make-free-name (id-name t))) + ((pair? t) (syntax-violation #f "Invalid procedure call syntax" t)) + ((symbol? t) (syntax-violation #f "Symbol may not appear in syntax object" t)) + (else t))))) + + ;; Only expands while t is a user macro invocation. + ;; Used by expand-lambda to detect internal definitions. + + (define (head-expand t) + (fluid-let ((*trace* (cons t *trace*))) + (let ((binding (operator-binding t))) + (cond (binding (case (binding-type binding) + ((macro) + (let ((macro (binding->macro binding t))) + (case (macro-type macro) + ((expander) (values t binding)) + (else + (head-expand (invoke-macro macro t)))))) + (else (values t binding)))) + (else (values t binding)))))) + + ;; Returns binding of identifier in operator position | #f if none. + ;; Singleton identifiers are also considered operators here for + ;; the purpose of discovering identifier macros and variables. + ;; Checks level and registers as a use. + + (define (operator-binding t) + (let ((operator (if (pair? t) (car t) t))) + (and (identifier? operator) + (let ((binding (binding operator))) + (check-binding-level operator binding) + (register-use! operator binding) + binding)))) + + ;; We cannot implicitly import a mutable variable. + + (define (check-implicit-import-of-mutable binding t) + (or (equal? (binding-library binding) *current-library*) + (not (binding-mutable? binding)) + (syntax-violation + #f + (string-append "Attempt to implicitly import variable that is mutable in library (" + (list->string (binding-library binding) " ") ")") + t))) + + ;;========================================================================= + ;; + ;; Quote, if, set!, expression begin, expression let[rec]-syntax, and, or: + ;; + ;;========================================================================= + + (define (expand-quote exp) + (match exp + ((- datum) (syntax->datum exp)))) + + (define (expand-if exp) + (match exp + ((- e1 e2 e3) `(if ,(expand e1) ,(expand e2) ,(expand e3))) + ((- e1 e2) `(if ,(expand e1) ,(expand e2))))) + + (define (expand-set! exp) + (match exp + ((- (? identifier? id) e) + (let ((binding (binding id))) + (check-binding-level id binding) + (register-use! id binding) + (case (binding-type binding) + ((macro) + (let ((macro (binding->macro binding id))) + (case (macro-type macro) + ((variable-transformer) + (expand (invoke-macro macro exp))) + (else + (syntax-violation + 'set! "Keyword being set! is not a variable transformer" exp id))))) + ((variable) + (or (eq? (binding-library binding) *current-library*) + (syntax-violation + 'set! "Directly or indirectly imported variable cannot be assigned" exp id)) + (binding-mutable-set! binding #t) + `(set! ,(binding-name binding) + ,(expand e))) + ((pattern-variable) + (syntax-violation 'set! "Pattern variable used outside syntax template" exp id))))))) + + ;; Expression begin. + + (define (expand-begin exp) + (match exp + ((- exps ___) + (scan-sequence 'expression-sequence + #f + exps + (lambda (forms no-syntax-definitions no-bound-variables) + `(begin ,@(map cdr forms))))))) + + ;; Expression let(rec)-syntax: + + (define (expand-local-syntax exp) + (expand-begin `(,(rename 'macro 'begin) ,exp))) + + ;; Define and and or as primitives so we can import them into the repl + ;; toplevel without spoiling the and and or of the library language. + + (define (expand-and exp) + (match exp + ((and) #t) + ((and e) (expand e)) + ((and e es ___) + `(if ,(expand e) + ,(expand `(,and ,@es)) + #f)))) + + (define (expand-or exp) + (match exp + ((or) #t) + ((or e) (expand e)) + ((or e es ___) + `(let ((x ,(expand e))) + (if x x ,(expand `(,or ,@es))))))) + + ;;========================================================================= + ;; + ;; Lambda: + ;; + ;;========================================================================= + + (define (expand-lambda exp) + (match exp + ((- (? formals? formals) body ___) + (fluid-let ((*usage-env* + (env-extend (map (lambda (formal) + (make-local-mapping 'variable formal #f)) + (flatten formals)) + *usage-env*))) + (let ((formals (dotted-map (lambda (formal) (binding-name (binding formal))) formals))) + ;; Scan-sequence expects the caller to have prepared + ;; the frame to which to destructively add bindings. + ;; Lambda bodies need a fresh frame. + (fluid-let ((*usage-env* (env-extend '() *usage-env*))) + (scan-sequence 'lambda + make-local-mapping + body + (lambda (forms syntax-definitions bound-variables) + `(lambda ,formals + ,@(if (null? bound-variables) ; +++ + (emit-body forms ex:undefined-set!) ; +++ + `(((lambda ,bound-variables + ,@(emit-body forms ex:undefined-set!)) + ,@(map (lambda (ignore) `ex:undefined) + bound-variables))))))))))))) + + (define (formals? s) + (or (null? s) + (identifier? s) + (and (pair? s) + (identifier? (car s)) + (formals? (cdr s)) + (not (dotted-memp (lambda (x) + (bound-identifier=? x (car s))) + (cdr s)))))) + + ;;========================================================================= + ;; + ;; Lambda*: + ;; + ;;========================================================================= + #;(define (expand-lambda* exp) + (define (variable? x) (symbol? x)) + (define (required-positional? x) (variable? x)) + (define (optional-positional? x) (and (pair? x) (pair? (cdr x)) (null? (cddr x)) (variable? (car x)))) + (define (required-named? x) (and (pair? x) (pair? (cdr x)) (null? (cddr x)) (keyword? (car x)) (variable? (cadr x)))) + (define (optional-named? x) (and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (null? (cdddr x)) (keyword? (car x)) (variable? (cadr x)))) + (define (named? x) (or (required-named? x) (optional-named? x))) + + (define (parse-formals formals) + + (define (duplicates? lst) + (cond + ((null? lst) #f) + ((memq (car lst) (cdr lst)) #t) + (else (duplicates? (cdr lst))))) + + (define (parse-positional-section lst cont) + (let loop1 ((lst lst) (rev-reqs '())) + (if (and (pair? lst) + (required-positional? (car lst))) + (loop1 (cdr lst) (cons (car lst) rev-reqs)) + (let loop2 ((lst lst) (rev-opts '())) + (if (and (pair? lst) + (optional-positional? (car lst))) + (loop2 (cdr lst) (cons (car lst) rev-opts)) + (cont lst (cons (reverse rev-reqs) (reverse rev-opts)))))))) + + (define (parse-named-section lst cont) + (let loop ((lst lst) (rev-named '())) + (if (and (pair? lst) + (named? (car lst))) + (loop (cdr lst) (cons (car lst) rev-named)) + (cont lst (reverse rev-named))))) + + (define (parse-rest lst + positional-before-named? + positional-reqs/opts + named) + (if (null? lst) + (parse-end positional-before-named? + positional-reqs/opts + named + #f) + (if (variable? lst) + (parse-end positional-before-named? + positional-reqs/opts + named + lst) + (error "syntax error in formal parameter list")))) + + (define (parse-end positional-before-named? + positional-reqs/opts + named + rest) + (let ((positional-reqs (car positional-reqs/opts)) + (positional-opts (cdr positional-reqs/opts))) + (let ((vars + (append positional-reqs + (map car positional-opts) + (map cadr named) + (if rest (list rest) '()))) + (keys + (map car named))) + (cond ((duplicates? vars) + (error "duplicate variable in formal parameter list")) + ((duplicates? keys) + (error "duplicate keyword in formal parameter list")) + (else + (list positional-before-named? + positional-reqs + positional-opts + named + rest)))))) + + (define (parse lst) + (if (and (pair? lst) (named? (car lst))) + (parse-named-section + lst + (lambda (lst named) + (parse-positional-section + lst + (lambda (lst positional-reqs/opts) + (parse-rest lst + #f + positional-reqs/opts + named))))) + (parse-positional-section + lst + (lambda (lst positional-reqs/opts) + (parse-named-section + lst + (lambda (lst named) + (parse-rest lst + #t + positional-reqs/opts + named))))))) + + (parse formals)) + (match exp + ;if it uses normal formals then use standard expand-lambda + ((- (? formals? formals) body ___) + (expand-lambda exp)) + ((- (? formals*? formals) body ___) + (fluid-let ((*usage-env* + (env-extend (map (lambda (formal) + (cond + ((named? formal) (make-local-mapping 'variable (cadr formal) #f)) + ((optional-positional? formal) (make-local-mapping 'variable (car formal) #f)) + (else (make-local-mapping 'variable formal #f)))) + (flatten formals)) + *usage-env*))) + (let ((formals (dotted-map (lambda (formal) (binding-name (binding formal))) formals))) + ;; Scan-sequence expects the caller to have prepared + ;; the frame to which to destructively add bindings. + ;; Lambda bodies need a fresh frame. + (fluid-let ((*usage-env* (env-extend '() *usage-env*))) + (scan-sequence 'lambda + make-local-mapping + body + (lambda (forms syntax-definitions bound-variables) + `(lambda ,formals + ,@(if (null? bound-variables) ; +++ + (emit-body forms ex:undefined-set!) ; +++ + `(((lambda ,bound-variables + ,@(emit-body forms ex:undefined-set!)) + ,@(map (lambda (ignore) `ex:undefined) + bound-variables))))))))))))) + #;(define (formals*? s) + (or (null? s) + (identifier? s) + (and (pair? s) + (or (identifier? (car s)) (pair? (car s))) + (formals*? (cdr s)) + (not (dotted-memp (lambda (x) + (bound-identifier=? x (car s))) + (cdr s)))))) + ;;========================================================================= + ;; + ;; Bodies and sequences: + ;; + ;;========================================================================= + + ;; R6RS splicing of internal let-syntax and letrec-syntax + ;; requires that we remember the bindings visible in each + ;; form for later expansion of deferred right hand sides + ;; and expressions. This is done by attaching + ;; the environment to the expression. + ;; We call the resulting data structure a wrap. + ;; Wraps are only used internally in processing of bodies, + ;; and are never seen by user macros. + + (define (make-wrap env exp) + (cons env exp)) + (define wrap-env car) + (define wrap-exp cdr) + + ;; The continuation k is evaluated in the body environment. This is + ;; used for example by expand-library to obtain the correct bindings of + ;; exported identifiers. + ;; + ;; ::= toplevel | library | program | lambda | expression-sequence + ;; + ;; All but TOPLEVEL are as in r6rs. + ;; TOPLEVEL is meant for the REPL. + ;; At TOPLEVEL, we may have a sequence of expressions, definitions, macros, + ;; import declarations, libraries and programs wrapped in (program ---). + ;; Redefinitions are allowed at toplevel. + + (define (scan-sequence body-type make-map body-forms k) + + ;; Each
::= ( #t ) (deferred rhs) + ;; | ( #f ) (undeferred rhs) + ;; Returns (( . ) ...) + + (define (expand-deferred forms) + (map (lambda (form) + (cons (car form) + (let ((deferred? (cadr form)) + (exp (caddr form))) + (if deferred? + (fluid-let ((*usage-env* (wrap-env exp))) + (expand (wrap-exp exp))) + exp)))) + forms)) + + (let ((common-env *usage-env*)) + + ;; Add new frame for keeping track of bindings used + ;; so we can detect redefinitions violating lexical scope. + (add-fresh-used-frame!) + + (let loop ((ws (map (lambda (e) (make-wrap common-env e)) + body-forms)) + (forms '()) + (syntax-defs '()) + (bound-variables '())) + (cond + ((null? ws) + (check-expression-body body-type forms body-forms) + ;; Add denotations used in this frame to those of parent. + ;; This is just for the optional reporting of shadowing errors. + (merge-used-with-parent-frame!) + (k (reverse (expand-deferred forms)) + (reverse syntax-defs) + bound-variables)) + (else + (fluid-let ((*usage-env* (wrap-env (car ws)))) + (call-with-values + (lambda () (head-expand (wrap-exp (car ws)))) + (lambda (form operator-binding) + (let ((type (and operator-binding (binding-name operator-binding)))) + (check-expression-sequence body-type type form) + (check-toplevel body-type type form) + (case type + ((import) + (match form + ((- specs ___) + (call-with-values + (lambda () (scan-imports specs)) + (lambda (imported-libraries imports) + (import-libraries-for-expand imported-libraries (map not imported-libraries) 0) + (env-import! (car form) imports common-env) + (loop (cdr ws) + (cons (list #f #f `(ex:import-libraries-for-run + ',imported-libraries + ',(current-builds imported-libraries) + 0)) + forms) + syntax-defs + bound-variables)))))) + ((program) + (loop (cdr ws) + (cons (list #f #f (expand-program form)) forms) + syntax-defs + bound-variables)) + ((library) + (loop (cdr ws) + (cons (list #f #f (expand-library form)) forms) + syntax-defs + bound-variables)) + ((define) + (call-with-values + (lambda () (parse-definition form)) + (lambda (id rhs) + (check-valid-definition id common-env body-type form forms type) + (env-extend! (list (make-map 'variable id #f)) common-env) + (loop (cdr ws) + (cons (list (binding-name (binding id)) + #t + (make-wrap *usage-env* rhs)) + forms) + syntax-defs + (cons (binding-name (binding id)) bound-variables))))) + ((define-syntax) + (call-with-values + (lambda () (parse-definition form)) + (lambda (id rhs) + (check-valid-definition id common-env body-type form forms type) + (let ((mapping (make-map 'macro id #f))) + (env-extend! (list mapping) common-env) + (let ((rhs (fluid-let ((*phase* (+ 1 *phase*))) + (expand rhs)))) + (register-macro! (binding-name (cdr mapping)) (make-user-macro (eval rhs (interaction-environment)))) + (loop (cdr ws) + forms + (cons (cons (binding-name (binding id)) rhs) syntax-defs) + bound-variables)))))) + ((begin) + (or (list? form) + (invalid-form form)) + (loop (append (map (lambda (exp) + (make-wrap *usage-env* exp)) + (cdr form)) + (cdr ws)) + forms + syntax-defs + bound-variables)) + ((let-syntax letrec-syntax) + (call-with-values + (lambda () (parse-local-syntax form)) + (lambda (formals rhs body) + (let* ((original-env *usage-env*) + (usage-diff (map (lambda (formal) + (make-local-mapping 'macro formal #f)) + formals)) + (extended-env (env-extend usage-diff original-env)) + (rhs-expanded + (fluid-let ((*phase* (+ 1 *phase*)) + (*usage-env* + (case type + ((let-syntax) original-env) + ((letrec-syntax) extended-env)))) + (map expand rhs))) + (macros (map (lambda (e) (eval e (interaction-environment))) rhs-expanded))) + (for-each (lambda (mapping macro) + (register-macro! (binding-name (cdr mapping)) (make-user-macro macro))) + usage-diff + macros) + (loop (append (map (lambda (form) (make-wrap extended-env form)) + body) + (cdr ws)) + forms + syntax-defs + bound-variables))))) + (else + (loop (cdr ws) + (cons (list #f #t (make-wrap *usage-env* form)) + forms) + syntax-defs + bound-variables)))))))))))) + + (define (emit-body body-forms define-or-set) + (map (lambda (body-form) + (if (symbol? (car body-form)) + `(,define-or-set ,(car body-form) ,(cdr body-form)) + (cdr body-form))) + body-forms)) + + (define (parse-definition exp) + (match exp + ((- (? identifier? id)) + (values id (rename 'variable 'ex:unspecified))) + ((- (? identifier? id) e) + (values id e)) + ((- ((? identifier? id) . (? formals? formals)) body ___) + (values id `(,(rename 'macro 'lambda) ,formals ,@body))))) + + (define (parse-local-syntax t) + (match t + ((- ((x e) ___) body ___) + (or (formals? x) + (invalid-form t)) + (values x e body)))) + + (define (check-expression-sequence body-type type form) + (and (eq? body-type 'expression-sequence) + (memq type '(import program library define define-syntax)) + (syntax-violation type "Invalid form in expression sequence" form))) + + (define (check-toplevel body-type type form) + (and (not (eq? body-type 'toplevel)) + (memq type '(import program library)) + (syntax-violation type "Expression may only occur at toplevel" form))) + + (define (check-valid-definition id common-env body-type form forms type) + (and (not (eq? body-type 'toplevel)) + (duplicate? id common-env) + (syntax-violation type "Redefinition of identifier in body" form id)) + (check-used id body-type form) + (and (not (memq body-type `(toplevel program))) + (not (null? forms)) + (not (symbol? (car (car forms)))) + (syntax-violation type "Definitions may not follow expressions in a body" form))) + + (define (check-expression-body body-type forms body-forms) + (and (eq? body-type 'lambda) + (or (null? forms) + (symbol? (caar forms))) + (syntax-violation body-type "Body must be nonempty and end with an expression" body-forms))) + + ;;========================================================================= + ;; + ;; Syntax-case: + ;; + ;;========================================================================= + + (define (expand-syntax-case exp) + (define (literal? x) + (and (identifier? x) + (not (or (free=? x '_) + (free=? x '...))))) + (match exp + ((- e ((? literal? literals) ___) clauses ___) + (let ((input (generate-guid 'input))) + `(let ((,input ,(expand e))) + ,(process-clauses clauses input literals)))))) + + (define (process-clauses clauses input literals) + + (define (literal? pattern) + (and (identifier? pattern) + (memp (lambda (x) + (bound-identifier=? x pattern)) + literals))) + + (define (process-match input pattern sk fk) + (if (not (symbol? input)) + (let ((temp (generate-guid 'temp))) + `(let ((,temp ,input)) + ,(process-match temp pattern sk fk))) + (match pattern + ((syntax _) sk) + ((syntax ...) (syntax-violation 'syntax-case "Invalid use of ellipses" pattern)) + (() `(if (null? ,input) ,sk ,fk)) + ((? literal? id) `(if (and (ex:identifier? ,input) + (ex:free-identifier=? ,input ,(syntax-reflect id))) + ,sk + ,fk)) + ((? identifier? id) `(let ((,(binding-name (binding id)) ,input)) ,sk)) + ((p (syntax ...)) + (let ((mapped-pvars (map (lambda (pvar) (binding-name (binding pvar))) + (map car (pattern-vars p 0))))) + (if (and (identifier? p) ; +++ + (= (length mapped-pvars) 1)) ; +++ + `(if (list? ,input) ; +++ + (let ((,(car mapped-pvars) ,input)) ; +++ + ,sk) ; +++ + ,fk) ; +++ + (let ((columns (generate-guid 'cols)) + (rest (generate-guid 'rest))) + `(ex:map-while (lambda (,input) + ,(process-match input + p + `(list ,@mapped-pvars) + #f)) + ,input + (lambda (,columns ,rest) + (if (null? ,rest) + (apply (lambda ,mapped-pvars ,sk) + (if (null? ,columns) + ',(map (lambda (ignore) '()) mapped-pvars) + (apply map list ,columns))) + ,fk))))))) + ((p (syntax ...) . tail) + (let ((tail-length (dotted-length tail))) + `(if (>= (ex:dotted-length ,input) ,tail-length) + ,(process-match `(ex:dotted-butlast ,input ,tail-length) + `(,p ,(cadr pattern)) + (process-match `(ex:dotted-last ,input ,tail-length) + tail + sk + fk) + fk) + ,fk))) + ((p1 . p2) + `(if (pair? ,input) + ,(process-match `(car ,input) + p1 + (process-match `(cdr ,input) p2 sk fk) + fk) + ,fk)) + (#(ps ___) + `(if (vector? ,input) + ,(process-match `(vector->list ,input) + ps + sk + fk) + ,fk)) + ((? symbol? -) + (syntax-violation 'syntax-case "Symbol object may not appear in pattern" pattern)) + (other + `(if (equal? ,input ',other) ,sk ,fk))))) + + (define (pattern-vars pattern level) + (match pattern + ((p (syntax ...) . tail) (append (pattern-vars p (+ level 1)) + (pattern-vars tail level))) + ((p1 . p2) (append (pattern-vars p1 level) + (pattern-vars p2 level))) + (#(ps ___) (pattern-vars ps level)) + ((syntax ...) '()) + ((syntax _) '()) + ((? literal? -) '()) + ((? identifier? id) (list (cons id level))) + (- '()))) + + (define (process-clause clause input fk) + (match clause + ((pattern . rest) + (let ((pvars (pattern-vars pattern 0))) + (check-set? (map car pvars) + bound-identifier=? + (lambda (dup) + (syntax-violation 'syntax-case "Repeated pattern variable" clause dup))) + (let ((mappings (map (lambda (pvar) + (make-local-mapping 'pattern-variable (car pvar) (cdr pvar))) + pvars))) + (fluid-let ((*usage-env* (env-extend mappings *usage-env*))) + (process-match input + pattern + (match rest + ((template) + (expand template)) + ((fender template) + `(if ,(expand fender) + ,(expand template) + ,fk)) + (- (syntax-violation 'syntax-case "Invalid clause" clause))) + fk))))))) + + ;; process-clauses + + (match clauses + (() + `(ex:invalid-form ,input)) + ((clause clauses ___) + (let ((fail (generate-guid 'fail))) + `(let ((,fail (lambda () ,(process-clauses clauses input literals)))) + ,(process-clause clause input `(,fail))))))) + + ;;========================================================================= + ;; + ;; Syntax: + ;; + ;;========================================================================= + + (define (expand-syntax form) + (match form + ((- template) + (process-template template 0 #f)))) + + (define (process-template template dim ellipses-quoted?) + (match template + ((syntax ...) + (if (not ellipses-quoted?) + (syntax-violation 'syntax "Invalid occurrence of ellipses in syntax template" template)) + (syntax-reflect template)) + ((? identifier? id) + (let ((binding (binding id))) + (cond ((and binding + (eq? (binding-type binding) 'pattern-variable) + (binding-dimension binding)) + => (lambda (pdim) + (if (<= pdim dim) + (begin + (check-binding-level id binding) + (register-use! id binding) + (binding-name binding)) + (syntax-violation 'syntax "Template dimension error (too few ...'s?)" id)))) + (else + (syntax-reflect id))))) + (((syntax ...) p) + (process-template p dim #t)) + ((? (lambda (_) (not ellipses-quoted?)) + (t (syntax ...) . tail)) + (let* ((depth (segment-depth template)) + (seg-dim (+ dim depth)) + (vars + (map (lambda (mapping) + (let ((id (car mapping)) + (binding (cdr mapping))) + (check-binding-level id binding) + (register-use! id binding) + (binding-name binding))) + (free-meta-variables t seg-dim '())))) + (if (null? vars) + (syntax-violation 'syntax "Too many ...'s" template) + (let* ((x (process-template t seg-dim ellipses-quoted?)) + (gen (if (equal? (list x) vars) ; +++ + x ; +++ + `(if (or (< (length ',vars) 2) + (= ,@(map (lambda (var) + `(length ,var)) + vars))) + (map (lambda ,vars ,x) + ,@vars) + (ex:syntax-violation + 'syntax + "Pattern variables denoting lists of unequal length preceding ellipses" + ',(syntax->datum template) + (list ,@vars))))) + (gen (do ((d depth (- d 1)) + (gen gen `(apply append ,gen))) + ((= d 1) + gen)))) + (if (null? (segment-tail template)) ; +++ + gen ; +++ + `(append ,gen ,(process-template (segment-tail template) dim ellipses-quoted?))))))) + ((t1 . t2) + `(cons ,(process-template t1 dim ellipses-quoted?) + ,(process-template t2 dim ellipses-quoted?))) + (#(ts ___) + `(list->vector ,(process-template ts dim ellipses-quoted?))) + (other + `(quote ,(expand other))))) + + ;; Return a list of meta-variables of given higher dim + + (define (free-meta-variables template dim free) + (match template + ((? identifier? id) + (if (memp (lambda (x) (bound-identifier=? (car x) id)) free) + free + (let ((binding (binding id))) + (if (and binding + (eq? (binding-type binding) 'pattern-variable) + (let ((pdim (binding-dimension binding))) + (>= pdim dim))) + (cons (cons id binding) free) + free)))) + ((t (syntax ...) . tail) + (free-meta-variables t dim (free-meta-variables tail dim free))) + ((t1 . t2) + (free-meta-variables t1 dim (free-meta-variables t2 dim free))) + (#(ts ___) + (free-meta-variables ts dim free)) + (- free))) + + ;; Count the number of `...'s in PATTERN. + + (define (segment-depth pattern) + (match pattern + ((p (syntax ...) . rest) + (+ 1 (segment-depth (cdr pattern)))) + (- 0))) + + ;; Get whatever is after the `...'s in PATTERN. + + (define (segment-tail pattern) + (let loop ((pattern (cdr pattern))) + (match pattern + (((syntax ...) . tail) + (loop tail)) + (- pattern)))) + + ;;========================================================================= + ;; + ;; Detecting violations of lexical scope. + ;; + ;;========================================================================= + + ;; This is r6rs-optional. + ;; For avoiding giving lexically invalid semantics to body + ;; sequences according to the following semantics described in r6rs: + ;; A definition in the sequence of forms must not define any + ;; identifier whose binding is used to determine the meaning of the + ;; undeferred portions of the definition or any definition that precedes + ;; it in the sequence of forms. + ;; This implementation treats a possble violation of the restriction + ;; as a syntax violation. + + ;; The parameter *used* keeps track of bindings used so we can + ;; detect redefinitions violating lexical scope in body sequences. + ;; The car of *used* contains bindings used in current frame. + + (define (add-fresh-used-frame!) + (set! *used* (cons '() *used*))) + + (define (register-use! id binding) + (set! *used* (cons (cons (cons id binding) + (car *used*)) + (cdr *used*)))) + + (define (merge-used-with-parent-frame!) + (set! *used* (cons (append (car *used*) + (cadr *used*)) + (cddr *used*)))) + + (define (check-used id body-type form) + (and (not (eq? body-type 'toplevel)) + ;; The car contains bindings for current frame and nested frames + (let* ((already-used (car *used*)) + ;; This destructively changes *used* and must follow previous + (binding (binding id))) + (if (memp (lambda (mapping) + (and (eq? binding (cdr mapping)) + (bound-identifier=? id (car mapping)))) + already-used) + (syntax-violation + 'definition + "Definition of identifier that may have already affected meaning of undeferred portions of body" + form + id))))) + + ;;========================================================================== + ;; + ;; Libraries: + ;; + ;;========================================================================== + + (define (expand-program t) + (match t + ((program import-clause forms ___) + (expand-library-or-program + `(,program (,(datum->syntax program (generate-guid 'program))) + (,(datum->syntax program 'export)) + ,import-clause + ,@forms) + 'program)))) + + (define (expand-library t) + (expand-library-or-program t 'library)) + + ;; ::= library | program + + (define (expand-library-or-program t library-type) + (match t + ((keyword name ((syntax export) sets ___) ((syntax import) specs ___) body-forms ___) + (let ((name (syntax->datum (scan-library-name name)))) + (let ((exports (scan-exports sets))) + (call-with-values + (lambda () (scan-imports specs)) + (lambda (imported-libraries imports) + (fluid-let ((*usage-env* (make-unit-env)) + (*env-table* '()) + (*macro-table* '()) + (*current-library* name) + (*syntax-reflected* #f)) ; +++ space + + (import-libraries-for-expand imported-libraries (map not imported-libraries) 0) + (env-import! keyword imports *usage-env*) + + (let ((initial-env-table *env-table*)) ; +++ space + (scan-sequence library-type + make-local-mapping + body-forms + (lambda (forms syntax-definitions bound-variables) + (let* ((exports + (map (lambda (mapping) + (cons (id-name (car mapping)) + (let ((binding (binding (cadr mapping)))) + (or binding + (syntax-violation + 'library "Unbound export" t (cadr mapping))) + (if (binding-mutable? binding) + (syntax-violation + 'library "Attempt to export mutable variable" t (cadr mapping))) + binding))) + exports)) + (expanded-library + (case library-type + ((program) + `(begin + (ex:import-libraries-for-run ',imported-libraries + ',(current-builds imported-libraries) + 0) + ,@(emit-body forms 'define))) + ((library) + `(begin + ,@(map (lambda (var) + `(define ,var ex:unspecified)) + bound-variables) + (ex:register-library! + (ex:make-library + ',name + ;; Store as thunk so that it is not unnecesarily + ;; uncompressed at runtime + (lambda () + ,(if *syntax-reflected* ; +++ space + `(ex:uncompress ; +++ space + ',(compress (drop-tail + *env-table* + initial-env-table))) + `'())) ; +++ space + ',exports + ',imported-libraries + ',(current-builds imported-libraries) + ;; visit + (lambda () + ,@(map (lambda (def) + `(ex:register-macro! ',(car def) ,(cdr def))) + syntax-definitions) + (values)) + ;; invoke + (lambda () + ,@(map (lambda (var) + `(set! ,var ex:undefined)) + bound-variables) + ,@(emit-body forms ex:undefined-set!) + (values)) + ;; build + ',(generate-guid 'build))) + (values)))))) + + ;; Register library for any further expansion. + (if (eq? library-type 'library) + (eval expanded-library (interaction-environment))) + + expanded-library)))))))))))) + + (define (env-import! keyword imports env) + (env-extend! (map (lambda (import) + (cons (cons (car import) + (id-colors keyword)) + (cdr import))) + imports) + env)) + + (define (current-builds imported-libraries) + (map (lambda (lib-entry) + (ex:library-build (ex:lookup-library (car lib-entry)))) + imported-libraries)) + + (define (import-libraries-for-expand imports builds phase) + (ex:import-libraries-for + imports + builds + phase + (lambda (library phase imported) + (if (>= phase 0) + (let ((name (ex:library-name library))) + (if (not (memp (lambda (entry) + (and (equal? (car entry) name) + (>= (cdr entry) 0))) + imported)) + (fluid-let ((*phase* phase)) + (set! *env-table* (append ((ex:library-envs library)) *env-table*)) + ((ex:library-visiter library)))) + (if (>= phase 1) + (if (not (memp (lambda (entry) + (and (equal? (car entry) name) + (>= (cdr entry) 1))) + imported)) + (fluid-let ((*phase* phase)) + ((ex:library-invoker library)))))))))) + + ;; Returns (( ...) ...) + + (define (scan-exports sets) + (let ((exports (apply append (map scan-export-set sets)))) + (check-set? exports + (lambda (x y) + (eq? (id-name (car x)) + (id-name (car y)))) + (lambda (dup) (syntax-violation 'export "Duplicate export" sets dup))) + exports)) + + (define (scan-export-set set) + (match set + ((? identifier? x) + `((,x ,x 0))) + (((syntax rename) ((? identifier? xs) (? identifier? ys)) ___) + (map (lambda (x y) `(,y ,x 0)) xs ys)) + (- (syntax-violation 'export "Invalid export set" set)))) + + ;; Returns + ;; (values (( ...) ....) + ;; (( . ) ...)) + ;; with no repeats. + + (define (scan-imports specs) + (let loop ((specs specs) + (imported-libraries '()) + (imports '())) + (if (null? specs) + (values imported-libraries (unify-imports imports)) + (call-with-values + (lambda () (scan-import-spec (car specs))) + (lambda (library-ref levels more-imports) + (loop (cdr specs) + ;; library-ref = #f if primitives spec + (if library-ref + (cons (cons library-ref levels) + imported-libraries) + imported-libraries) + (append more-imports imports))))))) + + ;; Returns (values | #f + ;; ( ...) + ;; (( . ) ...) + ;; where ::= + ;; #f is returned for library name in case of primitives. + + (define (scan-import-spec spec) + ;(cond-expand + ;((or srfi-88 gambit) + (define prefix-identifier? (lambda (x) (or (keyword? x) (identifier? x)))) + (define prefix->string object->string) + ;(else + ;(define prefix-identifier? identifier?) + ;(define prefix->string symbol->string))) + + (call-with-values + (lambda () (scan-levels spec)) + (lambda (levels import-set) + (let loop ((import-set import-set) + (adjuster (lambda (set) set))) + + (define (check-presence names mappings from) + (for-each (lambda (name) + (or (assq name mappings) + (syntax-violation from + (string-append "Identifier not in set: " + (list->string (map car mappings) " ")) + import-set + name))) + names)) + + (match import-set + (((syntax primitives) (? identifier? xs) ___) + (values #f + levels + (map (lambda (mapping) + (cons (car mapping) (make-binding 'variable (cdr mapping) levels #f '()))) + (adjuster (map (lambda (name) (cons name name)) + (syntax->datum xs)))))) + (((syntax only) set (? identifier? xs) ___) + (let ((args (syntax->datum xs))) + (loop set + (compose adjuster (lambda (mappings) + (check-presence args mappings 'only) + (filter (lambda (mapping) + (memq (car mapping) args)) + mappings)))))) + (((syntax except) set (? identifier? xs) ___) + (let ((args (syntax->datum xs))) + (loop set + (compose adjuster (lambda (mappings) + (check-presence args mappings 'except) + (filter (lambda (mapping) + (not (memq (car mapping) args))) + mappings)))))) + (((syntax prefix) set (? prefix-identifier? pre)) + (loop set + (compose adjuster (lambda (mappings) + (map (lambda (mapping) + (cons (string->symbol + (string-append + (prefix->string (syntax->datum pre)) + (symbol->string (car mapping)))) + (cdr mapping))) + mappings))))) + (((syntax rename) set ((? identifier? xs) (? identifier? ys)) ___) + (let ((args (syntax->datum (cddr import-set)))) + (loop set + (compose adjuster + (lambda (mappings) + (check-presence (map car args) mappings 'rename) + (map (lambda (mapping) + (cons (cond ((assq (car mapping) args) => cadr) + (else (car mapping))) + (cdr mapping))) + mappings)))))) + (((syntax primitives) . -) (invalid-form import-set)) + (((syntax only) . -) (invalid-form import-set)) + (((syntax except) . -) (invalid-form import-set)) + (((syntax prefix) . -) (invalid-form import-set)) + (((syntax rename) . -) (invalid-form import-set)) + (- + (let ((library-ref (library-ref import-set))) + (if library-ref + (let* ((library (ex:lookup-library (syntax->datum library-ref))) + (exports (ex:library-exports library)) + (imports + (map (lambda (mapping) + (cons (car mapping) + (let ((binding (cdr (assq (cdr mapping) exports)))) + (make-binding (binding-type binding) + (binding-name binding) + (compose-levels levels (binding-levels binding)) + (binding-mutable? binding) + (binding-library binding))))) + (adjuster (map (lambda (name) (cons name name)) + (map car exports)))))) + (values (syntax->datum library-ref) + levels + imports)) + (syntax-violation 'import "Invalid import set" import-set))))))))) + + (define (scan-levels spec) + (match spec + (((syntax for) set levels ___) + (let ((levels + (map (lambda (level) + (match level + ((syntax run) 0) + ((syntax expand) 1) + (((syntax meta) (? integer? n)) n) + (- (syntax-violation 'for "Invalid level in for spec" spec level)))) + levels))) + (check-set? levels = (lambda (dup) (syntax-violation 'for "Repeated level in for spec" spec dup))) + (values levels set))) + (- (values '(0) spec)))) + + (define (compose-levels levels levels*) + (apply unionv + (map (lambda (level) + (map (lambda (level*) + (+ level level*)) + levels*)) + levels))) + + ;; Argument is of the form (( ) ...) + ;; where combinations ( (binding-name )) may be repeated. + ;; Return value is of the same format but with no repeats and + ;; where union of (binding-levels )s has been taken for any original repeats. + ;; An error is signaled if same occurs with s + ;; whose (binding-name )s are different. + + (define (unify-imports imports) + (let ((seen '())) + (let loop ((imports imports)) + (if (null? imports) + seen + (let* ((mapping (car imports)) + (probe (assq (car mapping) seen))) + (if probe + (begin + (or (eq? (binding-name (cdr mapping)) + (binding-name (cdr probe))) + (syntax-violation + 'import + (string-append "Different bindings for identifier imported from libraries (" + (list->string (binding-library (cdr mapping)) " ") + ") and (" + (list->string (binding-library (cdr probe)) " ") ")") + (car mapping))) + (set-cdr! probe + (make-binding (binding-type (cdr probe)) + (binding-name (cdr probe)) + (unionv (binding-levels (cdr probe)) + (binding-levels (cdr mapping))) + (binding-mutable? (cdr probe)) + (binding-library (cdr probe))))) + (set! seen (cons mapping seen))) + (loop (cdr imports))))))) + + (define (scan-library-name e) + (library-ref-helper e version?)) + + (define (library-ref e) + (library-ref-helper + (match e + (((syntax library) name) name) + (((syntax library) . -) (invalid-form e)) + (- e)) + version-reference?)) + + (define (library-ref-helper e version?) + (match e + (((? identifier? ids) ___) ids) + (((? identifier? ids) ___ (? version? -)) ids) + (- (syntax-violation 'library "Invalid library reference" e)))) + + (define (version? e) + (and (list? e) + (for-all subversion? e))) + + (define (subversion? x) + (and (integer? x) + (>= x 0))) + + (define (version-reference? e) + (match e + (((syntax and) (? version-reference? -) ___) #t) + (((syntax or) (? version-reference? -) ___) #t) + (((syntax not) (? version-reference? -)) #t) + (((? subversion-reference? -) ___) #t) + (- #f))) + + (define (subversion-reference? e) + (or (subversion? e) + (subversion-condition? e))) + + (define (subversion-condition? e) + (match e + (((syntax >=) (? subversion? -)) #t) + (((syntax <=) (? subversion? -)) #t) + (((syntax not) (? subversion? -)) #t) + (((syntax and) (? subversion-reference? -) ___) #t) + (((syntax or) (? subversion-reference? -) ___) #t) + (- #f))) + + ;;========================================================================== + ;; + ;; Debugging facilities: + ;; + ;;========================================================================== + + (define trace + (let ((constructor (record-constructor &trace))) + (lambda () (constructor (map syntax-debug *trace*))))) + + (define (syntax-violation who message form . maybe-subform) + (let ((who (if who + who + (cond ((identifier? form) + (syntax->datum form)) + ((and (list? form) + (identifier? (car form))) + (syntax->datum (car form))) + (else #f)))) + (subform (cond ((null? maybe-subform) #f) + ((and (pair? maybe-subform) + (null? (cdr maybe-subform))) + (car maybe-subform)) + (else (assertion-violation 'syntax-violation + "Invalid subform in syntax violation" + maybe-subform))))) + (raise + (if who + (condition (make-who-condition who) + (make-message-condition message) + (make-syntax-violation (syntax-debug form) (if subform (syntax-debug subform) #f)) + (trace)) + (condition (make-message-condition message) + (make-syntax-violation (syntax-debug form) (if subform (syntax-debug from))) + (trace)))))) + + (define (syntax-debug exp) + (sexp-map (lambda (leaf) + (cond ((identifier? leaf) + (id-name leaf)) + (else leaf))) + exp)) + + ;;========================================================================== + ;; + ;; Eval and environment: + ;; + ;;========================================================================== + + (define eval-template + (make-identifier 'eval-template + '() + '() + 0 + `(anonymous))) + + (define (make-r6rs-environment imported-libraries env) + (cons imported-libraries env)) + (define r6rs-environment-imported-libraries car) + (define r6rs-environment-env cdr) + + (define (environment . import-specs) + (fluid-let ((*usage-env* (make-unit-env))) + (env-import! eval-template (make-library-language) *usage-env*) + (call-with-values + (lambda () + (fluid-let ((*phase* 0)) + (scan-imports + (map (lambda (spec) + (datum->syntax eval-template spec)) + import-specs)))) + (lambda (imported-libraries imports) + (make-r6rs-environment imported-libraries + (let ((env (make-unit-env))) + (env-import! eval-template imports env) + env)))))) + + (define (r6rs-eval exp env) + (fluid-let ((*usage-env* (r6rs-environment-env env))) + (let ((exp (datum->syntax eval-template exp)) + (imported-libraries (r6rs-environment-imported-libraries env))) + (import-libraries-for-expand (r6rs-environment-imported-libraries env) (map not imported-libraries) 0) + (ex:import-libraries-for-run (r6rs-environment-imported-libraries env) (map not imported-libraries) 0) + (eval (expand-begin + ;; wrap in expression begin so no definition can occur as required by r6rs + `(,(rename 'macro 'begin) ,exp)) + (interaction-environment))))) + + ;;========================================================================== + ;; + ;; Library reflection: + ;; + ;;========================================================================= + + (define (environment-bindings r6rs-env) + (map format-mapping + (caar (r6rs-environment-env r6rs-env)))) + + (define (format-mapping mapping) + `((name ,(caar mapping)) + (type ,(binding-type (cdr mapping))) + (from ,(binding-library (cdr mapping))) + (levels ,(binding-levels (cdr mapping))))) + + ;;===================================================================== + ;; + ;; Utilities: + ;; + ;;===================================================================== + + (define (flatten l) + (cond ((null? l) l) + ((pair? l) (cons (car l) + (flatten (cdr l)))) + (else (list l)))) + + (define (sexp-map f s) + (cond ((null? s) '()) + ((pair? s) (cons (sexp-map f (car s)) + (sexp-map f (cdr s)))) + ((vector? s) + (apply vector (sexp-map f (vector->list s)))) + (else (f s)))) + + (define (dotted-memp proc ls) + (cond ((null? ls) #f) + ((pair? ls) (if (proc (car ls)) + ls + (dotted-memp proc (cdr ls)))) + (else (and (proc ls) + ls)))) + + (define (dotted-map f lst) + (cond ((null? lst) '()) + ((pair? lst) (cons (f (car lst)) + (dotted-map f (cdr lst)))) + (else (f lst)))) + + ;; Returns 0 also for non-list a la SRFI-1 protest. + + (define (dotted-length dl) + (cond ((null? dl) 0) + ((pair? dl) (+ 1 (dotted-length (cdr dl)))) + (else 0))) + + (define (dotted-butlast ls n) + (let recurse ((ls ls) + (length-left (dotted-length ls))) + (cond ((< length-left n) (assertion-violation 'dotted-butlast "List too short" ls n)) + ((= length-left n) '()) + (else + (cons (car ls) + (recurse (cdr ls) + (- length-left 1))))))) + + (define (dotted-last ls n) + (let recurse ((ls ls) + (length-left (dotted-length ls))) + (cond ((< length-left n) (assertion-violation 'dotted-last "List too short" ls n)) + ((= length-left n) ls) + (else + (recurse (cdr ls) + (- length-left 1)))))) + + (define (map-while f lst k) + (cond ((null? lst) (k '() '())) + ((pair? lst) + (let ((head (f (car lst)))) + (if head + (map-while f + (cdr lst) + (lambda (answer rest) + (k (cons head answer) + rest))) + (k '() lst)))) + (else (k '() lst)))) + + (define (check-set? ls = fail) + (or (null? ls) + (if (memp (lambda (x) + (= x (car ls))) + (cdr ls)) + (fail (car ls)) + (check-set? (cdr ls) = fail)))) + + (define (unionv . sets) + (cond ((null? sets) '()) + ((null? (car sets)) + (apply unionv (cdr sets))) + (else + (let ((rest (apply unionv + (cdr (car sets)) + (cdr sets)))) + (if (memv (car (car sets)) rest) + rest + (cons (car (car sets)) rest)))))) + + (define (drop-tail list tail) + (cond ((null? list) '()) + ((eq? list tail) '()) + (else + (cons (car list) + (drop-tail (cdr list) tail))))) + + (define (list->string e separator) + (define (tostring x) + (cond ((symbol? x) + (symbol->string x)) + ((number? x) + (number->string x)) + (else + (assertion-violation 'list->string "Invalid argument" e)))) + (if (null? e) + "" + (string-append + (tostring (car e)) + (apply string-append + (map (lambda (x) + (string-append separator (tostring x))) + (cdr e)))))) + + (define (compose f g) + (lambda (x) (f (g x)))) + + (define (check x p? from) + (or (p? x) + (syntax-violation from "Invalid argument" x))) + + (define (invalid-form exp) + (syntax-violation #f "Invalid form" exp)) + + ;;============================================================================ + ;; + ;; REPL integration: + ;; + ;;============================================================================ + + ;; Evaluates a sequence of library definitions, commands, and top-level + ;; import forms in the interactive environment. The semantics for + ;; evaluating libraries in and importing bindings into the interactive + ;; environment is consistent with the ERR5RS proposal at + ;; http://scheme-punks.cyber-rush.org/wiki/index.php?title=ERR5RS:Libraries. + ;; Bindings in the interactive environment persist between invocations + ;; of REPL. + + (define (repl exps) + (reset-toplevel!) + (for-each (lambda (exp) + (for-each (lambda (exp) + (for-each (lambda (result) + (display result) + (newline)) + (call-with-values + (lambda () + (eval exp (interaction-environment))) + list))) + (expand-toplevel-sequence (list exp)))) + exps)) + + ;; Evaluates a sequence of forms of the format + ;; * | * . + ;; The environment is separate from the + ;; interactive REPL environment and does not persist + ;; between invocations of run-r6rs-sequence. + ;; For importing and evaluating stuff in the persistent + ;; interactive environment, see REPL above. + + (define (run-r6rs-sequence forms) + (reset-toplevel!) + (for-each (lambda (exp) (eval exp (interaction-environment))) + (expand-toplevel-sequence (normalize forms)))) + + (define (run-r6rs-program filename) + (run-r6rs-sequence (read-file filename))) + + ;; Restores parameters to a consistent state + ;; in case they were left inconsistent by an error. + + (define reset-toplevel! + (let ((last-good-macro-table '()) + (last-good-env-table '())) + (lambda () + (if (not (null? *current-library*)) + (begin + ;; an error occurred while library was being + ;; expanded so restore last good toplevel tables + (set! *macro-table* last-good-macro-table) + (set! *env-table* last-good-env-table))) + (set! last-good-macro-table *macro-table*) + (set! last-good-env-table *env-table*) + (set! *trace* '()) + (set! *current-library* '()) + (set! *phase* 0) + (set! *used* (list '())) + (set! *color* (generate-color)) + (set! *usage-env* *toplevel-env*) + (set! *syntax-reflected* #f)))) + + (define (expand-toplevel-sequence forms) + (scan-sequence 'toplevel + make-toplevel-mapping + (source->syntax forms) + (lambda (forms syntax-definitions bound-variables) + (emit-body forms 'define)))) + + ;;========================================================================== + ;; + ;; Expand-file: + ;; + ;;========================================================================== + + ;; This may be used as a front end for the compiler. + ;; It expands a file consisting of a possibly empty sequence + ;; of libraries optionally followed by a . + ;; The result is a sequence of vanilla r5rs-like toplevel + ;; definitions and expressions. + + (define (expand-file filename target-filename) + (reset-toplevel!) + (write-file (expand-toplevel-sequence (normalize (read-file filename))) + target-filename)) + +;;;ATS added this to allow expanding multiple files into one file + (define (expand-file* target-filename . files) + (reset-toplevel!) + (write-file (expand-toplevel-sequence (normalize + (let loop ((files files)) + (cond + ((pair? files) (append (read-file (car files)) (loop (cdr files)))) + ((null? files) '()))))) + target-filename)) + + ;; This approximates the common r5rs behaviour of + ;; expanding a toplevel file but treating unbound identifiers + ;; as bare symbols that may refer to variables in the built-in toplevel + ;; environment. The environment argument should import at least the + ;; macros necessary to expand the file. + ;; This is provided mainly to be able to self-expand this expander + ;; metacircularly (see the relevant note at the top of this file). + ;; In contrast, expand-file strictly isolates a + ;; environment from the builtin environment and strictly disallows + ;; unbound identifiers. + ;; The resulting file will need the include file runtime.scm + ;; and the appropriate libraries that constitute the env argument + ;; to be preloaded before it can be run. + + (define (expand-r5rs-file filename target-filename r6rs-env) + (reset-toplevel!) + (fluid-let ((make-free-name (lambda (symbol) symbol)) + (*usage-env* (r6rs-environment-env r6rs-env)) + (*macro-table* *macro-table*)) + (let ((imported-libraries (r6rs-environment-imported-libraries r6rs-env))) + (import-libraries-for-expand (r6rs-environment-imported-libraries r6rs-env) (map not imported-libraries) 0) + (write-file (cons `(ex:import-libraries-for-run ',(r6rs-environment-imported-libraries r6rs-env) + ',(current-builds imported-libraries) + 0) + (expand-toplevel-sequence (read-file filename))) + target-filename)))) + + ;; Keeps ( ...) the same. + ;; Converts ( ... . ) + ;; to ( ... (program . )) + + (define (normalize exps) + (define (error) + (let ((newline (string #\newline))) + (syntax-violation + 'expand-file + (string-append + "File should be of the form:" newline + " *" newline + " | * ") + exps))) + (let loop ((exps exps) + (normalized '())) + (if (null? exps) + (reverse normalized) + (if (pair? (car exps)) + (case (caar exps) + ((library) + (loop (cdr exps) + (cons (car exps) normalized))) + ((import) + (loop '() + (cons (cons 'program exps) + normalized))) + (else (error))) + (error))))) + + (define (read-file fn) + (let ((p (open-input-file fn))) + (let f ((x (read p))) + (if (eof-object? x) + (begin (close-input-port p) '()) + (cons x + (f (read p))))))) + + (define (write-file exps fn) + (if (file-exists? fn) + (delete-file fn)) + (let ((p (open-output-file fn))) + (for-each (lambda (exp) + (write exp p) + (newline p)) + exps) + (close-output-port p))) + + ;;========================================================================== + ;; + ;; Toplevel bootstrap: + ;; + ;;========================================================================== + + (define toplevel-template + (make-identifier 'toplevel-template + '() + '() + 0 + #f)) + + (define (source->syntax datum) + (datum->syntax toplevel-template datum)) + + ;;=================================================================== + ;; + ;; Language for bootstrapping the REPL session and (environment ---): + ;; + ;;=================================================================== + + (define library-language-names + `(program library export import for run expand meta only + except prefix rename primitives >= <= and or not)) + + (define (make-library-language) + (map (lambda (name) + (cons name (make-binding 'macro name '(0) #f '()))) + library-language-names)) + + ;;=================================================================== + ;; + ;; Bootstrap library containing macros defined in this expander. + ;; + ;;=================================================================== + + (ex:register-library! + (let ((primitive-macro-mapping + `((lambda . ,expand-lambda) + (if . ,expand-if) + (set! . ,expand-set!) + (begin . ,expand-begin) + (syntax . ,expand-syntax) + (quote . ,expand-quote) + (let-syntax . ,expand-local-syntax) + (letrec-syntax . ,expand-local-syntax) + (syntax-case . ,expand-syntax-case) + (and . ,expand-and) + (or . ,expand-or) + (define . ,invalid-form) + (define-syntax . ,invalid-form) + (_ . ,invalid-form) + (... . ,invalid-form)))) + (ex:make-library + '(core primitive-macros) + ;; envs + (lambda () '()) + ;; exports + (map (lambda (mapping) + (cons (car mapping) (make-binding 'macro (car mapping) '(0) #f '()))) + primitive-macro-mapping) + ;; imported-libraries + '() + ;; builds + '() + ;; visit + (lambda () + (for-each (lambda (mapping) + (register-macro! (car mapping) (make-expander (cdr mapping)))) + primitive-macro-mapping) + (values)) + ;; invoke + (lambda () (values)) + ;; build + 'system))) + + ;; Initial environments: + + (set! *toplevel-env* (make-unit-env)) + (set! *usage-env* *toplevel-env*) + + ;; Import only the minimal library language into the toplevel: + + (env-import! toplevel-template (make-library-language) *toplevel-env*) + (register-macro! 'library (make-expander invalid-form)) + (register-macro! 'program (make-expander invalid-form)) + (register-macro! 'import (make-expander invalid-form)) + + ;;========================================================================== + ;; + ;; Exports: + ;; + ;;========================================================================== + + (set! ex:make-variable-transformer make-variable-transformer) + (set! ex:identifier? identifier?) + (set! ex:bound-identifier=? bound-identifier=?) + (set! ex:free-identifier=? free-identifier=?) + (set! ex:generate-temporaries generate-temporaries) + (set! ex:datum->syntax datum->syntax) + (set! ex:syntax->datum syntax->datum) + (set! ex:environment environment) + (set! ex:environment-bindings environment-bindings) + (set! ex:eval r6rs-eval) + (set! ex:syntax-violation syntax-violation) + + (set! ex:expand-file expand-file) + (set! ex:expand-file* expand-file*) + (set! ex:repl repl) + (set! ex:expand-r5rs-file expand-r5rs-file) + (set! ex:run-r6rs-sequence run-r6rs-sequence) + (set! ex:run-r6rs-program run-r6rs-program) + + (set! ex:invalid-form invalid-form) + (set! ex:register-macro! register-macro!) + (set! ex:syntax-rename syntax-rename) + (set! ex:map-while map-while) + (set! ex:dotted-length dotted-length) + (set! ex:dotted-butlast dotted-butlast) + (set! ex:dotted-last dotted-last) + (set! ex:uncompress uncompress) + (set! ex:free=? free=?) + + ) ; let + ) ; letrec-syntax adddir ./libs adddir ./libs/gambit addfile ./libs/gambit/bytevectors.scm hunk ./libs/gambit/bytevectors.scm 1 +(library (gambit bytevectors) + +(export + ;s8 +s8vector s8vector->list s8vector-append s8vector-copy s8vector-fill! list->s8vector s8vector-length s8vector-ref s8vector-set! make-s8vector s8vector? subs8vector + ;u8 +u8vector u8vector->list u8vector-append u8vector-copy u8vector-fill! make-u8vector u8vector-length u8vector-ref u8vector-set! list->u8vector u8vector? subu8vector +;u16 +u16vector u16vector->list u16vector-append u16vector-copy u16vector-fill! list->u16vector u16vector-length u16vector-ref u16vector-set! make-u16vector subu16vector u16vector? + ;s16 +s16vector s16vector->list s16vector-append s16vector-copy s16vector-fill! make-s16vector s16vector-length s16vector-ref s16vector-set! subs16vector s16vector? list->s16vector + ;u32 +u32vector u32vector->list u32vector-append u32vector-copy u32vector-fill! list->u32vector u32vector-length u32vector-ref u32vector-set! make-u32vector u32vector? subu32vector + ;s32 +s32vector s32vector->list s32vector-append s32vector-copy s32vector-fill! list->s32vector s32vector-length s32vector-ref s32vector-set! make-s32vector s32vector? subs32vector + ;s64 +s64vector s64vector->list s64vector-append s64vector-copy s64vector-fill! list->s64vector s64vector-length s64vector-ref s64vector-set! make-s64vector s64vector? subs64vector + ;u64 +u64vector u64vector->list u64vector-append u64vector-copy u64vector-fill! list->u64vector u64vector-length u64vector-ref u64vector-set! make-u64vector u64vector? subu64vector + ;f32 +f32vector f32vector->list f32vector-append f32vector-copy f32vector-fill! f32vector-length f32vector-ref f32vector-set! f32vector? subf32vector list->f32vector make-f32vector + ;f64 +f64vector f64vector->list f64vector-append f64vector-copy f64vector-fill! subf64vector f64vector-length f64vector-ref f64vector-set! f64vector? list->f64vector make-f64vector) +(import (primitives + ;s8 +s8vector s8vector->list s8vector-append s8vector-copy s8vector-fill! list->s8vector s8vector-length s8vector-ref s8vector-set! make-s8vector s8vector? subs8vector + ;u8 +u8vector u8vector->list u8vector-append u8vector-copy u8vector-fill! make-u8vector u8vector-length u8vector-ref u8vector-set! list->u8vector u8vector? subu8vector +;u16 +u16vector u16vector->list u16vector-append u16vector-copy u16vector-fill! list->u16vector u16vector-length u16vector-ref u16vector-set! make-u16vector subu16vector u16vector? + ;s16 +s16vector s16vector->list s16vector-append s16vector-copy s16vector-fill! make-s16vector s16vector-length s16vector-ref s16vector-set! subs16vector s16vector? list->s16vector + ;u32 +u32vector u32vector->list u32vector-append u32vector-copy u32vector-fill! list->u32vector u32vector-length u32vector-ref u32vector-set! make-u32vector u32vector? subu32vector + ;s32 +s32vector s32vector->list s32vector-append s32vector-copy s32vector-fill! list->s32vector s32vector-length s32vector-ref s32vector-set! make-s32vector s32vector? subs32vector + ;s64 +s64vector s64vector->list s64vector-append s64vector-copy s64vector-fill! list->s64vector s64vector-length s64vector-ref s64vector-set! make-s64vector s64vector? subs64vector + ;u64 +u64vector u64vector->list u64vector-append u64vector-copy u64vector-fill! list->u64vector u64vector-length u64vector-ref u64vector-set! make-u64vector u64vector? subu64vector + ;f32 +f32vector f32vector->list f32vector-append f32vector-copy f32vector-fill! f32vector-length f32vector-ref f32vector-set! f32vector? subf32vector list->f32vector make-f32vector + ;f64 +f64vector f64vector->list f64vector-append f64vector-copy f64vector-fill! subf64vector f64vector-length f64vector-ref f64vector-set! f64vector? list->f64vector make-f64vector +))) addfile ./libs/gambit/debug.scm hunk ./libs/gambit/debug.scm 1 +(library (gambit debug) + (export trace untrace step step-level-set! break unbreak generate-proper-tail-calls display-environment-set! pretty-print pp gc-report-set!) + (import (primitives trace untrace step step-level-set! break unbreak generate-proper-tail-calls display-environment-set! pretty-print pp gc-report-set!))) addfile ./libs/gambit/exceptions.scm hunk ./libs/gambit/exceptions.scm 1 +(library (gambit exceptions) + (export current-exception-handler with-exception-handler with-exception-catcher raise abort) + (import (primitives current-exception-handler with-exception-handler with-exception-catcher raise abort))) addfile ./libs/gambit/extensions.scm hunk ./libs/gambit/extensions.scm 1 +(library (gambit extensions) + (export + ;vectors + vector-copy vector-append subvector + ;boxes + box box? unbox set-box! + ;keywords + keyword? keyword->string string->keyword make-uninterned-keyword uninterned-keyword? + ;symbols + gensym make-uninterned-symbol uninterned-symbol? + ;serialization + object->u8vector u8vector->object + ;other + void + ;special forms + ;currently not supported + ;include define-macro declare + ) + (import (primitives + ;vectors + vector-copy vector-append subvector + ;boxes + box box? unbox set-box! + ;keywords + keyword? keyword->string string->keyword make-uninterned-keyword uninterned-keyword? + ;symbols + gensym make-uninterned-symbol uninterned-symbol? + ;serialization + object->u8vector u8vector->object + ;other + void + ;special forms + ;currently not supported + ;include define-macro declare + ))) addfile ./libs/gambit/files.scm hunk ./libs/gambit/files.scm 1 +(library (gambit files) + (export + ;path operations + current-directory path-expand path-normalize path-extension path-strip-extension path-directory path-strip-directory path-strip-trailing-directory-separator path-volume path-strip-volume + ;filesystem operations + create-directory create-fifo create-link create-symbolic-link rename-file copy-file delete-file delete-directory directory-files file-exists? + ;file-info + file-info file-info? file-info-type file-info-device file-info-inode file-info-mode file-info-number-of-links file-info-owner file-info-group file-info-size file-info-last-access-time file-info-last-modification-time file-info-last-change-time file-info-creation-time + ;combines file-info with the cooresponding accessor + file-type file-device file-inode file-mode file-number-of-links file-owner file-group file-size file-last-access-time path file-last-modification-time file-last-change-time file-attributes file-creation-time) + (import (primitives + ;path operations + current-directory path-expand path-normalize path-extension path-strip-extension path-directory path-strip-directory path-strip-trailing-directory-separator path-volume path-strip-volume + ;filesystem operations + create-directory create-fifo create-link create-symbolic-link rename-file copy-file delete-file delete-directory directory-files file-exists? + ;file-info + file-info file-info? file-info-type file-info-device file-info-inode file-info-mode file-info-number-of-links file-info-owner file-info-group file-info-size file-info-last-access-time file-info-last-modification-time file-info-last-change-time file-info-creation-time + ;combines file-info with the cooresponding accessor + file-type file-device file-inode file-mode file-number-of-links file-owner file-group file-size file-last-access-time path file-last-modification-time file-last-change-time file-attributes file-creation-time))) addfile ./libs/gambit/io.readtable.scm hunk ./libs/gambit/io.readtable.scm 1 +(library (gambit io readtable) + (export current-readtable readtable? readtable-case-conversion readtable-case-conversion?-set readtable-keywords-allowed? readtable-keywords-allowed?-set readtable-sharing-allowed? readtable-sharing-allowed?-set readtable-eval-allowed? readtable-eval-allowed?-set readtable-max-write-level readtable-max-write-level-set readtable-max-write-length readtable-max-write-length-set readtable-start-syntax readtable-start-syntax-set) + (import (primitives current-readtable readtable? readtable-case-conversion readtable-case-conversion?-set readtable-keywords-allowed? readtable-keywords-allowed?-set readtable-sharing-allowed? readtable-sharing-allowed?-set readtable-eval-allowed? readtable-eval-allowed?-set readtable-max-write-level readtable-max-write-level-set readtable-max-write-length readtable-max-write-length-set readtable-start-syntax readtable-start-syntax-set))) + addfile ./libs/gambit/io.scm hunk ./libs/gambit/io.scm 1 +(library (gambit io) + (export + ;object ports + input-port? output-port? port? read read-all write newline force-output close-input-port close-output-port close-port input-port-timeout-set! output-port-timeout-set! + ;character ports + input-port-line inport-port-column output-port-line output-port-column output-port-width read-char peek-char write-char read-line read-substring write-substring input-port-readtable output-port-readtable input-port-readtable-set! output-port-readtable-set! + ;byte ports + read-u8 write-u8 read-subu8vector write-subu8vector + ;device ports + ;filesystem devices + open-file open-input-file open-output-file call-with-input-file call-with-output-file with-input-from-file with-output-to-file input-port-byte-position output-port-byte-position + ;processes + open-process + ;network devices + open-tcp-client open-tcp-server + ;directory devices + open-directory + ;vector device + open-vector open-input-vector open-output-vector call-with-input-vector call-with-output-vector with-input-from-vector with-output-to-vector open-vector-pipe get-output-vector + ;string device + open-string open-input-string open-output-string call-with-input-string call-with-output-string with-input-from-string with-output-to-string open-string-pipe get-output-string object->string + ;u8vector device + open-u8vector open-input-u8vector open-output-u8vector call-with-input-u8vector call-with-output-u8vector with-input-from-u8vector with-output-to-u8vector open-u8vector-pipe get-output-u8vector + ;parameter object accessors + current-input-port current-output-port current-error-port + ;r5rs + display eof-object? + ) + (import (primitives + ;object ports + input-port? output-port? port? read read-all write newline force-output close-input-port close-output-port close-port input-port-timeout-set! output-port-timeout-set! + ;character ports + input-port-line inport-port-column output-port-line output-port-column output-port-width read-char peek-char write-char read-line read-substring write-substring input-port-readtable output-port-readtable input-port-readtable-set! output-port-readtable-set! + ;byte ports + read-u8 write-u8 read-subu8vector write-subu8vector + ;device ports + ;filesystem devices + open-file open-input-file open-output-file call-with-input-file call-with-output-file with-input-from-file with-output-to-file input-port-byte-position output-port-byte-position + ;processes + open-process + ;network devices + open-tcp-client open-tcp-server + ;directory devices + open-directory + ;vector device + open-vector open-input-vector open-output-vector call-with-input-vector call-with-output-vector with-input-from-vector with-output-to-vector open-vector-pipe get-output-vector + ;string device + open-string open-input-string open-output-string call-with-input-string call-with-output-string with-input-from-string with-output-to-string open-string-pipe get-output-string object->string + ;u8vector device + open-u8vector open-input-u8vector open-output-u8vector call-with-input-u8vector call-with-output-u8vector with-input-from-u8vector with-output-to-u8vector open-u8vector-pipe get-output-u8vector + ;parameter object accessors + current-input-port current-output-port current-error-port + ;r5rs + display eof-object? + )) +) addfile ./libs/gambit/programs.scm hunk ./libs/gambit/programs.scm 1 +(library (gambit programs) + (export shell-command exit command-line get-env set-env) + (import (primitives shell-command exit command-line get-env set-env))) addfile ./libs/gambit/threads.scm hunk ./libs/gambit/threads.scm 1 + +(library (gambit threads (4)) + (export + ;threads + current-thread make-thread thread? thread-name thread-thread-group thread-specific thread-specific-set! thread-base-priority thread-base-priority-set! thread-priority-boost thread-priority-boost-set! thread-quantum thread-quantum-set! thread-init! thread-start! thread-join! thread-yield! thread-sleep! thread-suspend! thread-resume! thread-terminate! thread-send thread-receive thread-mailbox-rewind thread-mailbox-next thread-mailbox-extract-and-rewind + ;threadgroups + make-thread-group thread-group? thread-group-name thread-group-parent thread-group-resume! thread-group-suspend! thread-group-terminate! + ;mutexes + make-mutex mutex? mutex-name mutex-specific mutex-specific-set! mutex-state mutex-lock! mutex-unlock! + ;condition-variables + make-condition-variable condition-variable? condition-variable-name condition-variable-specific condition-variable-specific-set! condition-variable-broadcast! condition-variable-signal! + ;exceptions + deadlock-exception? mailbox-receive-timeout-exception-arguments mailbox-receive-timeout-exception-procedure mailbox-receive-timeout-exception? started-thread-exception-arguments started-thread-exception-procedure started-thread-exception? terminated-thread-exception-arguments terminated-thread-exception-procedure terminated-thread-exception? uninitialized-thread-exception? uninitialized-thread-exception-procedure uninitialized-thread-exception-arguments abandoned-mutex-exception? join-timeout-exception? join-timeout-exception-procedure join-timeout-exception-arguments uncaught-exception? uncaught-exception-procedure uncaught-exception-arguments uncaught-exception-reason + +) + (import (primitives + ;threads + current-thread make-thread thread? thread-name thread-thread-group thread-specific thread-specific-set! thread-base-priority thread-base-priority-set! thread-priority-boost thread-priority-boost-set! thread-quantum thread-quantum-set! thread-init! thread-start! thread-join! thread-yield! thread-sleep! thread-suspend! thread-resume! thread-terminate! thread-send thread-receive thread-mailbox-rewind thread-mailbox-next thread-mailbox-extract-and-rewind + ;threadgroups + make-thread-group thread-group? thread-group-name thread-group-parent thread-group-resume! thread-group-suspend! thread-group-terminate! + ;mutexes + make-mutex mutex? mutex-name mutex-specific mutex-specific-set! mutex-state mutex-lock! mutex-unlock! + ;condition-variables + make-condition-variable condition-variable? condition-variable-name condition-variable-specific condition-variable-specific-set! condition-variable-broadcast! condition-variable-signal! + ;exceptions + deadlock-exception? mailbox-receive-timeout-exception-arguments mailbox-receive-timeout-exception-procedure mailbox-receive-timeout-exception? started-thread-exception-arguments started-thread-exception-procedure started-thread-exception? terminated-thread-exception-arguments terminated-thread-exception-procedure terminated-thread-exception? uninitialized-thread-exception? uninitialized-thread-exception-procedure uninitialized-thread-exception-arguments abandoned-mutex-exception? scheduler-exception? scheduler-exception-reason deadlock-exception? abandoned-mutex-exception? join-timeout-exception? join-timeout-exception-procedure join-timeout-exception-arguments uncaught-exception? uncaught-exception-procedure uncaught-exception-arguments uncaught-exception-reason +))) + addfile ./libs/gambit/time.scm hunk ./libs/gambit/time.scm 1 +(library (gambit time) + (export time? current-time time->seconds seconds->time) + (import (primitives time? current-time time->seconds seconds->time))) addfile ./libs/gambit/will.scm hunk ./libs/gambit/will.scm 1 +(library (gambit will (4)) + (export make-will will? will-testator will-execute! ) + (import (primitives make-will will? will-testator will-execute!))) addfile ./libs/ieee.scm hunk ./libs/ieee.scm 1 +(library (ieee) + (export not boolean? eqv? eq? equal? pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list length append reverse list-ref memq memv member assq assv assoc symbol? symbol->string string->symbol number? complex? real? rational? integer? exact? inexact? = < > <= >= zero? positive? negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round rationalize exp log sin cos tan asin acos atan expt sqrt make-rectangular make-polar real-part imag-part magnitude angle exact->inexact inexact->exact number->string string->number char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char->integer integer->char char-upcase char-downcase string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? substring string-append vector? make-vector vector vector-length vector-ref vector-set! procedure? apply map for-each call-with-current-continuation call-with-input-file call-with-output-file input-port? output-port? current-input-port current-output-port open-input-file open-output-file close-input-port close-output-port eof-object? read read-char peek-char write display newline write-char + ;special forms + define begin if lambda quote set! and or cond case let let* letrec do delay quasiquote) + (import (r5rs))) addfile ./libs/r5rs.scm hunk ./libs/r5rs.scm 1 +;; Nonstandard R5RS library: + +(library (r5rs) + (export + + ;; core primitives + + set! + + ;; rnrs base + + begin if lambda quote and or + define define-syntax let-syntax letrec-syntax + ... + + let let* letrec + case cond else => + quasiquote unquote unquote-splicing + syntax-rules + + * + - / < <= = > >= abs acos append apply asin atan angle + boolean? call-with-current-continuation + call-with-values car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar + cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + ceiling char? char->integer char=? char? char<=? char>=? + complex? cons cos + denominator dynamic-wind + eq? equal? eqv? even? exact? exp expt floor for-each + gcd imag-part inexact? integer->char integer? + lcm length list list->string + list->vector list-ref list-tail list? log magnitude make-polar + make-rectangular make-string make-vector map max min + negative? not null? number->string number? numerator + odd? pair? + positive? procedure? rational? rationalize + real-part real? reverse round + sin sqrt string string->list string->number string->symbol + string-append + string-copy string-length string-ref string<=? string=? string>? string? substring symbol->string symbol? tan + truncate values vector vector->list + vector-fill! vector-length vector-ref vector-set! vector? zero? + + ;; rnrs eval + + eval + + ;; rnrs load + + load + + ;; rnrs control + + do + ;; rnrs io ports + input-port? output-port? + + ;; rnrs io simple + + call-with-input-file call-with-output-file + close-input-port close-output-port current-input-port current-output-port + display eof-object? newline open-input-file open-output-file peek-char + read read-char with-input-from-file with-output-to-file write write-char + + ;; rnrs unicode + + char-upcase char-downcase char-ci=? char-ci? + char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? string-ci=? string-ci? + string-ci<=? string-ci>=? + + ;; rnrs mutable pairs + + set-car! set-cdr! + + ;; rnrs lists + + assoc assv assq member memv memq + + ;; rnrs mutable-strings + + string-set! string-fill! + + ;; rnrs r5rs + + null-environment scheme-report-environment delay force + exact->inexact inexact->exact quotient remainder modulo) + + ;; Not necessary to use only and except here, but keep + ;; them because they contain useful information. + + (import (only (core primitives) set!) + (except (rnrs base) + set! ; because should not be exported for expand + _ letrec* let-values let*-values identifier-syntax + real-valued? rational-valued? integer-valued? exact inexact finite? infinite? + nan? div mod div-and-mod div0 mod0 div0-and-mod0 exact-integer-sqrt boolean=? + symbol=? string-for-each vector-map vector-for-each error assertion-violation + call/cc) + (only (rnrs eval) eval) + (only (rnrs load) load) + (only (rnrs control) do) + (only (rnrs io ports) input-port? output-port?) + (only (rnrs io simple) + call-with-input-file call-with-output-file + close-input-port close-output-port current-input-port current-output-port + display eof-object? newline open-input-file open-output-file peek-char + read read-char with-input-from-file with-output-to-file write write-char) + (only (rnrs unicode) + char-upcase char-downcase char-ci=? char-ci? + char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? string-ci=? string-ci? + string-ci<=? string-ci>=?) + (only (rnrs mutable-pairs) set-car! set-cdr!) + (only (rnrs lists) assoc assv assq member memv memq) + (only (rnrs mutable-strings) string-set! string-fill!) + (rnrs r5rs)) + ) + addfile ./libs/renaming.scm hunk ./libs/renaming.scm 1 +;; Nonstandard explicit renaming library: +;; See also examples and discussion in file examples.scm. +;; +;; Exports: +;; +;; er-transformer (syntax) +;; bound-identifier=? (procedure) +;; datum->syntax (procedure) +;; +;; Differences with traditional explicit renaming: +;; +;; - The renaming procedure has signature -> , +;; where the type is disjoint from the type. +;; +;; - The renaming procedure acts as a mathematical function in the sense that +;; the identifiers obtained from any two calls with the same argument will +;; be the same in the sense of bound-identifier=?, not eqv? +;; +;; - The output may not contain raw symbols, so implicit identifiers must +;; be introduced using datum->syntax. +;; +;; - Breaking hygiene with datum->syntax allows more modular macro +;; programming than traditional explicit renaming. +;; See in particular the example of while in terms of loop below. +;; +;; - The renaming procedure is aware of the transformer environment, +;; so that identifiers not bound at the usage site will resolve to +;; the r6rs library-local bindings at the transformer site. +;; More precisely, they will be resolved in the lexical environment +;; of the er-transformer keyword. +;; +;; - Fully compatible with my r6rs syntax-case macro system. +;; +;; Portability and complexity note: +;; +;; This library is not r6rs-portable, since it assumes that the input +;; to a transformer is always an unwrapped syntax object, which is +;; allowed but not required by r6rs, and is currently only true for my +;; implementation. The library could be ported to other implementations +;; by inserting a step that unwrapped the input to the transformer. +;; However, that would adversely modify the complexity class of +;; er-transformer macros in those implementations. + +(library (explicit-renaming helper) + (export er-transformer) + (import (only (rnrs) + define-syntax lambda syntax-case syntax datum->syntax free-identifier=?)) + + (define-syntax er-transformer + (lambda (exp) + (syntax-case exp () + ((k proc) + (syntax + (lambda (form) + (proc form + (lambda (symbol) (datum->syntax (syntax k) symbol)) + free-identifier=?)))))))) + +(library (explicit-renaming) + (export er-transformer identifier? bound-identifier=? datum->syntax) + (import (explicit-renaming helper) + (rnrs syntax-case))) + adddir ./libs/rnrs addfile ./libs/rnrs/arithmetic.scm hunk ./libs/rnrs/arithmetic.scm 1 +(library (rnrs arithmetic fixnums (6)) + + (export + fixnum? fixnum-width least-fixnum greatest-fixnum + fx=? fx>? fx=? fx<=? + fxzero? fxpositive? fxnegative? + fxodd? fxeven? + fxmax fxmin + fx+ fx- fx* + fxdiv-and-mod fxdiv fxmod + fxdiv0-and-mod0 fxdiv0 fxmod0 + fx+/carry fx-/carry fx*/carry + fxnot fxand fxior fxxor + fxif fxbit-count fxlength + fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field fxcopy-bit-field + fxrotate-bit-field fxreverse-bit-field + fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right) + + (import + (primitives + fixnum? fixnum-width least-fixnum greatest-fixnum + fx=? fx>? fx=? fx<=? + fxzero? fxpositive? fxnegative? + fxodd? fxeven? + fxmax fxmin + fx+ fx- fx* + fxdiv-and-mod fxdiv fxmod + fxdiv0-and-mod0 fxdiv0 fxmod0 + fx+/carry fx-/carry fx*/carry + fxnot fxand fxior fxxor + fxif fxbit-count fxlength + fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field fxcopy-bit-field + fxrotate-bit-field fxreverse-bit-field + fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right))) + +(library (rnrs arithmetic flonums (6)) + + (export + flonum? + real->flonum + fl=? fl? fl<=? fl>=? + flinteger? flzero? flpositive? flnegative? flodd? fleven? + flfinite? flinfinite? flnan? + flmax flmin + fl+ fl* fl- fl/ + flabs + fldiv-and-mod fldiv flmod + fldiv0-and-mod0 fldiv0 flmod0 + flnumerator fldenominator + flfloor flceiling fltruncate flround + flexp fllog flsin flcos fltan flasin flacos flatan + flsqrt flexpt + +; FIXME +; &no-infinities make-no-infinities-violation no-infinities-violation +; &no-nans make-no-nans-violation no-nans-violation + + fixnum->flonum) + + (import + (primitives + flonum? + real->flonum + fl=? fl? fl<=? fl>=? + flinteger? flzero? flpositive? flnegative? flodd? fleven? + flfinite? flinfinite? flnan? + flmax flmin + fl+ fl* fl- fl/ + flabs + fldiv-and-mod fldiv flmod + fldiv0-and-mod0 fldiv0 flmod0 + flnumerator fldenominator + flfloor flceiling fltruncate flround + flexp fllog flsin flcos fltan flasin flacos flatan + flsqrt flexpt + +; FIXME +; &no-infinities make-no-infinities-violation no-infinities-violation +; &no-nans make-no-nans-violation no-nans-violation + + fixnum->flonum))) + +(library (rnrs arithmetic bitwise (6)) + + (export + + bitwise-not + bitwise-and + bitwise-ior + bitwise-xor + bitwise-if + bitwise-bit-count + bitwise-length + bitwise-first-bit-set + bitwise-bit-set? + bitwise-copy-bit + bitwise-bit-field + bitwise-copy-bit-field + bitwise-rotate-bit-field + bitwise-reverse-bit-field + bitwise-arithmetic-shift + bitwise-arithmetic-shift-left + bitwise-arithmetic-shift-right) + + (import + (primitives + + bitwise-not + bitwise-and + bitwise-ior + bitwise-xor + bitwise-if + bitwise-bit-count + bitwise-length + bitwise-first-bit-set + bitwise-bit-set? + bitwise-copy-bit + bitwise-bit-field + bitwise-copy-bit-field + bitwise-arithmetic-shift + bitwise-arithmetic-shift-left + bitwise-arithmetic-shift-right + bitwise-rotate-bit-field + bitwise-reverse-bit-field))) + addfile ./libs/rnrs/base.scm hunk ./libs/rnrs/base.scm 1 +(library (rnrs base (6)) + + (export + + ;; Macros defined in core expander: + + begin if lambda quote set! and or + define define-syntax let-syntax letrec-syntax + _ ... + + ;; Derived syntax: + + let let* letrec letrec* let-values let*-values + case cond else => + assert + quasiquote unquote unquote-splicing + syntax-rules + identifier-syntax + + ;; R5RS primitives: + + * + - / < <= = > >= abs acos append apply asin atan angle + boolean? call-with-current-continuation + call-with-values car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar + cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + ceiling char? char->integer char=? char? char<=? char>=? + complex? cons cos + denominator dynamic-wind + eq? equal? eqv? even? exact? exp expt floor for-each + gcd imag-part inexact? integer->char integer? + lcm length list list->string + list->vector list-ref list-tail list? log magnitude make-polar + make-rectangular make-string make-vector map max min + negative? not null? number->string number? numerator + odd? pair? + positive? procedure? rational? rationalize + real-part real? reverse round + sin sqrt string string->list string->number string->symbol + string-append + string-copy string-length string-ref string<=? string=? string>? string? substring symbol->string symbol? tan + truncate values vector vector->list + vector-fill! vector-length vector-ref vector-set! vector? zero? + + ;; R6RS additional procedures: + + real-valued? rational-valued? integer-valued? exact inexact finite? infinite? + nan? div mod div-and-mod div0 mod0 div0-and-mod0 exact-integer-sqrt boolean=? + symbol=? string-for-each vector-map vector-for-each error assertion-violation + call/cc) + + (import (except (core primitives) _ ...) + (core let) + (core derived) + (core quasiquote) + (core let-values) + (for (core syntax-rules) expand) + (for (core identifier-syntax) expand) + (for (only (core primitives) _ ... set!) expand) + (only (rnrs exceptions) raise) + (only (rnrs conditions) condition make-error make-message-condition make-who-condition make-irritants-condition) + (primitives + + ;; R5RS primitives: + + * + - / < <= = > >= abs acos append apply asin atan angle + boolean? call-with-current-continuation + call-with-values car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar + cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + ceiling char? char->integer char=? char? char<=? char>=? + complex? cons cos + denominator dynamic-wind + eq? equal? eqv? even? exact? exp expt floor for-each + gcd imag-part inexact? integer->char integer? + lcm length list list->string + list->vector list-ref list-tail list? log magnitude make-polar + make-rectangular make-string make-vector map max min + negative? not null? number->string number? numerator + odd? pair? + positive? procedure? rational? rationalize + real-part real? reverse round + sin sqrt string string->list string->number string->symbol + string-append + string-copy string-length string-ref string<=? string=? string>? string? substring symbol->string symbol? tan + truncate values vector vector->list + vector-fill! vector-length vector-ref vector-set! vector? zero? + + ;; R6RS additional procedures: + + real-valued? rational-valued? integer-valued? exact inexact finite? infinite? + nan? div mod div-and-mod div0 mod0 div0-and-mod0 exact-integer-sqrt boolean=? + symbol=? string-for-each vector-map vector-for-each assertion-violation + call/cc )) + + (define (error who message . irritants) + (raise + (if who + (condition (make-who-condition who) + (make-message-condition message) + (make-error) + (make-irritants-condition irritants)) + (condition + (make-message-condition message) + (make-error) + (make-irritants-condition irritants))))) + + + (define-syntax assert + (syntax-rules () + ((_ expression) + (if (not expression) + (assertion-violation #f "assertion failed" 'expression))))) + + ) ;; rnrs base + addfile ./libs/rnrs/bytevectors.scm hunk ./libs/rnrs/bytevectors.scm 1 +(library (rnrs bytevectors) + (export + ;general options + bytevector=? bytevector-copy! endianness native-endianness + (rename (u8vector? bytevector?) (make-u8vector make-bytevector) (u8vector-length bytevector-length) (u8vector-fill! bytevector-fill!) (u8vector-copy bytevector-copy)) + ;operations on bytes and octets + bytevector-s8-ref bytevector-s8-set! + (rename (u8vector-ref bytevector-u8-ref) (u8vector-set! bytevector-u8-set!) (u8vector->list bytevector-u8list) (list->u8vector u8-list->bytevector)) + ;operations on integers of arbitrary size + bytevector-uint-ref bytevector-sint-ref bytevector-uint-set! bytevector-sint-set! bytevector->uint-list bytevector->sint-list uint-list->bytevector sint-list->bytevector + ;operations on 16 bit integers + bytevector-u16-ref bytevector-s16-ref bytevector-u16-native-ref bytevector-s16-native-ref bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-set! bytevector-s16-native-set! + ;operations on 32 bit integers + bytevector-u32-ref bytevector-s32-ref bytevector-u32-native-ref bytevector-s32-native-ref bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-set! bytevector-s32-native-set! + ;operations on 64 bit integers + bytevector-u64-ref bytevector-s64-ref bytevector-u64-native-ref bytevector-s64-native-ref bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-set! bytevector-s64-native-set! + ;operations on IEEE-754 + bytevector-ieee-single-native-ref bytevector-ieee-single-ref bytevector-ieee-double-native-ref bytevector-ieee-double-ref bytevector-ieee-single-native-set! bytevector-ieee-single-set! bytevector-ieee-double-native-set! bytevector-ieee-double-set! + ;operations on strings + string->utf8 string->utf16 string->utf32 utf8->string utf16->string utf32->string) + (import + (rnrs base) + (rnrs control) + (gambit bytevectors) + (gambit io) + (gambit debug)) + + (define (endianness x) + (case x + ((big little native) x) + (else (error 'endianness "Endianness must be big, little or native")))) + + (define (native-endianness) 'native) + + (define (bytevector=? bytevector1 bytevector2) (equal? bytevector1 bytevector2)) + (define (bytevector-copy! source source-start target target-start k) (error 'bytevector-copy! "Not implemented")) + + (define (bytevector-s8-ref bytevector k) (error 'bytevector-s8-ref "Not implemented")) + + (define (bytevector-s8-set! bytevector k byte) (error 'bytevector-s8-set! "Not implemented")) + (define (bytevector-uint-ref bytevector k endianness size) (error 'bytevector-uint-ref "Not implemented")) + (define (bytevector-sint-ref bytevector k endianness size) (error 'bytevector-sint-ref "Not implemented")) + (define (bytevector-uint-set! bytevector k n endianness size) (error 'bytevector-uint-set! "Not implemented")) + (define (bytevector-sint-set! bytevector k n endianness size) (error 'bytevector-sint-set! "Not implemented")) + (define (bytevector->uint-list bytevector endianness size) (error 'bytevector->uint-list "Not implemented")) + (define (bytevector->sint-list bytevector endianness size) (error 'bytevector->sint-list "Not implemented")) + (define (uint-list->bytevector list endianness size) (error 'uint-list->bytevector "Not implemented")) + (define (sint-list->bytevector list endianness size) (error 'sint-list->bytevector "Not implemented")) + ;16bit + (define (bytevector-u16-ref bytevector k endianness) (bytevector-uint-ref bytevector k endianness 16)) + (define (bytevector-s16-ref bytevector k endianness) (bytevector-sint-ref bytevector k endianness 16)) + (define (bytevector-u16-native-ref bytevector k) (bytevector-uint-ref bytevector k (native-endianness) 16)) + (define (bytevector-s16-native-ref bytevector k) (bytevector-sint-ref bytevector k (native-endianness) 16)) + (define (bytevector-u16-set! bytevector k n endianness) (bytevector-uint-set! bytevector k n endianness 16)) + (define (bytevector-s16-set! bytevector k n endianness) (bytevector-sint-set! bytevector k n endianness 16)) + (define (bytevector-u16-native-set! bytevector k n) (bytevector-uint-set! bytevector k n (native-endianness) 16)) + (define (bytevector-s16-native-set! bytevector k n) (bytevector-sint-set! bytevector k n (native-endianness) 16)) + ;32bit + (define (bytevector-u32-ref bytevector k endianness) (bytevector-uint-ref bytevector k endianness 32)) + (define (bytevector-s32-ref bytevector k endianness) (bytevector-sint-ref bytevector k endianness 32)) + (define (bytevector-u32-native-ref bytevector k) (bytevector-uint-ref bytevector k (native-endianness) 32)) + (define (bytevector-s32-native-ref bytevector k) (bytevector-sint-ref bytevector k (native-endianness) 32)) + (define (bytevector-u32-set! bytevector k n endianness) (bytevector-uint-set! bytevector k n endianness 32)) + (define (bytevector-s32-set! bytevector k n endianness) (bytevector-sint-set! bytevector k n endianness 32)) + (define (bytevector-u32-native-set! bytevector k n) (bytevector-uint-set! bytevector k n (native-endianness) 32)) + (define (bytevector-s32-native-set! bytevector k n) (bytevector-sint-set! bytevector k n (native-endianness) 32)) + ;64bit + (define (bytevector-u64-ref bytevector k endianness) (bytevector-uint-ref bytevector k endianness 64)) + (define (bytevector-s64-ref bytevector k endianness) (bytevector-sint-ref bytevector k endianness 64)) + (define (bytevector-u64-native-ref bytevector k) (bytevector-uint-ref bytevector k (native-endianness) 64)) + (define (bytevector-s64-native-ref bytevector k) (bytevector-sint-ref bytevector k (native-endianness) 64)) + (define (bytevector-u64-set! bytevector k n endianness) (bytevector-uint-set! bytevector k n endianness 64)) + (define (bytevector-s64-set! bytevector k n endianness) (bytevector-sint-set! bytevector k n endianness 64)) + (define (bytevector-u64-native-set! bytevector k n) (bytevector-uint-set! bytevector k n (native-endianness) 64)) + (define (bytevector-s64-native-set! bytevector k n) (bytevector-sint-set! bytevector k n (native-endianness) 64)) + ;ieee-754 + (define (bytevector-ieee-single-native-ref bytevector k) (error 'bytevector-ieee-single-native-ref "Not implemented")) + (define (bytevector-ieee-single-ref bytevector k endianness) (error 'bytevector-ieee-single-ref "Not implemented")) + (define (bytevector-ieee-double-native-ref bytevector k) (error 'bytevector-ieee-double-native-ref "Not implemented")) + (define (bytevector-ieee-double-ref bytevector k endianness) (error 'bytevector-ieee-double-ref "Not implemented")) + (define (bytevector-ieee-single-native-set! bytevector k x) (error 'bytevector-ieee-single-native-set! "Not implemented")) + (define (bytevector-ieee-single-set! bytevector k x endianness) (error 'bytevector-ieee-single-set! "Not implemented")) + (define (bytevector-ieee-double-native-set! bytevector k x) (error 'bytevector-ieee-double-native-set! "Not implemented")) + (define (bytevector-ieee-double-set! bytevector k x endianness) (error 'bytevector-ieee-double-set! "Not implemented")) + ;strings + (define (string->utf8 string) + (call-with-output-u8vector '(char-encoding: UTF-8) + (lambda (p) + (display string p)))) + + (define (string->utf16 string . endian) + (call-with-output-u8vector + (if (null? endian) + '(char-encoding: UTF-16) + (case (endianness (car endian)) + ((big) '(char-encoding: UTF-16BE)) + ((little) '(char-encoding: UTF-16LE)) + (else '(char-encoding: UTF-16)))) + (lambda (p) + (display string p)))) + + (define (string->utf32 string . endian) + (call-with-output-u8vector + (if (null? endian) + '(char-encoding: UCS-4) + (case (endianness (car endian)) + ((big) '(char-encoding: UCS-4BE)) + ((little) '(char-encoding: UCS-4LE)) + (else '(char-encoding: UCS-4)))) + (lambda (p) + (display string p)))) + + (define (utf8->string bytevector) + (define buffer-size 512) + (call-with-input-u8vector `(init: ,bytevector char-encoding: UTF-8 permanent-close: #t) + (lambda (in) + (define out (open-output-string '())) + (define buffer (make-string buffer-size)) + (do ((i (read-substring buffer 0 buffer-size in) (read-substring buffer 0 buffer-size in))) + ((< i buffer-size) + (write-substring buffer 0 i out) + (display "getting output") + (force-output out) + (close-port out) + (get-output-string out)) + (pp i) + (pp buffer) + (write-substring buffer 0 i out))))) + + ;fixme + (define (utf16->string bytevector endianness . manditory) + (with-input-from-u8vector (list init: bytevector char-encoding: "UTF-16") + (read-line (current-input-port) #f))) + + ;fixme + (define (utf32->string bytevector endianness . manditory) + (with-input-from-u8vector (list init: bytevector char-encoding: "UCS-4") + (read-line (current-input-port) #f))) +) addfile ./libs/rnrs/conditions.scm hunk ./libs/rnrs/conditions.scm 1 +(library (rnrs conditions (6)) + (export &condition condition simple-conditions condition? condition-predicate condition-accessor + define-condition-type + &message make-message-condition message-condition? condition-message + &warning make-warning warning? + &serious make-serious-condition serious-condition? + &error make-error error? + &violation make-violation violation? + &assertion make-assertion-violation assertion-violation? + &irritants make-irritants-condition irritants-condition? condition-irritants + &who make-who-condition who-condition? condition-who + &non-continuable make-non-continuable-violation non-continuable-violation? + &implementation-restriction make-implementation-restriction-violation implementation-restriction-violation? + &lexical make-lexical-violation lexical-violation? + &syntax make-syntax-violation syntax-violation-form syntax-violation-subform + &undefined make-undefined-violation undefined-violation?) + (import + (for (core primitives) expand run) + (for (core syntax-rules) expand run) + (for (core derived) expand run) + (core let) + (for (only (rnrs records procedural) + record-constructor record-predicate record-accessor) expand run) + (primitives make-condition-type pair? null? car cdr list + &condition &serious &violation &assertion &who &message &irritants &syntax + condition simple-conditions make-assertion-violation make-syntax-violation + make-who-condition make-message-condition make-irritants-condition)) + + (define-syntax define-condition-type + (syntax-rules () + ((_ condition-type supertype constructor predicate (field accessor) ...) + (begin + (define condition-type (make-condition-type 'condition-type supertype '#(field ...))) + ;using the non-standard record-constructor with condition-type only + (define constructor (record-constructor condition-type)) + (define predicate (condition-predicate condition-type)) + (define accessor (condition-accessor condition-type + (record-accessor condition-type 'field))) ...)))) + + (define condition? (record-predicate &condition)) + + (define (condition-predicate rtd) + (define predicate (record-predicate rtd)) + (lambda (x) + (let recur ((conditions (simple-conditions x))) + (if (null? conditions) #f + (if (predicate (car conditions)) #t + (recur (cdr conditions))))))) + + ;should the accessor throw an error if the condition is not the proper type? + (define (condition-accessor rtd proc) + (define predicate (record-predicate rtd)) + (lambda (x) + (let recur ((conditions (simple-conditions x))) + (if (pair? conditions) + (if (predicate (car conditions)) + (proc (car conditions)) + (recur (cdr conditions))))))) + + ;standard conditions + (define-condition-type &warning &condition make-warning warning?) + (define make-serious-condition (record-constructor &serious)) + (define serious-condition? (condition-predicate &serious)) + (define-condition-type &error &serious make-error error?) + (define make-violation (record-constructor &violation)) + (define violation? (condition-predicate &violation)) + (define assertion-violation? (condition-predicate &assertion)) + (define-condition-type &lexical &violation make-lexical-violation lexical-violation?) + (define-condition-type &undefined &violation make-undefined-violation undefined-violation?) + (define who-condition? (condition-predicate &who)) + (define condition-who (condition-accessor &who (record-accessor &who 0))) + (define message-condition? (condition-predicate &message)) + (define condition-message (condition-accessor &message (record-accessor &message 0))) + (define irritants-condition? (condition-predicate &irritants)) + (define condition-irritants (condition-accessor &irritants (record-accessor &irritants 0))) + + (define-condition-type &non-continuable &violation + make-non-continuable-violation non-continuable-violation?) + (define-condition-type &implementation-restriction &violation + make-implementation-restriction-violation + implementation-restriction-violation?) + (define syntax-violation? (condition-predicate &syntax)) + (define syntax-violation-form (condition-accessor &syntax (record-accessor &syntax 0))) + (define syntax-violation-subform (condition-accessor &syntax (record-accessor &syntax 1))) + +) addfile ./libs/rnrs/control.scm hunk ./libs/rnrs/control.scm 1 +(library (rnrs control (6)) + (export when unless do case-lambda) + (import (for (rnrs base) expand run) + (for (rnrs syntax-case) expand run)) + ;(for (core primitives) expand run) + ;(for (core let) expand run) + ;(for (core with-syntax) expand) + ;(for (core syntax-rules) expand) + ;(for (primitives not map length assertion-violation = >= apply) + ; expand run) ) + + (define-syntax when + (syntax-rules () + ((when test result1 result2 ...) + (if test + (begin result1 result2 ...))))) + + (define-syntax unless + (syntax-rules () + ((unless test result1 result2 ...) + (if (not test) + (begin result1 result2 ...))))) + + (define-syntax do + (lambda (orig-x) + (syntax-case orig-x () + ((_ ((var init . step) ...) (e0 e1 ...) c ...) + (with-syntax (((step ...) + (map (lambda (v s) + (syntax-case s () + (() v) + ((e) (syntax e)) + (_ (syntax-violation 'do "Invalid step" orig-x s)))) + (syntax (var ...)) + (syntax (step ...))))) + (syntax-case (syntax (e1 ...)) () + (() (syntax (let do ((var init) ...) + (if (not e0) + (begin c ... (do step ...)))))) + ((e1 e2 ...) (syntax (let do ((var init) ...) + (if e0 + (begin e1 e2 ...) + (begin c ... (do step ...)))))))))))) + + (define-syntax case-lambda + (syntax-rules () + ((_ (fmls b1 b2 ...)) + (lambda fmls b1 b2 ...)) + ((_ (fmls b1 b2 ...) ...) + (lambda args + (let ((n (length args))) + (case-lambda-help args n + (fmls b1 b2 ...) ...)))))) + + (define-syntax case-lambda-help + (syntax-rules () + ((_ args n) + (assertion-violation #f "unexpected number of arguments")) + ((_ args n ((x ...) b1 b2 ...) more ...) + (if (= n (length '(x ...))) + (apply (lambda (x ...) b1 b2 ...) args) + (case-lambda-help args n more ...))) + ((_ args n ((x1 x2 ... . r) b1 b2 ...) more ...) + (if (>= n (length '(x1 x2 ...))) + (apply (lambda (x1 x2 ... . r) b1 b2 ...) + args) + (case-lambda-help args n more ...))) + ((_ args n (r b1 b2 ...) more ...) + (apply (lambda r b1 b2 ...) args)))) + + ) ; rnrs control + addfile ./libs/rnrs/core.scm hunk ./libs/rnrs/core.scm 1 +;;;===================================================================== +;;; +;;; Derived forms: +;;; +;;; Copyright (c) 2006 Andre van Tonder +;;; +;;; Copyright statement at http://srfi.schemers.org/srfi-process.html +;;; +;;;===================================================================== + +;;;===================================================================== +;;; +;;; This file builds r6rs up using a sequence of libraries. +;;; It constitutes a nontrivial example, tutorial and test +;;; of the library system. +;;; +;;; It is meant to be expanded by expander.scm and compiled +;;; together with the latter before using in a production system. +;;; +;;; Various of the standard macros were copied from +;;; SRFI-93 reference implementation. +;;; +;;; An explicit renaming library is included for easier +;;; porting of legacy macros in some implementations. +;;; +;;;===================================================================== + +(library (core primitives) + + (export + + ;; Macros defined in core expander: + + begin if lambda quote set! and or + define define-syntax let-syntax letrec-syntax + _ ... syntax syntax-case + + ;; Procedures and values defined in core expander: + + (rename (ex:make-variable-transformer make-variable-transformer) + (ex:identifier? identifier?) + (ex:bound-identifier=? bound-identifier=?) + (ex:free-identifier=? free-identifier=?) + (ex:generate-temporaries generate-temporaries) + (ex:datum->syntax datum->syntax) + (ex:syntax->datum syntax->datum) + (ex:syntax-violation syntax-violation) + (ex:environment environment) + (ex:environment-bindings environment-bindings) + (ex:eval eval) + (ex:undefined undefined))) + + (import + + (only (core primitive-macros) + + begin if set! and or lambda quote + define define-syntax let-syntax letrec-syntax + syntax syntax-case _ ...) + + ;; An extension to the r6rs import syntax, used here to make + ;; available variable bindings provided natively. + ;; This will not work for macros, which have to be defined + ;; within the context of this expander. + + (primitives + + ;; Procedures and values defined in the core expander: + + ex:make-variable-transformer ex:identifier? ex:bound-identifier=? + ex:free-identifier=? ex:generate-temporaries ex:datum->syntax ex:syntax->datum + ex:syntax-violation ex:environment ex:environment-bindings ex:eval + ex:undefined + )) + + ) ;; core primitives + +(library (core with-syntax) + (export with-syntax) + (import (for (core primitives) run expand) + (primitives list)) + + (define-syntax with-syntax + (lambda (x) + (syntax-case x () + ((_ () e1 e2 ...) (syntax (begin e1 e2 ...))) + ((_ ((out in)) e1 e2 ...) (syntax (syntax-case in () + (out (begin e1 e2 ...))))) + ((_ ((out in) ...) e1 e2 ...) (syntax (syntax-case (list in ...) () + ((out ...) (begin e1 e2 ...)))))))) + ) + +(library (core syntax-rules) + (export syntax-rules) + (import (for (core primitives) expand run) + (for (core with-syntax) expand) + (for (primitives for-all map) expand)) + + (define-syntax syntax-rules + (lambda (x) + (define clause + (lambda (y) + (syntax-case y () + (((keyword . pattern) template) + (syntax ((dummy . pattern) (syntax template)))) + (_ + (syntax-violation 'syntax-rules "Invalid expression" x))))) + (syntax-case x () + ((_ (k ...) cl ...) + (for-all identifier? (syntax (k ...))) + (with-syntax (((cl ...) (map clause (syntax (cl ...))))) + (syntax + (lambda (x) (syntax-case x (k ...) cl ...)))))))) + ) + +(library (core let) + (export let letrec letrec*) + (import (for (core primitives) expand run) + (for (core with-syntax) expand) + (for (primitives for-all) expand)) + + (define-syntax let + (lambda (x) + (syntax-case x () + ((_ ((x v) ...) e1 e2 ...) + (for-all identifier? (syntax (x ...))) + (syntax ((lambda (x ...) e1 e2 ...) v ...))) + ((_ f ((x v) ...) e1 e2 ...) + (for-all identifier? (syntax (f x ...))) + (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f) v ...)))))) + + (define-syntax letrec + (lambda (x) + (syntax-case x () + ((_ ((i v) ...) e1 e2 ...) + (with-syntax (((t ...) (generate-temporaries (syntax (i ...))))) + (syntax (let ((i undefined) ...) + (let ((t v) ...) + (set! i t) ... + (let () e1 e2 ...))))))))) + + (define-syntax letrec* + (lambda (x) + (syntax-case x () + ((_ ((i v) ...) e1 e2 ...) + (syntax (let () + (define i v) ... + (let () e1 e2 ...))))))) + + ) ; let + +(library (core derived) + (export let* cond case else =>) + (import (for (core primitives) expand run) + (for (core let) expand run) + (for (core with-syntax) expand) + (for (core syntax-rules) expand) + (for (primitives for-all null? memv car cdr) expand run)) + + (define-syntax let* + (lambda (x) + (syntax-case x () + ((_ () e1 e2 ...) + (syntax (let () e1 e2 ...))) + ((_ ((x v) ...) e1 e2 ...) + (for-all identifier? (syntax (x ...))) + (let f ((bindings (syntax ((x v) ...)))) + (syntax-case bindings () + (((x v)) (syntax (let ((x v)) e1 e2 ...))) + (((x v) . rest) (with-syntax ((body (f (syntax rest)))) + (syntax (let ((x v)) body)))))))))) + + (define-syntax cond + (lambda (x) + (syntax-case x () + ((_ c1 c2 ...) + (let f ((c1 (syntax c1)) + (c2* (syntax (c2 ...)))) + (syntax-case c2* () + (() + (syntax-case c1 (else =>) + ((else e1 e2 ...) (syntax (begin e1 e2 ...))) + ((e0) (syntax (let ((t e0)) (if t t)))) + ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t))))) + ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...)))) + (_ (syntax-violation 'cond "Invalid expression" x)))) + ((c2 c3 ...) + (with-syntax ((rest (f (syntax c2) + (syntax (c3 ...))))) + (syntax-case c1 (else =>) + ((e0) (syntax (let ((t e0)) (if t t rest)))) + ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest)))) + ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest))) + (_ (syntax-violation 'cond "Invalid expression" x))))))))))) + + (define-syntax case + (lambda (x) + (syntax-case x () + ((_ e c1 c2 ...) + (with-syntax ((body + (let f ((c1 (syntax c1)) + (cmore (syntax (c2 ...)))) + (if (null? cmore) + (syntax-case c1 (else) + ((else e1 e2 ...) (syntax (begin e1 e2 ...))) + (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) + (begin e1 e2 ...))))) + (with-syntax ((rest (f (car cmore) (cdr cmore)))) + (syntax-case c1 () + (((k ...) e1 e2 ...) + (syntax (if (memv t '(k ...)) + (begin e1 e2 ...) + rest))))))))) + (syntax (let ((t e)) body))))))) + + (define-syntax => + (lambda (x) + (syntax-violation '=> "Invalid expression" x))) + + (define-syntax else + (lambda (x) + (syntax-violation 'else "Invalid expression" x))) + + ) ; derived + +(library (core identifier-syntax) + (export identifier-syntax) + (import (for (core primitives) + expand + run + ;; since generated macro contains (syntax set!) at level 0 + (meta -1))) + + (define-syntax identifier-syntax + (lambda (x) + (syntax-case x (set!) + ((_ e) + (syntax (lambda (x) + (syntax-case x () + (id (identifier? (syntax id)) (syntax e)) + ((_ x (... ...)) (syntax (e x (... ...)))))))) + ((_ (id exp1) + ((set! var val) exp2)) + (and (identifier? (syntax id)) + (identifier? (syntax var))) + (syntax + (make-variable-transformer + (lambda (x) + (syntax-case x (set!) + ((set! var val) (syntax exp2)) + ((id x (... ...)) (syntax (exp1 x (... ...)))) + (id (identifier? (syntax id)) (syntax exp1)))))))))) + ) + +;;;========================================================= +;;; +;;; Quasisyntax in terms of syntax-case. +;;; +;;;========================================================= +;;; +;;; To make nested unquote-splicing behave in a useful way, +;;; the R5RS-compatible extension of quasiquote in appendix B +;;; of the following paper is here ported to quasisyntax: +;;; +;;; Alan Bawden - Quasiquotation in Lisp +;;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html +;;; +;;; The algorithm converts a quasisyntax expression to an +;;; equivalent with-syntax expression. +;;; For example: +;;; +;;; (quasisyntax (set! #,a #,b)) +;;; ==> (with-syntax ((t0 a) +;;; (t1 b)) +;;; (syntax (set! t0 t1))) +;;; +;;; (quasisyntax (list #,@args)) +;;; ==> (with-syntax (((t ...) args)) +;;; (syntax (list t ...))) +;;; +;;; Note that quasisyntax is expanded first, before any +;;; ellipses act. For example: +;;; +;;; (quasisyntax (f ((b #,a) ...)) +;;; ==> (with-syntax ((t a)) +;;; (syntax (f ((b t) ...)))) +;;; +;;; so that +;;; +;;; (let-syntax ((test-ellipses-over-unsyntax +;;; (lambda (e) +;;; (let ((a (syntax a))) +;;; (with-syntax (((b ...) (syntax (1 2 3)))) +;;; (quasisyntax +;;; (quote ((b #,a) ...)))))))) +;;; (test-ellipses-over-unsyntax)) +;;; +;;; ==> ((1 a) (2 a) (3 a)) + +(library (core quasisyntax) + (export quasisyntax unsyntax unsyntax-splicing) + (import (for (core primitives) run expand) + (for (core let) run expand) + (for (core derived) run expand) + (for (core with-syntax) run expand) + (for (primitives = > + - vector->list) run expand)) + + (define-syntax quasisyntax + (lambda (e) + + ;; Expand returns a list of the form + ;; [template[t/e, ...] (replacement ...)] + ;; Here template[t/e ...] denotes the original template + ;; with unquoted expressions e replaced by fresh + ;; variables t, followed by the appropriate ellipses + ;; if e is also spliced. + ;; The second part of the return value is the list of + ;; replacements, each of the form (t e) if e is just + ;; unquoted, or ((t ...) e) if e is also spliced. + ;; This will be the list of bindings of the resulting + ;; with-syntax expression. + + (define (expand x level) + (syntax-case x (quasisyntax unsyntax unsyntax-splicing) + ((quasisyntax e) + (with-syntax (((k _) x) ;; original identifier must be copied + ((e* reps) (expand (syntax e) (+ level 1)))) + (syntax ((k e*) reps)))) + ((unsyntax e) + (= level 0) + (with-syntax (((t) (generate-temporaries '(t)))) + (syntax (t ((t e)))))) + (((unsyntax e ...) . r) + (= level 0) + (with-syntax (((r* (rep ...)) (expand (syntax r) 0)) + ((t ...) (generate-temporaries (syntax (e ...))))) + (syntax ((t ... . r*) + ((t e) ... rep ...))))) + (((unsyntax-splicing e ...) . r) + (= level 0) + (with-syntax (((r* (rep ...)) (expand (syntax r) 0)) + ((t ...) (generate-temporaries (syntax (e ...))))) + (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...)))) + (syntax ((t ... ... . r*) + (((t ...) e) ... rep ...)))))) + ((k . r) + (and (> level 0) + (identifier? (syntax k)) + (or (free-identifier=? (syntax k) (syntax unsyntax)) + (free-identifier=? (syntax k) (syntax unsyntax-splicing)))) + (with-syntax (((r* reps) (expand (syntax r) (- level 1)))) + (syntax ((k . r*) reps)))) + ((h . t) + (with-syntax (((h* (rep1 ...)) (expand (syntax h) level)) + ((t* (rep2 ...)) (expand (syntax t) level))) + (syntax ((h* . t*) + (rep1 ... rep2 ...))))) + (#(e ...) + (with-syntax ((((e* ...) reps) + (expand (vector->list (syntax #(e ...))) level))) + (syntax (#(e* ...) reps)))) + (other + (syntax (other ()))))) + + (syntax-case e () + ((_ template) + (with-syntax (((template* replacements) (expand (syntax template) 0))) + (syntax + (with-syntax replacements (syntax template*)))))))) + + (define-syntax unsyntax + (lambda (e) + (syntax-violation 'unsyntax "Invalid expression" e))) + + (define-syntax unsyntax-splicing + (lambda (e) + (syntax-violation 'unsyntax "Invalid expression" e))) + ) + +(library (core quasiquote) + (export quasiquote unquote unquote-splicing) + (import (for (core primitives) run expand) + (for (core let) run expand) + (for (core derived) run expand) + (for (core with-syntax) expand) + (for (core quasisyntax) expand) + (for (primitives = + - null? cons car cdr append map list vector list->vector) + run expand)) + + ;; Optimised version copied from portable syntax-case (Dybvig) + + (define-syntax quasiquote + (let () + (define (quasi p lev) + (syntax-case p (unquote quasiquote) + ((unquote p) + (if (= lev 0) + (syntax ("value" p)) + (quasicons (syntax ("quote" unquote)) (quasi (syntax (p)) (- lev 1))))) + ((quasiquote p) (quasicons (syntax ("quote" quasiquote)) (quasi (syntax (p)) (+ lev 1)))) + ((p . q) + (syntax-case (syntax p) (unquote unquote-splicing) + ((unquote p ...) + (if (= lev 0) + (quasilist* (syntax (("value" p) ...)) (quasi (syntax q) lev)) + (quasicons + (quasicons (syntax ("quote" unquote)) (quasi (syntax (p ...)) (- lev 1))) + (quasi (syntax q) lev)))) + ((unquote-splicing p ...) + (if (= lev 0) + (quasiappend (syntax (("value" p) ...)) (quasi (syntax q) lev)) + (quasicons + (quasicons (syntax ("quote" unquote-splicing)) (quasi (syntax (p ...)) (- lev 1))) + (quasi (syntax q) lev)))) + (_ (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev))))) + (#(x ...) (quasivector (vquasi (syntax (x ...)) lev))) + (p (syntax ("quote" p))))) + (define (vquasi p lev) + (syntax-case p () + ((p . q) + (syntax-case (syntax p) (unquote unquote-splicing) + ((unquote p ...) + (if (= lev 0) + (quasilist* (syntax (("value" p) ...)) (vquasi (syntax q) lev)) + (quasicons + (quasicons (syntax ("quote" unquote)) (quasi (syntax (p ...)) (- lev 1))) + (vquasi (syntax q) lev)))) + ((unquote-splicing p ...) + (if (= lev 0) + (quasiappend (syntax (("value" p) ...)) (vquasi (syntax q) lev)) + (quasicons + (quasicons + (syntax ("quote" unquote-splicing)) + (quasi (syntax (p ...)) (- lev 1))) + (vquasi (syntax q) lev)))) + (_ (quasicons (quasi (syntax p) lev) (vquasi (syntax q) lev))))) + (() (syntax ("quote" ()))))) + (define (quasicons x y) + (with-syntax ((x x) (y y)) + (syntax-case (syntax y) () + (("quote" dy) + (syntax-case (syntax x) () + (("quote" dx) (syntax ("quote" (dx . dy)))) + (_ (if (null? (syntax dy)) (syntax ("list" x)) (syntax ("list*" x y)))))) + (("list" . stuff) (syntax ("list" x . stuff))) + (("list*" . stuff) (syntax ("list*" x . stuff))) + (_ (syntax ("list*" x y)))))) + (define (quasiappend x y) + (syntax-case y () + (("quote" ()) + (cond + ((null? x) (syntax ("quote" ()))) + ((null? (cdr x)) (car x)) + (else (with-syntax (((p ...) x)) (syntax ("append" p ...)))))) + (_ + (cond + ((null? x) y) + (else (with-syntax (((p ...) x) (y y)) (syntax ("append" p ... y)))))))) + (define (quasilist* x y) + (let f ((x x)) + (if (null? x) + y + (quasicons (car x) (f (cdr x)))))) + (define (quasivector x) + (syntax-case x () + (("quote" (x ...)) (syntax ("quote" #(x ...)))) + (_ + (let f ((y x) (k (lambda (ls) (quasisyntax ("vector" (unsyntax-splicing ls)))))) + (syntax-case y () + (("quote" (y ...)) (k (syntax (("quote" y) ...)))) + (("list" y ...) (k (syntax (y ...)))) + (("list*" y ... z) (f (syntax z) (lambda (ls) (k (append (syntax (y ...)) ls))))) + (else (quasisyntax ("list->vector" (unsyntax x))))))))) + (define (emit x) + (syntax-case x () + (("quote" x) (syntax 'x)) + (("list" x ...) (quasisyntax (list (unsyntax-splicing (map emit (syntax (x ...))))))) + ;; could emit list* for 3+ arguments if implementation supports list* + (("list*" x ... y) + (let f ((x* (syntax (x ...)))) + (if (null? x*) + (emit (syntax y)) + (quasisyntax (cons (unsyntax (emit (car x*))) (unsyntax (f (cdr x*)))))))) + (("append" x ...) (quasisyntax (append (unsyntax-splicing (map emit (syntax (x ...))))))) + (("vector" x ...) (quasisyntax (vector (unsyntax-splicing (map emit (syntax (x ...))))))) + (("list->vector" x) (quasisyntax (list->vector (unsyntax (emit (syntax x)))))) + (("value" x) (syntax x)))) + (lambda (x) + (syntax-case x () + ;; convert to intermediate language, combining introduced (but not + ;; unquoted source) quote expressions where possible and choosing + ;; optimal construction code otherwise, then emit Scheme code + ;; corresponding to the intermediate language forms. + ((_ e) (emit (quasi (syntax e) 0))))))) + + (define-syntax unquote + (lambda (e) + (syntax-violation 'unquote "Invalid expression" e))) + + (define-syntax unquote-splicing + (lambda (e) + (syntax-violation 'unquote-splicing "Invalid expression" e))) + ) + +(library (core let-values) + (export let-values let*-values) + (import (for (core primitives) expand run) + (for (core syntax-rules) expand) + (core let) + (primitives call-with-values)) + + (define-syntax let-values + (syntax-rules () + ((let-values (?binding ...) ?body0 ?body1 ...) + (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...))) + ((let-values "bind" () ?tmps ?body) + (let ?tmps ?body)) + ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body) + (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body)) + ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body) + (call-with-values + (lambda () ?e0) + (lambda ?args + (let-values "bind" ?bindings ?tmps ?body)))) + ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body) + (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body)) + ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body) + (call-with-values + (lambda () ?e0) + (lambda (?arg ... . x) + (let-values "bind" ?bindings (?tmp ... (?a x)) ?body)))))) + + (define-syntax let*-values + (syntax-rules () + ((let*-values () ?body0 ?body1 ...) + (begin ?body0 ?body1 ...)) + ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...) + (let-values (?binding0) + (let*-values (?binding1 ...) ?body0 ?body1 ...))))) + + ) ; core let-values + addfile ./libs/rnrs/eval.scm hunk ./libs/rnrs/eval.scm 1 +(library (rnrs eval (6)) + (export eval environment) + (import (core primitives))) + +;; Nonstandard library for reflection on library import sets. +;; See examples file for sevaral examples. + +(library (rnrs eval reflection (6)) + (export environment-bindings) + (import (core primitives))) + addfile ./libs/rnrs/exceptions.scm hunk ./libs/rnrs/exceptions.scm 1 +(library (rnrs exceptions (6)) + (export with-exception-handler (rename (abort raise) (raise raise-continuable))) + (import (primitives with-exception-handler abort raise))) addfile ./libs/rnrs/files.scm hunk ./libs/rnrs/files.scm 1 +(library (rnrs files (6)) + (export file-exists? delete-file) + (import (only (gambit files) file-exists? delete-file))) + addfile ./libs/rnrs/io.scm hunk ./libs/rnrs/io.scm 1 +(library (rnrs io ports (6)) + (export eof-object eof-object? port? input-port? output-port? (rename (call-with-output-string call-with-output-string-port))) + (import (gambit io) + (rnrs base)) + + (define (eof-object) #!eof)) + +(library (rnrs io simple (6)) + (export + eof-object eof-object? call-with-input-file call-with-output-file input-port? output-port? current-input-port current-output-port current-error-port with-input-from-file with-output-to-file open-input-file open-output-file close-input-port close-output-port read-char peek-char read display newline write write-char) + (import (gambit io) + (rnrs base)) + + (define (eof-object) #!eof)) + addfile ./libs/rnrs/lists.scm hunk ./libs/rnrs/lists.scm 1 +;derived from srfi-1 +(library (rnrs lists (6)) + (export find for-all exists filter partition fold-left fold-right + remp remove remq remv + memp member memv memq + assp assoc assv assq + cons*) + (import (primitives member memv memq assoc assv assq) + (rnrs base)) + + (define (filter pred lis) ; Sleazing with EQ? makes this + ;(check-arg procedure? pred filter) ; one faster. + (let recur ((lis lis)) + (if (null? lis) lis + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) ; Replicate the RECUR call so + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) + + (define (partition pred lis) + ;(check-arg procedure? pred partition) + (let recur ((lis lis)) + (if (null? lis) (values lis lis) + (let ((elt (car lis)) + (tail (cdr lis))) + (let-values ([(in out) (recur tail)]) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis)))))))) + + (define (remp pred l) (filter (lambda (x) (not (pred x))) l)) + (define (remove obj l) (filter (lambda (x) (not (equal? obj x))) l)) + (define (remv obj l) (filter (lambda (x) (not (eqv? obj x))) l)) + (define (remq obj l) (filter (lambda (x) (not (eq? obj x))) l)) + + (define (cons* first . rest) + (let recur ((x first) (rest rest)) + (if (pair? rest) + (cons x (recur (car rest) (cdr rest))) + x))) + + (define (find pred list) + (cond ((memp pred list) => car) + (else #f))) + + (define (memp pred list) + ;(check-arg procedure? pred find-tail) + (let lp ((list list)) + (and (not (null? list)) + (if (pred (car list)) list + (lp (cdr list)))))) + +(define (assp proc list) (find (lambda (entry) (proc (car entry))) list)) + +;;; LISTS is a (not very long) non-empty list of lists. +;;; Return two lists: the cars & the cdrs of the lists. +;;; However, if any of the lists is empty, just abort and return [() ()]. +(define (car+cdr pair) (values (car pair) (cdr pair))) + +(define (%cars+cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let-values ([(list other-lists) (car+cdr lists)]) + (if (null? list) (abort '() '()) ; LIST is empty -- bail out + (let-values ([(a d) (car+cdr list)] + [(cars cdrs) (recur other-lists)]) + (values (cons a cars) (cons d cdrs))))) + (values '() '())))))) + +(define (exists pred lis1 . lists) + ;(check-arg procedure? pred any) + (if (pair? lists) + + ;; N-ary case + (let-values ([(heads tails) (%cars+cdrs (cons lis1 lists))]) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (let-values ([(next-heads next-tails) (%cars+cdrs tails)]) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + + ;; Fast path + (and (not (null? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null? tail) + (pred head) ; Last PRED app is tail call. + (or (pred head) (lp (car tail) (cdr tail)))))))) + +(define (for-all pred lis1 . lists) + ;(check-arg procedure? pred every) + (if (pair? lists) + + ;; N-ary case + (let-values ([(heads tails) (%cars+cdrs (cons lis1 lists))]) + (or (not (pair? heads)) + (let lp ((heads heads) (tails tails)) + (let-values ([(next-heads next-tails) (%cars+cdrs tails)]) + (if (pair? next-heads) + (and (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + + ;; Fast path + (or (null? lis1) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null? tail) + (pred head) ; Last PRED app is tail call. + (and (pred head) (lp (car tail) (cdr tail)))))))) + +(define (fold-left kons knil lis1 . lists) + (define (%cars+cdrs+ lists cars-final) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let-values ([(list other-lists) (car+cdr lists)]) + (if (null? list) (abort '() '()) ; LIST is empty -- bail out + (let-values ([(a d) (car+cdr list)] + [(cars cdrs) (recur other-lists)]) + (values (cons a cars) (cons d cdrs))))) + (values (list cars-final) '())))))) + + ;(check-arg procedure? kons fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case + (let-values ([(cars+ans cdrs) (%cars+cdrs+ lists ans)]) + (if (null? cars+ans) ans ; Done. + (lp cdrs (apply kons cars+ans))))) + + (let lp ((lis lis1) (ans knil)) ; Fast path + (if (null? lis) ans + (lp (cdr lis) (kons (car lis) ans)))))) + + +(define (fold-right kons knil lis1 . lists) + (define (%cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null? lis) (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) + (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) + (let recur ((lists lists)) + (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) + + ;(check-arg procedure? kons fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) knil + (apply kons (%cars+ lists (recur cdrs)))))) + + (let recur ((lis lis1)) ; Fast path + (if (null? lis) knil + (let ((head (car lis))) + (kons head (recur (cdr lis)))))))) +) addfile ./libs/rnrs/load.scm hunk ./libs/rnrs/load.scm 1 +;; Nonstandard library for loading files into a +;; top-level interactive REPL environment. +;; The files may contain libraries in source form, +;; which are them dynamically loaded. + +(library (rnrs load) + (export load) + (import (rnrs) + (primitives ex:repl)) + + (define (load filename) + (define (read-file fn) + (let ((p (open-input-file fn))) + (let f ((x (read p))) + (if (eof-object? x) + (begin (close-input-port p) '()) + (cons x + (f (read p))))))) + (ex:repl (read-file filename))) + ) + addfile ./libs/rnrs/mutable.scm hunk ./libs/rnrs/mutable.scm 1 +(library (rnrs mutable-pairs (6)) + (export set-car! set-cdr!) + (import (primitives set-car! set-cdr!))) + +(library (rnrs mutable-strings (6)) + (export string-set! string-fill!) + (import (primitives string-set! string-fill!))) + addfile ./libs/rnrs/programs.scm hunk ./libs/rnrs/programs.scm 1 +(library (rnrs programs (6)) + (export command-line exit) + (import (only (gambit programs) command-line exit))) addfile ./libs/rnrs/r5rs.scm hunk ./libs/rnrs/r5rs.scm 1 +(library (rnrs r5rs (6)) + + (export null-environment scheme-report-environment delay force + exact->inexact inexact->exact quotient remainder modulo) + + (import (primitives exact->inexact inexact->exact quotient remainder modulo) + (rnrs eval) + (rnrs base) + (rnrs control)) + + (define (scheme-report-environment n) + (unless (= n 5) + (assertion-violation 'scheme-report-environment "Argument should be 5" n)) + (environment '(r5rs))) + + (define null-environment + (let ((null-env + (environment '(only (rnrs base) + begin if lambda quote set! and or + define define-syntax let-syntax letrec-syntax + let let* letrec + case cond else => + quasiquote unquote unquote-splicing + syntax-rules ...) + '(only (rnrs control) do)))) + (lambda (n) + (unless (= n 5) + (assertion-violation 'scheme-report-environment "Argument should be 5" n)) + null-env))) + + (define force + (lambda (object) + (object))) + + (define-syntax delay + (syntax-rules () + ((delay expression) + (make-promise (lambda () expression))))) + + (define make-promise + (lambda (proc) + (let ((result-ready? #f) + (result #f)) + (lambda () + (if result-ready? + result + (let ((x (proc))) + (if result-ready? + result + (begin (set! result-ready? #t) + (set! result x) + result)))))))) + ) ; rnrs r5rs + addfile ./libs/rnrs/records.scm hunk ./libs/rnrs/records.scm 1 +(library (rnrs records procedural (6)) + (export + make-record-type-descriptor record-type-descriptor? + make-record-constructor-descriptor record-constructor + record-predicate record-accessor record-mutator) + (import + (primitives + make-record-type-descriptor record-type-descriptor? + make-record-constructor-descriptor record-constructor + record-predicate record-accessor record-mutator))) + +(library (rnrs records inspection (6)) + (export + record? record-rtd record-type-name record-type-parent record-type-uid + record-type-generative? record-type-sealed? record-type-opaque? + record-type-field-names record-field-mutable?) + (import + (primitives + record? record-rtd record-type-name record-type-parent record-type-uid + record-type-generative? record-type-sealed? record-type-opaque? + record-type-field-names record-field-mutable?))) + addfile ./libs/rnrs/rnrs.scm hunk ./libs/rnrs/rnrs.scm 1 +(library (rnrs (6)) + + (export + + ;; Macros defined in core expander: + + begin if lambda quote set! and or + define define-syntax let-syntax letrec-syntax + _ ... + + ;; Derived syntax: + + let let* letrec letrec* let-values let*-values + case cond else => + assert + quasiquote unquote unquote-splicing + syntax-rules identifier-syntax + + ;; R5RS primitives: + + * + - / < <= = > >= abs acos append apply asin atan angle + boolean? call-with-current-continuation + call-with-values car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar + cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + ceiling char? char->integer char=? char? char<=? char>=? + complex? cons cos + denominator dynamic-wind + eq? equal? eqv? even? exact? exp expt floor for-each + gcd imag-part inexact? integer->char integer? + lcm length list list->string + list->vector list-ref list-tail list? log magnitude make-polar + make-rectangular make-string make-vector map max min + negative? not null? number->string number? numerator + odd? pair? + positive? procedure? rational? rationalize + real-part real? reverse round + sin sqrt string string->list string->number string->symbol + string-append + string-copy string-length string-ref string<=? string=? string>? string? substring symbol->string symbol? tan + truncate values vector vector->list + vector-fill! vector-length vector-ref vector-set! vector? zero? + + ;; R6RS additional procedures: + + real-valued? rational-valued? integer-valued? exact inexact finite? infinite? + nan? div mod div-and-mod div0 mod0 div0-and-mod0 exact-integer-sqrt boolean=? + symbol=? string-for-each vector-map vector-for-each error assertion-violation + call/cc + + ;; From (rnrs syntax-case) + + make-variable-transformer + identifier? bound-identifier=? free-identifier=? + generate-temporaries datum->syntax syntax->datum + syntax-violation syntax syntax-case quasisyntax + unsyntax unsyntax-splicing with-syntax + + ;; From (rnrs control) + + when unless do case-lambda + + ;; From (rnrs lists) + + find for-all exists filter partition fold-left fold-right + remp remove remq remv memp member memv memq + assp assoc assv assq + + ;; From (rnrs io ports) + input-port? output-port? + + ;; From (rnrs io simple) + + call-with-input-file call-with-output-file + close-input-port close-output-port current-input-port current-output-port + display eof-object? newline open-input-file open-output-file peek-char + read read-char with-input-from-file with-output-to-file write write-char + + ;; From (rnrs unicode) + + char-upcase char-downcase char-titlecase char-foldcase + char-ci=? char-ci? char-ci<=? char-ci>=? + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char-title-case? + char-general-category + + string-upcase string-downcase string-titlecase string-foldcase + string-ci=? string-ci? string-ci<=? string-ci>=? + string-normalize-nfd string-normalize-nfkd + string-normalize-nfc string-normalize-nfkc + + ;; From (rnrs sorting) + + list-sort vector-sort vector-sort! + + ;; From (rnrs records procedural) + + make-record-type-descriptor record-type-descriptor? + make-record-constructor-descriptor record-constructor + record-predicate record-accessor record-mutator + + ;; From (rnrs records inspection) + + record? record-rtd record-type-name record-type-parent record-type-uid + record-type-generative? record-type-sealed? record-type-opaque? + record-type-field-names record-field-mutable? + + ;; From (rnrs arithmetic fixnums) + + fixnum? fixnum-width least-fixnum greatest-fixnum + fx=? fx>? fx=? fx<=? + fxzero? fxpositive? fxnegative? + fxodd? fxeven? + fxmax fxmin + fx+ fx- fx* + fxdiv-and-mod fxdiv fxmod + fxdiv0-and-mod0 fxdiv0 fxmod0 + fx+/carry fx-/carry fx*/carry + fxnot fxand fxior fxxor + fxif fxbit-count fxlength + fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field fxcopy-bit-field + fxrotate-bit-field fxreverse-bit-field + fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right + + ;;; From (rnrs arithmetic flonums) + + flonum? + real->flonum + fl=? fl? fl<=? fl>=? + flinteger? flzero? flpositive? flnegative? flodd? fleven? + flfinite? flinfinite? flnan? + flmax flmin + fl+ fl* fl- fl/ + flabs + fldiv-and-mod fldiv flmod + fldiv0-and-mod0 fldiv0 flmod0 + flnumerator fldenominator + flfloor flceiling fltruncate flround + flexp fllog flsin flcos fltan flasin flacos flatan + flsqrt flexpt + fixnum->flonum + + ;; FIXME + ;; &no-infinities make-no-infinities-violation no-infinities-violation + ;; &no-nans make-no-nans-violation no-nans-violation + + ;; From (rnrs arithmetic bitwise) + + bitwise-not + bitwise-and + bitwise-ior + bitwise-xor + bitwise-if + bitwise-bit-count + bitwise-length + bitwise-first-bit-set + bitwise-bit-set? + bitwise-copy-bit + bitwise-bit-field + bitwise-copy-bit-field + bitwise-rotate-bit-field + bitwise-reverse-bit-field + bitwise-arithmetic-shift + bitwise-arithmetic-shift-left + bitwise-arithmetic-shift-right + + ;; From (rnrs files) + + file-exists? delete-file) + + (import (for (except (rnrs base) syntax-rules identifier-syntax _ ... set!) run expand) + (for (only (rnrs base) set!) run expand) + (for (core syntax-rules) run expand) + (for (core identifier-syntax) run expand) + (for (rnrs control) run expand) + (for (rnrs lists) run expand) + (for (rnrs syntax-case) run expand) + (for (except (rnrs io ports) eof-object eof-object?) run expand) + (for (rnrs io simple) run expand) + (for (rnrs unicode) run expand) + (for (rnrs sorting) run expand) + (for (rnrs records procedural) run expand) + (for (rnrs records inspection) run expand) + (for (rnrs files) run expand) + (for (rnrs arithmetic fixnums) run expand) + (for (rnrs arithmetic flonums) run expand) + (for (rnrs arithmetic bitwise) run expand) + ) + + ) ;; rnrs + addfile ./libs/rnrs/sorting.scm hunk ./libs/rnrs/sorting.scm 1 +(library (rnrs sorting (6)) + (export + (rename (list-merge-sort list-sort) (vector-merge-sort vector-sort) (vector-merge-sort! vector-sort!))) + (import + (rnrs base) + (rnrs control) + (gambit extensions)) + + +;;; list merge & list merge-sort -*- Scheme -*- +;;; Copyright (c) 1998 by Olin Shivers. +;;; This code is open-source; see the end of the file for porting and +;;; more copyright information. +;;; Olin Shivers + +;;; Exports: +;;; (list-merge < lis lis) -> list +;;; (list-merge! < lis lis) -> list +;;; (list-merge-sort < lis) -> list +;;; (list-merge-sort! < lis) -> list + +;;; A stable list merge sort of my own device +;;; Two variants: pure & destructive +;;; +;;; This list merge sort is opportunistic (a "natural" sort) -- it exploits +;;; existing order in the input set. Instead of recursing all the way down to +;;; individual elements, the leaves of the merge tree are maximal contiguous +;;; runs of elements from the input list. So the algorithm does very well on +;;; data that is mostly ordered, with a best-case time of O(n) when the input +;;; list is already completely sorted. In any event, worst-case time is +;;; O(n lg n). +;;; +;;; The destructive variant is "in place," meaning that it allocates no new +;;; cons cells at all; it just rearranges the pairs of the input list with +;;; SET-CDR! to order it. +;;; +;;; The interesting control structure is the combination recursion/iteration +;;; of the core GROW function that does an "opportunistic" DFS walk of the +;;; merge tree, adaptively subdividing in response to the length of the +;;; merges, without requiring any auxiliary data structures beyond the +;;; recursion stack. It's actually quite simple -- ten lines of code. +;;; -Olin Shivers 10/20/98 + +;;; utilties +(define (has-element list index) + (cond + ((zero? index) + (if (pair? list) + (values #t (car list)) + (values #f #f))) + ((null? list) + (values #f #f)) + (else + (has-element (cdr list) (- index 1))))) + +(define (list-ref-or-default list index default) + (call-with-values + (lambda () (has-element list index)) + (lambda (has? maybe) + (if has? + maybe + default)))) + +(define (vector-start+end vector maybe-start+end) + (let ((start (list-ref-or-default maybe-start+end + 0 0)) + (end (list-ref-or-default maybe-start+end + 1 (vector-length vector)))) + (values start end))) + +(define (vector-portion-copy! target src start end) + (let ((len (- end start))) + (do ((i (- len 1) (- i 1)) + (j (- end 1) (- j 1))) + ((< i 0)) + (vector-set! target i (vector-ref src j))))) + + +;;; (list-merge-sort < lis) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; A natural, stable list merge sort. +;;; - natural: picks off maximal contiguous runs of pre-ordered data. +;;; - stable: won't invert the order of equal elements in the input list. + +(define (list-merge-sort elt< lis) + + ;; (getrun lis) -> run runlen rest + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Pick a run of non-decreasing data off of non-empty list LIS. + ;; Return the length of this run, and the following list. + (define (getrun lis) + (let lp ((ans '()) (i 1) (prev (car lis)) (xs (cdr lis))) + (if (pair? xs) + (let ((x (car xs))) + (if (elt< x prev) + (values (append-reverse ans (cons prev '())) i xs) + (lp (cons prev ans) (+ i 1) x (cdr xs)))) + (values (append-reverse ans (cons prev '())) i xs)))) + + (define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) + + (define (null-list? l) + (cond ((pair? l) #f) + ((null? l) #t) + (else (error "null-list?: argument out of domain" l)))) + + ;; (merge a b) -> list + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; List merge -- stably merge lists A (length > 0) & B (length > 0). + ;; This version requires up to |a|+|b| stack frames. + (define (merge a b) + (let recur ((x (car a)) (a a) + (y (car b)) (b b)) + (if (elt< y x) + (cons y (let ((b (cdr b))) + (if (pair? b) + (recur x a (car b) b) + a))) + (cons x (let ((a (cdr a))) + (if (pair? a) + (recur (car a) a y b) + b)))))) + + ;; (grow s ls ls2 u lw) -> [a la unused] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; The core routine. Read the next 20 lines of comments & all is obvious. + ;; - S is a sorted list of length LS > 1. + ;; - LS2 is some power of two <= LS. + ;; - U is an unsorted list. + ;; - LW is a positive integer. + ;; Starting with S, and taking data from U as needed, produce + ;; a sorted list of *at least* length LW, if there's enough data + ;; (LW <= LS + length(U)), or use all of U if not. + ;; + ;; GROW takes maximal contiguous runs of data from U at a time; + ;; it is allowed to return a list *longer* than LW if it gets lucky + ;; with a long run. + ;; + ;; The key idea: If you want a merge operation to "pay for itself," the two + ;; lists being merged should be about the same length. Remember that. + ;; + ;; Returns: + ;; - A: The result list + ;; - LA: The length of the result list + ;; - UNUSED: The unused tail of U. + + (define (grow s ls ls2 u lw) ; The core of the sort algorithm. + (if (or (<= lw ls) (not (pair? u))) ; Met quota or out of data? + (values s ls u) ; If so, we're done. + (let*-values (((ls2) (let lp ((ls2 ls2)) + (let ((ls2*2 (+ ls2 ls2))) + (if (<= ls2*2 ls) (lp ls2*2) ls2)))) + ;; LS2 is now the largest power of two <= LS. + ;; (Just think of it as being roughly LS.) + ((r lr u2) (getrun u)) ; Get a run, then + ((t lt u3) (grow r lr 1 u2 ls2))) ; grow it up to be T. + (grow (merge s t) (+ ls lt) ; Merge S & T, + (+ ls2 ls2) u3 lw)))) ; and loop. + + ;; Note: (LENGTH LIS) or any constant guaranteed + ;; to be greater can be used in place of INFINITY. + (if (pair? lis) ; Don't sort an empty list. + (let*-values (((r lr tail) (getrun lis)) ; Pick off an initial run, + ((infinity) #o100000000) ; then grow it up maximally. + ((a la v) (grow r lr 1 tail infinity))) + a) + '())) + + + +;;; (vector-merge-sort < v [start end temp]) -> vector +;;; (vector-merge-sort! < v [start end temp]) -> unspecific +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Stable natural vector merge sort + +(define (vector-merge-sort! < v . maybe-args) + (call-with-values + (lambda () (vector-start+end v maybe-args)) + (lambda (start end) + (let ((temp (if (and (pair? maybe-args) ; kludge + (pair? (cdr maybe-args)) + (pair? (cddr maybe-args))) + (caddr maybe-args) + (vector-copy v)))) + (%vector-merge-sort! < v start end temp))))) + +(define (vector-merge-sort < v . maybe-args) + (let ((ans (vector-copy v))) + (apply vector-merge-sort! < ans maybe-args) + ans)) + + +;;; %VECTOR-MERGE-SORT! is not exported. +;;; Preconditions: +;;; V TEMP vectors +;;; START END fixnums +;;; START END legal indices for V and TEMP +;;; If these preconditions are ensured by the cover functions, you +;;; can safely change this code to use unsafe fixnum arithmetic and vector +;;; indexing ops, for *huge* speedup. + +;;; This merge sort is "opportunistic" -- the leaves of the merge tree are +;;; contiguous runs of already sorted elements in the vector. In the best +;;; case -- an already sorted vector -- it runs in linear time. Worst case +;;; is still O(n lg n) time. + +(define (%vector-merge-sort! elt< v0 l r temp0) + (define (xor a b) (not (eq? a b))) + + ;; Merge v1[l,l+len1) and v2[l+len1,l+len1+len2) into target[l,l+len1+len2) + ;; Merge left-to-right, so that TEMP may be either V1 or V2 + ;; (that this is OK takes a little bit of thought). + ;; V2=TARGET? is true if V2 and TARGET are the same, which allows + ;; merge to punt the final blit half of the time. + + (define (merge target v1 v2 l len1 len2 v2=target?) + (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to TARGET[I,?] + (let lp ((j j) (i i)) ; J < END. The final copy. + (vector-set! target i (vector-ref fromv j)) + (let ((j (+ j 1))) + (if (< j end) (lp j (+ i 1)))))))) + + (let* ((r1 (+ l len1)) + (r2 (+ r1 len2))) + ; Invariants: + (let lp ((n l) ; N is next index of + (j l) (x (vector-ref v1 l)) ; TARGET to write. + (k r1) (y (vector-ref v2 r1))) ; X = V1[J] + (let ((n+1 (+ n 1))) ; Y = V2[K] + (if (elt< y x) + (let ((k (+ k 1))) + (vector-set! target n y) + (if (< k r2) + (lp n+1 j x k (vector-ref v2 k)) + (vblit v1 j n+1 r1))) + (let ((j (+ j 1))) + (vector-set! target n x) + (if (< j r1) + (lp n+1 j (vector-ref v1 j) k y) + (if (not v2=target?) (vblit v2 k n+1 r2)))))))))) + + + ;; Might hack GETRUN so that if the run is short it pads it out to length + ;; 10 with insert sort... + + ;; Precondition: l < r. + (define (getrun v l r) + (let lp ((i (+ l 1)) (x (vector-ref v l))) + (if (>= i r) + (- i l) + (let ((y (vector-ref v i))) + (if (elt< y x) + (- i l) + (lp (+ i 1) y)))))) + + ;; RECUR: Sort V0[L,L+LEN) for some LEN where 0 < WANT <= LEN <= (R-L). + ;; That is, sort *at least* WANT elements in V0 starting at index L. + ;; May put the result into either V0[L,L+LEN) or TEMP0[L,L+LEN). + ;; Must not alter either vector outside this range. + ;; Return: + ;; - LEN -- the number of values we sorted + ;; - ANSVEC -- the vector holding the value + ;; - ANS=V0? -- tells if ANSVEC is V0 or TEMP + ;; + ;; LP: V[L,L+PFXLEN) holds a sorted prefix of V0. + ;; TEMP = if V = V0 then TEMP0 else V0. (I.e., TEMP is the other vec.) + ;; PFXLEN2 is a power of 2 <= PFXLEN. + ;; Solve RECUR's problem. + (if (< l r) ; Don't try to sort an empty range. + (call-with-values + (lambda () + (let recur ((l l) (want (- r l))) + (let ((len (- r l))) + (let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1) + (v v0) (temp temp0) + (v=v0? #t)) + (if (or (>= pfxlen want) (= pfxlen len)) + (values pfxlen v v=v0?) + (let ((pfxlen2 (let lp ((j pfxlen2)) + (let ((j*2 (+ j j))) + (if (<= j pfxlen) (lp j*2) j)))) + (tail-len (- len pfxlen))) + ;; PFXLEN2 is now the largest power of 2 <= PFXLEN. + ;; (Just think of it as being roughly PFXLEN.) + (call-with-values + (lambda () + (recur (+ pfxlen l) pfxlen2)) + (lambda (nr-len nr-vec nrvec=v0?) + (merge temp v nr-vec l pfxlen nr-len + (xor nrvec=v0? v=v0?)) + (lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2) + temp v (not v=v0?)))))))))) + (lambda (ignored-len ignored-ansvec ansvec=v0?) + (if (not ansvec=v0?) (vector-portion-copy! v0 temp0 l r)))))) + + +;;; Copyright +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is +;;; Copyright (c) 1998 by Olin Shivers. +;;; The terms are: You may do as you please with this code, as long as +;;; you do not delete this notice or hold me responsible for any outcome +;;; related to its use. +;;; +;;; Blah blah blah. Don't you think source files should contain more lines +;;; of code than copyright notice? + + +;;; Code tuning & porting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This code is *tightly* bummed as far as I can go in portable Scheme. +;;; +;;; The two internal primitives that do the real work can be converted to +;;; use unsafe vector-indexing and fixnum-specific arithmetic ops *if* you +;;; alter the four small cover functions to enforce the invariants. This should +;;; provide *big* speedups. In fact, all the code bumming I've done pretty +;;; much disappears in the noise unless you have a good compiler and also +;;; can dump the vector-index checks and generic arithmetic -- so I've really +;;; just set things up for you to exploit. +;;; +;;; The optional-arg parsing, defaulting, and error checking is done with a +;;; portable R4RS macro. But if your Scheme has a faster mechanism (e.g., +;;; Chez), you should definitely port over to it. Note that argument defaulting +;;; and error-checking are interleaved -- you don't have to error-check +;;; defaulted START/END args to see if they are fixnums that are legal vector +;;; indices for the corresponding vector, etc. +) addfile ./libs/rnrs/syntax-case.scm hunk ./libs/rnrs/syntax-case.scm 1 +(library (rnrs syntax-case (6)) + + (export make-variable-transformer + identifier? bound-identifier=? free-identifier=? + generate-temporaries datum->syntax syntax->datum + syntax-violation syntax syntax-case quasisyntax + unsyntax unsyntax-splicing with-syntax + _ ...) + + (import (core primitives) + (core with-syntax) + (core quasisyntax)) + + ) ;; rnrs syntax-case + addfile ./libs/rnrs/unicode.scm hunk ./libs/rnrs/unicode.scm 1 +(library (rnrs unicode (6)) + + (export + char-upcase char-downcase char-titlecase char-foldcase + char-ci=? char-ci? char-ci<=? char-ci>=? + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char-title-case? + char-general-category + string-upcase string-downcase string-titlecase string-foldcase + string-ci=? string-ci? string-ci<=? string-ci>=? + string-normalize-nfd string-normalize-nfkd + string-normalize-nfc string-normalize-nfkc) + + (import + (primitives + char-upcase char-downcase char-titlecase char-foldcase + char-ci=? char-ci? char-ci<=? char-ci>=? + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char-title-case? + char-general-category + string-upcase string-downcase string-titlecase string-foldcase + string-ci=? string-ci? string-ci<=? string-ci>=? + string-normalize-nfd string-normalize-nfkd + string-normalize-nfc string-normalize-nfkc)) + ) + adddir ./libs/srfi addfile ./libs/srfi/srfi-0.scm hunk ./libs/srfi/srfi-0.scm 1 +;copied cond-expand from gambit's syntax-case system +;TODO use the one built into gambit or better yet create a new one +(library (srfi-0) + (export cond-expand) + (import (rnrs base)) + +(define-syntax cond-expand + (syntax-rules (and or not else srfi-0 srfi-30 gambit) + ((cond-expand) (syntax-error "Unfulfilled cond-expand")) + ((cond-expand (else body ...)) + (begin body ...)) + ((cond-expand ((and) body ...) more-clauses ...) + (begin body ...)) + ((cond-expand ((and req1 req2 ...) body ...) more-clauses ...) + (cond-expand + (req1 + (cond-expand + ((and req2 ...) body ...) + more-clauses ...)) + more-clauses ...)) + ((cond-expand ((or) body ...) more-clauses ...) + (cond-expand more-clauses ...)) + ((cond-expand ((or req1 req2 ...) body ...) more-clauses ...) + (cond-expand + (req1 + (begin body ...)) + (else + (cond-expand + ((or req2 ...) body ...) + more-clauses ...)))) + ((cond-expand ((not req) body ...) more-clauses ...) + (cond-expand + (req + (cond-expand more-clauses ...)) + (else body ...))) + ((cond-expand (srfi-0 body ...) more-clauses ...) + (begin body ...)) + ((cond-expand (gambit body ...) more-clauses ...) + (begin body ...)) + ((cond-expand (feature-id body ...) more-clauses ...) + (cond-expand more-clauses ...)))) +) addfile ./libs/srfi/srfi-18.scm hunk ./libs/srfi/srfi-18.scm 1 +;srfi-18 is a subset of srfi-21 +(library (srfi-18) + (export current-thread make-thread thread? thread-name thread-specific thread-specific-set! thread-start! thread-sleep! thread-yield! thread-terminate! thread-join! make-mutex mutex? mutex-name mutex-specific mutex-specific-set! mutex-state mutex-lock! mutex-unlock! condition-variable? make-condition-variable condition-variable-name condition-variable-specific condition-variable-specific-set! condition-variable-signal! condition-variable-broadcast! current-time time? time->seconds seconds->time current-exception-handler with-exception-handler raise join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? uncaught-exception? uncaught-exception-reason) + (import (srfi-21))) + addfile ./libs/srfi/srfi-2.scm hunk ./libs/srfi/srfi-2.scm 1 +;;;AND-LET srfi-2 +;;;This is copied from ssax library + +; AND-LET* -- an AND with local bindings, a guarded LET* special form +; +; AND-LET* (formerly know as LAND*) is a generalized AND: it evaluates +; a sequence of forms one after another till the first one that yields +; #f; the non-#f result of a form can be bound to a fresh variable and +; used in the subsequent forms. +; It is defined in SRFI-2 +; This macro re-writes the and-let* form into a combination of +; 'and' and 'let'. +; See vland.scm for the denotational semantics and +; extensive validation tests. +(library (srfi-2) + (export and-let*) + (import (rnrs base)) + +(define-syntax and-let* + (syntax-rules () + ((_ ()) #t) + ((_ claws) ; no body + ; re-write (and-let* ((claw ... last-claw)) ) into + ; (and-let* ((claw ...)) body) with 'body' derived from the last-claw + (and-let* "search-last-claw" () claws)) + ((_ "search-last-claw" first-claws ((exp))) + (and-let* first-claws exp)) ; (and-let* (... (exp)) ) + ((_ "search-last-claw" first-claws ((var exp))) + (and-let* first-claws exp)) ; (and-let* (... (var exp)) ) + ((_ "search-last-claw" first-claws (var)) + (and-let* first-claws var)) ; (and-let* (... var) ) + ((_ "search-last-claw" (first-claw ...) (claw . rest)) + (and-let* "search-last-claw" (first-claw ... claw) rest)) + + ; now 'body' is present + ((_ () . body) (begin . body)) ; (and-let* () form ...) + ((_ ((exp) . claws) . body) ; (and-let* ( (exp) claw... ) body ...) + (and exp (and-let* claws . body))) + ((_ ((var exp) . claws) . body) ; (and-let* ((var exp) claw...)body...) + (let ((var exp)) (and var (and-let* claws . body)))) + ((_ (var . claws) . body) ; (and-let* ( var claw... ) body ...) + (and var (and-let* claws . body))) +))) addfile ./libs/srfi/srfi-21.scm hunk ./libs/srfi/srfi-21.scm 1 +;subset of gambit threads +(library (srfi-21) + (export + ;;threads + current-thread make-thread thread? thread-name thread-specific thread-specific-set! thread-base-priority thread-base-priority-set! thread-priority-boost thread-priority-boost-set! thread-quantum thread-quantum-set! thread-start! thread-sleep! thread-yield! thread-terminate! thread-join! + ;;mutexes + make-mutex mutex? mutex-name mutex-specific mutex-specific-set! mutex-state mutex-lock! mutex-unlock! + ;;condition-variables + condition-variable? make-condition-variable condition-variable-name condition-variable-specific condition-variable-specific-set! condition-variable-signal! condition-variable-broadcast! + ;time + current-time time? time->seconds seconds->time + ;exceptions and exception handling + current-exception-handler with-exception-handler raise join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? uncaught-exception? uncaught-exception-reason) + (import (gambit threads) + (gambit time) + (gambit exceptions))) + addfile ./libs/srfi/srfi-23.scm hunk ./libs/srfi/srfi-23.scm 1 +;srfi-23 in terms of r6rs +(library (srfi-23) + (export error) + (import (except (rnrs base (6)) error) + (rename (rnrs base (6)) (error rnrs:error))) + +(define (error message . args) + (apply rnrs:error #f message args))) addfile ./libs/srfi/srfi-27.scm hunk ./libs/srfi/srfi-27.scm 1 + +(library (srfi-27) + (export random-integer random-real random-source-make-integers random-source-make-reals random-source-pseudo-randomize! random-source-randomize! random-source-state-ref random-source-state-set! random-source? make-random-source) + (import (primitives random-integer random-real random-source-make-integers random-source-make-reals random-source-pseudo-randomize! random-source-randomize! random-source-state-ref random-source-state-set! random-source? make-random-source))) addfile ./libs/srfi/srfi-39.scm hunk ./libs/srfi/srfi-39.scm 1 +(library (srfi-39) + (export make-parameter parameterize) + (import + (rnrs base) + (primitives make-parameter ##parameterize-build)) +;(##parameterize param val thunk) +(define-syntax parameterize + (syntax-rules () + ((parametrize bindings body . rest) + (##parameterize-build (cons 'parameterize (cons bindings (cons body rest)))))))) + addfile ./libs/srfi/srfi-4.scm hunk ./libs/srfi/srfi-4.scm 1 +(library (srfi-4) + +(export + ;s8 +s8vector s8vector->list s8vector-append s8vector-copy s8vector-fill! list->s8vector s8vector-length s8vector-ref s8vector-set! make-s8vector s8vector? subs8vector + ;u8 +u8vector u8vector->list u8vector-append u8vector-copy u8vector-fill! make-u8vector u8vector-length u8vector-ref u8vector-set! list->u8vector u8vector? subu8vector +;u16 +u16vector u16vector->list u16vector-append u16vector-copy u16vector-fill! list->u16vector u16vector-length u16vector-ref u16vector-set! make-u16vector subu16vector u16vector? + ;s16 +s16vector s16vector->list s16vector-append s16vector-copy s16vector-fill! make-s16vector s16vector-length s16vector-ref s16vector-set! subs16vector s16vector? list->s16vector + ;u32 +u32vector u32vector->list u32vector-append u32vector-copy u32vector-fill! list->u32vector u32vector-length u32vector-ref u32vector-set! make-u32vector u32vector? subu32vector + ;s32 +s32vector s32vector->list s32vector-append s32vector-copy s32vector-fill! list->s32vector s32vector-length s32vector-ref s32vector-set! make-s32vector s32vector? subs32vector + ;s64 +s64vector s64vector->list s64vector-append s64vector-copy s64vector-fill! list->s64vector s64vector-length s64vector-ref s64vector-set! make-s64vector s64vector? subs64vector + ;u64 +u64vector u64vector->list u64vector-append u64vector-copy u64vector-fill! list->u64vector u64vector-length u64vector-ref u64vector-set! make-u64vector u64vector? subu64vector + ;f32 +f32vector f32vector->list f32vector-append f32vector-copy f32vector-fill! f32vector-length f32vector-ref f32vector-set! f32vector? subf32vector list->f32vector make-f32vector + ;f64 +f64vector f64vector->list f64vector-append f64vector-copy f64vector-fill! subf64vector f64vector-length f64vector-ref f64vector-set! f64vector? list->f64vector make-f64vector) +(import (gambit bytevectors))) addfile ./libs/srfi/srfi-6.scm hunk ./libs/srfi/srfi-6.scm 1 +(library (srfi-6) + (export get-output-string open-input-string open-output-string) + (import (gambit io))) addfile ./libs/srfi/srfi-8.scm hunk ./libs/srfi/srfi-8.scm 1 + +(library (srfi-8) + (export receive) + (import (rnrs base (6))) + + (define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...)))))) addfile ./libs/srfi/srfi-88.scm hunk ./libs/srfi/srfi-88.scm 1 +(library (srfi-88) + (export keyword? keyword->string string->keyword) + (import (only (gambit extensions) keyword? keyword->string string->keyword))) addfile ./libs/srfi/srfi-89.scm hunk ./libs/srfi/srfi-89.scm 1 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;Copyright (C) Marc Feeley (2006). All Rights Reserved. +;;;; +;;;;Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: +;;;; +;;;;The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. +;;;; +;;;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(library (srfi-89 keywords) + (export $undefined $req-key $opt-key $process-keys $hash-keyword make-perfect-hash-table $perfect-hash-table-lookup keyword?) + (import + (rnrs base) + (rnrs r5rs) + (srfi-88) + (gambit extensions)) + + ; Handling of named parameters. + + (define $undefined (void)) + + (define ($req-key key-values i) + (let ((val (vector-ref key-values i))) + (if (eq? val $undefined) + (error "a required named parameter was not provided") + val))) + + (define ($opt-key key-values i default) + (let ((val (vector-ref key-values i))) + (if (eq? val $undefined) + (default) + val))) + + (define ($process-keys args key-hash-table key-values) + (let loop ((args args)) + (if (null? args) + args + (let ((k (car args))) + (if (not (keyword? k)) + args + (let ((i ($perfect-hash-table-lookup key-hash-table k))) + (if (not i) + (error "unknown parameter keyword" k) + (if (null? (cdr args)) + (error "a value was expected after keyword" k) + (begin + (if (eq? (vector-ref key-values i) $undefined) + (vector-set! key-values i (cadr args)) + (error "duplicate parameter" k)) + (loop (cddr args))))))))))) + + ;------------------------------------------------------------------------------ + + ; Procedures needed at expansion time. + + (define ($hash-keyword key n) + (let ((str (keyword->string key))) + (let loop ((h 0) (i 0)) + (if (< i (string-length str)) + (loop (modulo (+ (* h 65536) (char->integer (string-ref str i))) + n) + (+ i 1)) + h)))) + (define (make-perfect-hash-table alist) + + ; "alist" is a list of pairs of the form "(keyword . value)" + + ; The result is a perfect hash-table represented as a vector of + ; length 2*N, where N is the hash modulus. If the keyword K is in + ; the hash-table it is at index + ; + ; X = (* 2 ($hash-keyword K N)) + ; + ; and the associated value is at index X+1. + + (let loop1 ((n (length alist))) + (let ((v (make-vector (* 2 n) #f))) + (let loop2 ((lst alist)) + (if (pair? lst) + (let* ((key-val (car lst)) + (key (car key-val))) + (let ((x (* 2 ($hash-keyword key n)))) + (if (vector-ref v x) + (loop1 (+ n 1)) + (begin + (vector-set! v x key) + (vector-set! v (+ x 1) (cdr key-val)) + (loop2 (cdr lst)))))) + v))))) + + (define ($perfect-hash-table-lookup table key) + (let* ((n (quotient (vector-length table) 2)) + (x (* 2 ($hash-keyword key n)))) + (and (eq? (vector-ref table x) key) + (vector-ref table (+ x 1))))) +) + +(library (srfi-89) + (export define* lambda* $opt-key $req-key $process-keys) + (import + (for (srfi-89 keywords) expand run) + (for (rnrs base) expand run) + (for (rnrs lists) expand run) + (for (rnrs syntax-case) expand run) + (for (gambit debug) expand run) + ) + + + (define-syntax lambda* + (lambda (x) + + (define (parse-formals formals) + (define (variable? x) (symbol? x)) + (define (required-positional? x) (variable? x)) + (define (optional-positional? x) (and (pair? x) (pair? (cdr x)) (null? (cddr x)) (variable? (car x)))) + (define (required-named? x) (and (pair? x) (pair? (cdr x)) (null? (cddr x)) (keyword? (car x)) (variable? (cadr x)))) + (define (optional-named? x) (and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (null? (cdddr x)) (keyword? (car x)) (variable? (cadr x)))) + (define (named? x) (or (required-named? x) (optional-named? x))) + + (define (duplicates? lst) + (cond ((null? lst) #f) + ((memq (car lst) (cdr lst)) #t) + (else (duplicates? (cdr lst))))) + + (define (parse-positional-section lst cont) + (let loop1 ((lst lst) (rev-reqs '())) + (if (and (pair? lst) + (required-positional? (car lst))) + (loop1 (cdr lst) (cons (car lst) rev-reqs)) + (let loop2 ((lst lst) (rev-opts '())) + (if (and (pair? lst) + (optional-positional? (car lst))) + (loop2 (cdr lst) (cons (car lst) rev-opts)) + (cont lst (cons (reverse rev-reqs) (reverse rev-opts)))))))) + + (define (parse-named-section lst cont) + (let loop ((lst lst) (rev-named '())) + (if (and (pair? lst) + (named? (car lst))) + (loop (cdr lst) (cons (car lst) rev-named)) + (cont lst (reverse rev-named))))) + + (define (parse-rest lst positional-before-named? positional-reqs/opts named) + (if (null? lst) + (parse-end positional-before-named? + positional-reqs/opts + named + #f) + (if (variable? lst) + (parse-end positional-before-named? + positional-reqs/opts + named + lst) + (error "syntax error in formal parameter list")))) + + (define (parse-end positional-before-named? positional-reqs/opts named rest) + (let ((positional-reqs (car positional-reqs/opts)) + (positional-opts (cdr positional-reqs/opts))) + (let ((vars + (append positional-reqs + (map car positional-opts) + (map cadr named) + (if rest (list rest) '()))) + (keys (map car named))) + (cond ((duplicates? vars) + (error "duplicate variable in formal parameter list")) + ((duplicates? keys) + (error "duplicate keyword in formal parameter list")) + (else + (list positional-before-named? + positional-reqs + positional-opts + named + rest)))))) + + (define (parse lst) + (if (and (pair? lst) + (named? (car lst))) + (parse-named-section + lst + (lambda (lst named) + (parse-positional-section + lst + (lambda (lst positional-reqs/opts) + (parse-rest lst + #f + positional-reqs/opts + named))))) + (parse-positional-section + lst + (lambda (lst positional-reqs/opts) + (parse-named-section + lst + (lambda (lst named) + (parse-rest lst + #t + positional-reqs/opts + named))))))) + + (parse formals)) + + (define (expand-lambda* formals body) + + (define (range lo hi) + (if (< lo hi) + (cons lo (range (+ lo 1) hi)) + '())) + + (define (expand positional-before-named? + positional-reqs + positional-opts + named + rest) + (if (and (null? positional-opts) (null? named)) ; direct R5RS equivalent + + `(lambda ,(append positional-reqs (or rest '())) ,@body) + + (let () + + (define utility-fns + `(,@(if (or positional-before-named? + (null? positional-reqs)) + `() + `(($req + (lambda () + (if (pair? $args) + (let ((arg (car $args))) + (set! $args (cdr $args)) + arg) + (error "too few actual parameters")))))) + ,@(if (null? positional-opts) + `() + `(($opt + (lambda (default) + (if (pair? $args) + (let ((arg (car $args))) + (set! $args (cdr $args)) + arg) + (default)))))))) + + (define positional-bindings + `(,@(if positional-before-named? + `() + (map (lambda (x) `(,x ($req))) positional-reqs)) + ,@(map (lambda (x) `(,(car x) ($opt (lambda () ,(cadr x))))) positional-opts))) + + (define named-bindings + (if (null? named) + `() + `(($key-values (vector ,@(map (lambda (x) $undefined) named))) + ($args + ($process-keys + $args + ',(make-perfect-hash-table + (map (lambda (x i) + (cons (car x) i)) + named + (range 0 (length named)))) + $key-values)) + ,@(map (lambda (x i) + `(,(cadr x) + ,(if (null? (cddr x)) + `($req-key $key-values ,i) + `($opt-key $key-values ,i (lambda () + ,(caddr x)))))) + named + (range 0 (length named)))))) + + (define rest-binding + (if (not rest) + `(($args (or (null? $args) + (error "too many actual parameters")))) + `((,rest $args)))) + + (let ((bindings + (append (if positional-before-named? + (append utility-fns + positional-bindings + named-bindings) + (append named-bindings + utility-fns + positional-bindings)) + rest-binding))) + `(lambda ,(append (if positional-before-named? + positional-reqs + '()) + '$args) + (let* ,bindings + ,@body)))))) + + (apply expand (parse-formals formals))) + (syntax-case x () + ((lambda* formals . body) + (datum->syntax #'lambda* (expand-lambda* (syntax->datum #'formals) + (syntax->datum #'body))))))) + + (define-syntax define* + (lambda (x) + (syntax-case x () + ((define* (name formals ...) body ...) + (datum->syntax #'define* (syntax->datum #'(define name (lambda* (formals ...) body ...))))) + ((_ name body) + #'(define name body))))) +) addfile ./libs/srfi/srfi-9.scm hunk ./libs/srfi/srfi-9.scm 1 +;SRFI-9 in terms of rnrs records +(library (srfi-9) + (export define-record-type) + (import (for (rnrs records procedural (6)) expand run) + (for (rnrs syntax-case) expand run) + (for (rnrs base) expand run) + ) + +(define-syntax define-record-type + (lambda (x) + (define (make-field-defs x) + (syntax-case x () + ((f field-name accessor) + (eq? 'field (syntax->datum #'f)) + #''(immutable field-name)) + + ((f field-name accessor mutator) + (eq? 'field (syntax->datum #'f)) + #''(mutable field-name)) + + ((form form2 ) + #`(#,(make-field-defs #`(field #,@(syntax form))) + #,(make-field-defs #`(field #,@(syntax form2))))) + ((form forms ...) + #`(#,(make-field-defs #`(field #,@(syntax form))) + #,@(make-field-defs #'(forms ...)))))) + + (define (make-field-procs type index field-forms) + (syntax-case field-forms () + ((f field-name accessor) + (eq? 'field (syntax->datum #'f)) + #`((define accessor (record-accessor #,type #,index)))) + ((f field-name accessor mutator) + (eq? 'field (syntax->datum #'f)) + #`((define accessor (record-accessor #,type #,index)) + (define mutator (record-mutator #,type #,index)))) + ((form form2 ) + #`(#,@(make-field-procs type index #`(field #,@(syntax form))) + #,@(make-field-procs type (+ index 1) #`(field #,@(syntax form2))))) + ((form forms ...) + #`(#,@(make-field-procs type index #`(field #,@(syntax form ))) + #,@(make-field-procs type (+ index 1) #'(forms ...)))))) + + (syntax-case x () + ((_ type (constructor-name . constructor-fields) predicate fields ...) + #`(begin + (define type (make-record-type-descriptor 'type #f #f #f #f (vector #,@(make-field-defs #'(fields ...))))) + (define constructor-name (record-constructor (make-record-constructor-descriptor type #f #f))) + (define predicate (record-predicate type)) + #,@(make-field-procs #'type 0 #'(fields ...))))))) +) + addfile ./runtime.scm hunk ./runtime.scm 1 +;;; +;;; Runtime include file: +;;; Contains the minimal set of binding necessary +;;; for running a fully expanded program. +;;; + +(define ex:unspecified (if #f #f)) + +(define (ex:make-library name envs exports imports builds visiter invoker build) + (list name envs exports imports builds visiter invoker build)) + +(define (ex:library-name lib) (car lib)) +(define (ex:library-envs lib) (cadr lib)) +(define (ex:library-exports lib) (caddr lib)) +(define (ex:library-imports lib) (cadddr lib)) +(define (ex:library-builds lib) (car (cddddr lib))) +(define (ex:library-visiter lib) (car (cdr (cddddr lib)))) +(define (ex:library-invoker lib) (car (cdr (cdr (cddddr lib))))) +(define (ex:library-build lib) (car (cdr (cdr (cdr (cddddr lib)))))) + +(define (ex:import-libraries-for imports builds phase importer) + (let ((imported '())) + (define (import-libraries imports builds phase) + (for-each (lambda (import build) + (let ((name (car import)) + (levels (cdr import))) + (for-each (lambda (level) + (import-library name build (+ phase level))) + levels))) + imports + builds) + (values)) + (define (import-library name build phase) + (if (not (member (cons name phase) imported)) + (let ((library (ex:lookup-library name))) + (or (not build) + (eq? build (ex:library-build library)) + (assertion-violation + 'import "Client was expanded against a different build of this library" name)) + (import-libraries (ex:library-imports library) + (ex:library-builds library) + phase) + (importer library phase imported) + (set! imported (cons (cons name phase) imported))))) + (import-libraries imports builds phase))) + +(define (ex:import-libraries-for-run imports builds phase) + (ex:import-libraries-for imports + builds + phase + (lambda (library phase imported) + (if (= phase 0) + ((ex:library-invoker library)))))) + +(define ex:register-library! #f) +(define ex:lookup-library #f) +(let ((table '())) + (set! ex:register-library! + (lambda (library) + (set! table (cons library table)))) + (set! ex:lookup-library + (lambda (name) + (let ((library (assoc name table))) + (if library + library + (assertion-violation 'lookup-library "Library not loaded" name)))))) + +;; Only instantiate part of the bootstrap library +;; that would be needed for invocation at runtime. + +(ex:register-library! + (let ((error (lambda () + (assertion-violation + 'runtime.scm + "Attempt to use runtime instance of (core primitive-macros) for expansion. Make sure expander.scm is loaded after runtime.scm.")))) + (ex:make-library + '(core primitive-macros) + ;; envs + error + ;; exports + '() + ;; imported-libraries + '() + ;; builds + '() + ;; visiter + error + ;; invoker + (lambda () (values)) + ;; build + 'system))) adddir ./test addfile ./test/examples.scm hunk ./test/examples.scm 1 +;;;===================================================================== +;;; +;;; Examples and tests: +;;; +;;; Copyright (c) 2006 Andre van Tonder +;;; +;;; Copyright statement at http://srfi.schemers.org/srfi-process.html +;;; +;;;===================================================================== + +;; Uncomment whichever is applicable or provide your own. +;; Compat-r5rs.scm should run on most r5rs-compliant Schemes. + +;(load "compat-r5rs.scm") +;(load "compat-gambit.scm") +; (load "compat-mzscheme.scm") +;; (load "compat-larceny.scm") +;; (load "compat-chez.scm") +;(load "compat-scheme48.scm") ; but first ,open structures listed in this file + +;;====================================================================== +;; +;; Initialize the system: +;; +;;====================================================================== + +;(load "runtime.scm") +;(load "expander.scm") +;; Compile standard libraries. +;; This only needs to be done once. +;(ex:expand-file "standard-libraries.scm" "standard-libraries.exp") +;(load "standard-libraries.exp") +(load "../r6rs.o1") +;;====================================================================== +;; +;; REPL SESSION: +;; +;; (Examples of static compilation scripts are at the end of this file). +;; +;; The REPL goes beyond r6rs to allow incremental development in +;; a toplevel environment. The developer can freely change, replace +;; and make new toplevel definitions, evaluate toplevel expressions, +;; enter libraries and at the prompt, +;; dynamically load library definitions from files and import +;; library bindings into the toplevel environment. +;; +;;====================================================================== + +(ex:repl + '( + ;; Make rnrs available at toplevel: + + (import (rnrs)) + + ;;;===================================================================== + ;;; + ;;; LIBRARIES AND PROGRAMS: + ;;; + ;;; The file standard-libraries.scm builds r6rs up using a sequence + ;;; of r6rs libraries. It constitutes a nontrivial example, + ;;; tutorial and test of the library system. + ;;; + ;;; Here are some further tests and examples: + ;;; + ;;;===================================================================== + + ;;;==================================================== + ;;; + ;;; R6RS library examples. + ;;; + ;;;==================================================== + + (library (stack) + (export make push! pop! empty!) + (import (rnrs) + (rnrs mutable-pairs)) + + (define (make) + (list '())) + + (define (push! s v) + (set-car! s (cons v (car s)))) + + (define (pop! s) + (let ((v (caar s))) (set-car! s (cdar s)) v)) + + (define (empty! s) + (set-car! s '())) + ) + + (library (balloons) + (export make push pop) + (import (rnrs)) + + (define (make w h) + (cons w h)) + + (define (push b amt) + (cons (- (car b) amt) (+ (cdr b) amt))) + + (define (pop b) + (display "Boom! ") + (display (* (car b) (cdr b))) + (newline)) + ) + + (library (party) + (export (rename (balloon:make make) (balloon:push push)) + push! make-party + (rename (party-pop! pop!))) + (import (rnrs) + (only (stack) make push! pop!) ;; not empty! + (prefix (balloons) balloon:)) + + ;; Creates a party as a stack of balloons, starting with + ;; two balloons + (define (make-party) + (let ((s (make))) ;; from stack + (push! s (balloon:make 10 10)) + (push! s (balloon:make 12 9)) s)) + + (define (party-pop! p) + (balloon:pop (pop! p))) + ) + + (library (main) + (export) + (import (rnrs) (party)) + (define p (make-party)) + (pop! p) ;; displays "Boom! 108" + (push! p (push (make 5 5) 1)) + (pop! p)) ;; displays "Boom! 24" + + ;; This completes the program, executing main: + + (program + (import (main))) + + ;; In the current implementation, one can also do + ;; this to execute a library in the REPL: + + (import (main)) + + ;;====================================================================== + ;; + ;; Dynamic loading of libraries and programs as in ERR5RS. + ;; Simply use LOAD to load the source files. + ;; See http://scheme-punks.cyber-rush.org/wiki/index.php?title=ERR5RS:Libraries. + ;; + ;;====================================================================== + + (import (rnrs load)) + + (load "sample-stack.scm") + (load "sample-balloons.scm") + (load "sample-party.scm") + (load "sample-program.scm") ;; displays "Boom! 108" and "Boom! 24" + + ;;====================================================================== + ;; + ;; Library reflection: + ;; + ;;====================================================================== + + ;; Reflection facility useful for development and debugging: + ;; See uses of (environment-bindings ---) in examples below: + + (import (only (rnrs eval) environment) + (only (rnrs eval reflection) environment-bindings)) + + (environment-bindings (environment '(party))) + + ;; ==> (((name make) (type variable) (from (balloons)) (levels (0))) + ;; ((name push) (type variable) (from (balloons)) (levels (0))) + ;; ((name push!) (type variable) (from (stack)) (levels (0))) + ;; ((name make-party) (type variable) (from (party)) (levels (0))) + ;; ((name pop!) (type variable) (from (party)) (levels (0)))) + ;;====================================================================== + ;; + ;; Macros and meta-levels + ;; + ;;====================================================================== + + (library (my-helpers id-stuff) + (export find-dup) + (import (rnrs)) + + (define (find-dup l) + (and (pair? l) + (let loop ((rest (cdr l))) + (cond ((null? rest) + (find-dup (cdr l))) + ((bound-identifier=? (car l) (car rest)) + (car rest)) + (else (loop (cdr rest))))))) + ) + + (library (my-helpers value-stuff) + (export mvlet) + (import (rnrs) + (for (my-helpers id-stuff) expand)) + + (define-syntax mvlet + (lambda (stx) + (syntax-case stx () + ((_ ((id ...) expr) body0 body ...) + (not (find-dup (syntax (id ...)))) + (syntax + (call-with-values + (lambda () expr) + (lambda (id ...) body0 body ...)))))))) + + ;; Do some reflection to see what is going on with the levels: + + (environment-bindings (environment '(for (my-helpers id-stuff) expand))) + + ;;==> (((name find-dup) + ;; (type variable) + ;; (from (my-helpers id-stuff)) + ;; (levels (1)))) + + (library (let-div) + (export let-div) + (import (rnrs) (my-helpers value-stuff)) + + (define (quotient+remainder n d) + (let ((q (floor (/ n d)))) + (values q (- n (* q d))))) + + (define-syntax let-div + (syntax-rules () + ((_ n d (q r) body0 body ...) + (mvlet ((q r) (quotient+remainder n d)) + body0 body ...)))) + ) + + (program + (import (let-div) (rnrs)) + (let-div 5 2 (q r) (+ q r)) ;==> 3 + ) + + ;;================================================================= + ;; + ;; Version reference syntax: + ;; + ;;================================================================= + + (library (foo (2 3 5)) + (export) + (import)) + + (import (foo ())) + (import (foo (2))) + (import (foo (2 3))) + (import (foo (or (1 (>= 1)) (2)))) + (import (foo ((or 1 2 3)))) + + ;;====================================================== + ;; + ;; Further program tests: + ;; + ;;====================================================== + + ;; Test expressions returning no values and more than one value + ;; preceding definitions: + + (program + (import (rnrs)) + (define x 1) + (set! x 2) + (values) + (display 4) ;==> 4 + (values 2 3) + (define y 3) + (+ x y)) ;==> 5 + + ;;====================================================== + ;; + ;; Further library tests: + ;; + ;;====================================================== + + ;; Test meta-level resolution for chained imports: + + (library (foo) + (export u) + (import (rnrs)) + (define u 1)) + + (library (bar) + (export u v) + (import (rnrs) (foo)) + (define-syntax v (lambda (e) (syntax u)))) + + (library (baz) + (export) + (import (for (rnrs) (meta 2) expand run) + (for (bar) (meta 2))) + (display + (let-syntax ((m (lambda (e) + (let-syntax ((n (lambda (e) (+ u (v))))) + (n))))) + (m)))) + + (import (baz)) ;==> 2 + + ;;====================================================== + ;; + ;; Check that export levels compose correctly: + ;; + ;;====================================================== + + (library (foo) + (export x y) + (import (rnrs)) + (define x 2) + (define y 4)) + + (library (baz) + (export y) ;; exports y at level 1 + (import (rnrs) (for (foo) expand))) + + ;; To see what is going on, do some introspection: + + (environment-bindings (environment '(baz))) + + ;; ==> (((name y) (type variable) (from (foo)) (levels (1)))) + + (library (bab) + (export f) + (import (for (rnrs) expand run) ;; This also implicitly imports into (meta 2) + (for (foo) expand) ;; imports x and y at level 1 + (for (baz) expand)) ;; also imports y but at level expand + 1 = 2 + (define (f) + (let-syntax ((foo (lambda (_) + (+ x ;; level 1 + y ;; level 1 + (let-syntax ((bar (lambda (_) y))) ;; level 2 + (bar)))))) + (foo)))) + + ;; Again, do some reflection to see what is going on with the levels: + + (environment-bindings (environment '(for (foo) expand) + '(for (baz) expand))) + + ;;==> (((name x) (type variable) (from (foo)) (levels (1))) + ;; ((name y) (type variable) (from (foo)) (levels (2 1)))) + + (import (bab)) + (f) ;==> 10 + + ;;========================================================== + ;; + ;; Check that levels of reference are determined lexically: + ;; + ;;========================================================== + + (library (foo) + (export f) + (import (rnrs)) + (define (f) 1)) + + (library (bar) + (export g) + (import (rnrs) + (for (foo) expand)) ;; This is the wrong level ! + (define-syntax g + (syntax-rules () + ((_) (f))))) + + ;; This *must* be an error: + ;; The use of f in bar cannot be satisfied + ;; by the import of foo into the client level 0 here. + ;; That would violate lexical determination of + ;; level of reference to f in bar. + + ;; (library (main) + ;; (export) + ;; (import (rnrs) (foo) (bar)) + ;; (display (g))) + + ;; ==> Syntax violation: Attempt to use binding of f in library (bar) at invalid meta level 0. + ;; Binding is only valid at meta levels: 1 + + ;; Example from http://www.r6rs.org/r6rs-editors/2006-August/001682.html + + (library (A) + (export x) + (import (rnrs)) + (define x 37)) + + (library (B) + (export) + (import (A))) + + (library (C) + (export foo) + (import (rnrs) (for (A) expand)) + (define-syntax foo + (syntax-rules () + ((_) x)))) + + (library (D) + (export foo) + (import (rnrs) (C))) + + ;; This has to raise syntax error to avoid problem described in + ;; above message. + + (library (E) + (export) + (import (rnrs) (B) (D)) + ;; (display (foo)) ; Attempt to use x in library (C) at invalid meta level 0. + ;; ; Binding is only available at meta levels: 1 + ) + + ;;============================================================== + ;; + ;; Importing into multiple and negative levels: + ;; + ;;============================================================== + + (library (foo) + (export x) + (import (rnrs)) + (define x 42)) + + (library (bar) + (export get-x) + (import (rnrs) + ;; Code in (syntax ...) expressions refer to bindings + ;; at one lower level - for example, ordinary macros + ;; are evaluated at level expand = 1, but manipulate + ;; code that will run at level run = 0. + ;; The occurrence of (syntax x) below is not in a macro + ;; but rather at level 0. + ;; The reference x in (syntax x) is therefore at level -1. + ;; To make it refer to the x in foo, we need to import + ;; the latter at level -1. + (for (foo) (meta -1))) + (define (get-x) (syntax x))) + + (library (baz) + (export) + (import (for (rnrs) (meta 3) (meta 2) expand run) + (for (bar) (meta 3) expand)) + + (display + (let-syntax ((m (lambda (ignore) + (get-x)))) + (m))) ;==> 42 + + (display + (let-syntax ((m (lambda (ignore) + (let-syntax ((n (lambda (ignore) + (let-syntax ((o (lambda (ignore) + (get-x)))) + (o))))) + (n))))) + (m))) ;==> 42 + + ;; This should give a syntax error: + + ;; (display + ;; (let-syntax ((m (lambda (ignore) + ;; (let-syntax ((n (lambda (ignore) + ;; (get-x)))) + ;; (n))))) + ;; (m))) ;==> Syntax-violation: Attempt to use binding of get-x in library (baz) at invalid level 2 + ;; ; Binding is only valid at levels (1 3) + + ) ;; baz + + (import (baz)) ;==> 42 42 + + ;;============================================================= + ;; + ;; Nice practical example of negative levels: + ;; Modified from example by Abdulaziz Ghuloum. + ;; + ;;============================================================= + + (library (print) + (export print-args) + (import (rnrs)) + (define print-args + (lambda (fml* act*) + (display "Lambda ") + (display fml*) + (display " : ") + (display act*) + (newline)))) + + (library (tracers-helpers) + (export trace-transformer untrace-transformer) + (import (for (rnrs) (meta -1) run) + (for (print) (meta -1))) + (define trace-transformer + (lambda (stx) + (syntax-case stx () + ((_ fml* b b* ...) + (syntax + (lambda act* + (print-args 'fml* act*) + (apply (lambda fml* b b* ...) act*))))))) + (define untrace-transformer + (lambda (stx) + (syntax-case stx () + ((_ fml* b b* ...) + (syntax + (lambda fml* b b* ...))))))) + + (library (tracers) + (export trace-region untrace-region) + (import (rnrs) + (for (tracers-helpers) expand)) + + (define-syntax trace-region + (lambda (x) + (syntax-case x () + ((kwd b b* ...) + (with-syntax ((L (datum->syntax (syntax kwd) 'lambda))) + (syntax + (let-syntax ((L trace-transformer)) + b b* ...))))))) + + (define-syntax untrace-region + (lambda (x) + (syntax-case x () + ((kwd b b* ...) + (with-syntax ((L (datum->syntax (syntax kwd) 'lambda))) + (syntax + (let-syntax ((L untrace-transformer)) + b b* ...)))))))) + + (library (FOO) + (export) + (import (rnrs) (tracers)) + (define a (lambda (q) (display "A not traced\n"))) + (trace-region + (define b (lambda (r) (display "did it work in B?\n"))) + (untrace-region + (define c (lambda (s) (display "C not traced\n")))) + (define d (lambda (t) (display "did it work in D?\n")))) + (a 'a) + (b 'b) + (c 'c) + (d 'd)) + + (import (FOO)) + ;; ==> A not traced + ;; Lambda (r) : (b) + ;; did it work in B? + ;; C not traced + ;; Lambda (t) : (d) + ;; did it work in D? + + ;;==================================================================== + ;; + ;; SHARING OF BINDINGS: + ;; + ;; The following detects whether bindings are shared between + ;; different meta levels that may be present at expansion time. + ;; + ;;==================================================================== + + (library (foo) + (export counter) + (import (rnrs)) + (define counter + (let ((x 0)) + (lambda () + (set! x (+ x 1)) + x)))) + + (library (bar) + (export) + (import (rnrs) + (for (foo) run expand)) + (let-syntax ((m (lambda (e) (counter)))) + (display (list (m) (counter))))) + + (import (bar)) ;==> (1 1) since bindings are never shared between expand and run + + (library (baz) + (export) + (import (for (rnrs) run expand) + (for (foo) expand (meta 2))) + (let-syntax ((_ (let-syntax ((m (lambda (e) (counter)))) + (display (list (m) (counter))) + (lambda (_) _)))))) + + ;; ;==> (1 1) when bindings are not shared at expand-time + ;; (1 2) when bindings are shared at expand-time + + ;; This detects whether macro bindings are shared between levels. + + (library (foo) + (export f) + (import (rnrs)) + (define f + (let ((x 0)) + (lambda () + (set! x (+ x 1)) + x)))) + + (library (bar) + (export m) + (import (rnrs) (for (foo) expand)) + (define-syntax m + (lambda (e) + (f)))) + + (library (baz) + (export) + (import (for (rnrs) run expand) + (for (bar) expand (meta 2))) + (let-syntax ((n (lambda (e) + (let-syntax ((o (lambda (e) (m)))) + (+ (m) (o)))))) + (display (n)))) + + (import (baz)) ;==> 2 if macro bindings are not shared + ;; 3 if macro bindings are shared + + ;;==================================================================== + ;; + ;; Levels are not identical to phases: + ;; + ;; Example illustrating that two identifier references (1) and (2) + ;; both at level 1 can be evaluated in very different phases. + ;; Reference (1) is not evaluated at all during expansion of (foo), + ;; but only later during expansion of (bar). + ;; + ;;==================================================================== + + (library (baz) + (export x) + (import (rnrs)) + (define x 1)) + + (library (foo) + (export template) + (import (for (baz) expand) + (for (rnrs) run (meta -1))) + (define (template) + (syntax (let-syntax ((m (lambda (_) + (let-syntax ((n (lambda (_) x))) ; <== (1) + (n))))) + (m)))) + (let-syntax ((n (lambda (_) x))) ; <== (2) + (n))) + + (library (bar) + (export) + (import (rnrs) + (for (foo) expand)) + (let-syntax ((n (lambda (_) (template)))) + (display (n))) + ) + + (import (bar)) + + ;;================================================================ + ;; + ;; Level enforcement while visiting or invoking libraries: + ;; + ;; The following test checks that level enforcing works correctly + ;; also for expand-time toplevel identifiers created while + ;; visiting libraries. + ;; + ;;================================================================ + + (library (D) + (export put! get) + (import (rnrs)) + (define v #f) + (define (put! x) (set! v x)) + (define (get) v)) + + (library (B) + (export b) + (import (rnrs)) + (define b 7)) + + (library (A) + (export do-a) + (import (rnrs) + (for (D) expand) + (for (B) run)) + + (define-syntax do-a + (begin (put! (syntax b)) + (lambda (stx) + #f)))) + + (library (C) + (export) + (import (for (rnrs) run expand) + (for (D) expand) + + ;; In this test, change RUN to EXPAND. The following syntax + ;; error should be obtained: + ;; + ;; Syntax violation: invalid reference + ;; Attempt to use b in library (A) at invalid meta level -1. + ;; Binding is only available at meta levels: 0 + + (for (A) run)) + + (define-syntax make-ref + (lambda (stx) + (get))) + + (display (make-ref))) + + (import (C)) + + ;;================================================================= + ;; + ;; Phase checking for literals and free-identifier=? uses: + ;; + ;; R6RS does not say if these operations count as references, + ;; but does require importing of literals such as ... and _ + ;; into the appropriate phase. To ensure maximal portability, + ;; a good implementation should have a liberal interpretation of + ;; what a reference is, and check literal phases. + ;; We do so by checking that the arguments of free-identifier=? + ;; are both in phase when the result of the comparison is #t + ;; (for examples why, see below). + ;; For ensuring that uses of literals are in phase, this is sufficient + ;; but may be more than necessary. However, we are within our R6RS + ;; rights to be more restrictive, and in this case more is + ;; better for maximal portability checking. + ;; + ;;================================================================= + + ;; This shows why we should only test that the arguments of free-identifier=? + ;; are in phase when the comparison succeeds. The expander should complain + ;; about the wrong phase of ..., but should not complain about the phase of + ;; LIST in the template, even though LIST is also compared to see if it + ;; is bound to R6RS ... during expansion. + + ;;(library (foo) + ;; (export) + ;; (import (except (rnrs base) ...) + ;; (only (rnrs syntax-case) ...)) ;; .. is in wrong phase + ;; (define-syntax list-macro + ;; (syntax-rules () + ;; ((_ x ...) (list x ...))))) + ;; + ;; Attempt to use binding ... in library foo at invalid meta level 1. + ;; Binding is only available at meta levels: 0 + + ;; More examples: + + (library (foo) + (export test) + (import (rnrs base)) + (define-syntax test + (syntax-rules (car) + ((_ car) #t) + ((_ k) #f)))) + + ;; The literal CAR is used in the wrong phase: + ;; + ;;(library (bar) + ;; (export) + ;; (import (for (rnrs base) (meta 21)) + ;; (foo)) + ;; (test car)) + ;; + ;; Attempt to use binding car in library bar at invalid meta level 0. + ;; Binding is only available at meta levels: 21 + + ;; This is not a literal use, so no problem. + + (library (bar) + (export) + (import (for (rnrs base) (meta 21)) + (foo)) + (test cdr)) + + ;; Here the literal is in the wrong phase at the definition site: + + (library (foo) + (export test) + (import (except (rnrs base) car) + (for (only (rnrs base) car) (meta 21))) + (define-syntax test + (syntax-rules (car) + ((_ car) #t) ; is this a reference? + ((_ k) #f)))) + + ;; The problem is detected as soon as we try to use it: + + ;;(library (bar) + ;; (export) + ;; (import (rnrs base) + ;; (foo)) + ;; (test car)) + ;; + ;; Attempt to use binding car in library foo at invalid meta level 0. + ;; Binding is only available at meta levels: 21 + + ;; We will not detect the problem if we do not use the literal, though. + + (library (bar) + (export) + (import (rnrs base) + (foo)) + (test cdr)) ;==> expands without problems + + ;; To summarize, the arguments of free-identifier=? are only + ;; required to be in phase when the comparison succeeds. + + (library (foo) + (export test1 test2) + (import (except (rnrs) car) + (for (only (rnrs) car) (meta 21))) + (define-syntax test1 + (lambda (form) + (free-identifier=? (syntax car) (syntax cdr)))) + (define-syntax test2 + (lambda (form) + (free-identifier=? (syntax car) (syntax car))))) + + (import (foo)) + (test1) ;==> #f + + ;;(test2) + ;; + ;; Attempt to use binding car in library foo at invalid meta level 0. + ;; Binding is only available at meta levels: 21 22 + + ;; Another example, similar in spirit to the first ... example. + + ;;(library (foo) + ;; (export) + ;; (import (rnrs base) + ;; (for (prefix (only (rnrs base) quasiquote) meta-) (meta 21))) + ;; `(meta-quasiquote 1)) + ;; + ;; Attempt to use binding meta-quasiquote in library foo at invalid meta level 0. + ;; Binding is only available at meta levels: 21 + + ;; Out of phase uses of the literals DEFINE, BEGIN, etc., in + ;; bodies are detected in the same way. + + ;;(library (foo) + ;; (export) + ;; (import (except (rnrs base) define) + ;; (for (only (rnrs base) define))) ; imported but for no levels + ;; (define x 1) + ;; (display x)) + ;; + ;; Attempt to use binding define in library foo at invalid meta level 0. + ;; Binding is only available at meta levels: + + ;;================================================================== + ;; + ;; Out of context reference to let-syntax binding should raise + ;; syntax error for portability. + ;; + ;;================================================================== + + ;; (library (foo) + ;; (export bar) + ;; (import (rnrs)) + ;; (let-syntax ((baz (lambda (form) 1))) + ;; (define-syntax bar + ;; (syntax-rules () + ;; ((_) (baz)))))) + ;; + ;; (import (foo)) + ;; (bar) ;==> Syntax violation: Reference to macro keyword out of context: baz + + ;;================================================================ + ;; + ;; Toplevel interaction with unbound identifiers and literals: + ;; This is unspecified in r6rs but seems like reasonable behaviour. + ;; + ;;================================================================ + + ;; Toplevel binding should not capture unbound identifiers in + ;; libraries. + + (library (foo) + (export bar) + (import (rnrs)) + (define-syntax bar (syntax-rules () ((_) (baz))))) + + (import (foo)) + (define (baz) 1) + ;; (define (f) (bar)) ;==> Syntax violation: invalid reference. + ;; ; No binding available for baz at meta level 0 + + ;; Unbound literals in library match unbound identifiers at toplevel. + + (library (foo) + (export bar) + (import (rnrs)) + (define-syntax bar + (syntax-rules (unbound-literal) + ((_ unbound-literal) #t) + ((_ _) #f)))) + + (import (foo)) + + (bar unbound-literal) ;==> #t + (bar x) ;==> #f + (define unbound-literal 1) + (bar unbound-literal) ;==> #f + + ;;====================================================== + ;; + ;; Example from Matthew Flatt's paper. + ;; Illustrates use of expand-time state. + ;; + ;;====================================================== + + (library (records-helper) + (export register! registered?) + (import (rnrs)) + (define table '()) + (define (register! name) + (set! table (cons name table))) + (define (registered? name) + (memp (lambda (entry) (free-identifier=? name entry)) + table))) + + (library (records) + (export define-record record-switch) + (import (rnrs) (for (records-helper) expand)) + (define-syntax define-record + (lambda (form) + (syntax-case form () + ((_ name) + (syntax + (begin + (define name 'record-type-descriptor) + (define-syntax dummy + (begin + (register! (syntax name)) + (lambda (form) 'never-used))))))))) + (define-syntax record-switch + (lambda (form) + (syntax-case form () + ((_ exp (name consequence)) + (if (registered? (syntax name)) + (syntax (if (eq? exp 'name) consequence "no match")) + (syntax-violation #f "Invalid record type" (syntax name)))))))) + + (library (zoo) + (export zebra) + (import (records)) + (define-record zebra)) + + (library (metrics) + (export) + (import (rnrs) (zoo) (records)) + (display + (record-switch 'zebra (zebra 'zebra)))) ;==> zebra + + (import (metrics)) + + ;;================================================================= + ;; + ;; Immutabilty tests: + ;; + ;;================================================================= + + (library (foo) + (export x bar baz bax + ;; Uncomment to test error on attempt to export mutable variable: + ;; z ; Syntax violation: Attempt to export mutable variable + ) + (import (rnrs)) + (define x 1) + (define y 1) + (define z 1) + (define-syntax bar + (syntax-rules () + ((_) (set! x 2)))) + (define-syntax baz + (syntax-rules () + ((_) (set! y 2)))) + (define-syntax bax + (syntax-rules () + ((_) z))) + (set! z 2)) + + (library (boo) + (export) + (import (rnrs) + (foo)) + + ;; Uncomment to test explicit import assigment errors: + + ;;(set! x 2)) ; Syntax violation: Imported variable cannot be assigned: x + ;;(bar) ; Syntax violation: Imported variable cannot be assigned: x + + ;; Uncomment to test implicit import assignment error: + + ;;(baz) ; Syntax violation: Imported variable cannot be assigned: y + + ;; Uncomment to test error on attempt to implicitly import mutable variable: + + ;;(bax) ; Syntax violation: Attempt to implicitly import variable + ;; ; that is mutable in library (foo) : z + + ) ; (boo) + + ;;==================================================================== + ;; + ;; Correct lexical scoping of expansion algorithm: + ;; + ;; Examples where and error should be thrown to avoid giving a + ;; lexical-scope-violating semantics to expressions: + ;; + ;;==================================================================== + + ;; This must give an error: + + ;; (let () + ;; (define-syntax foo (lambda (e) (+ 1 2))) + ;; (define + 2) + ;; (foo)) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: + + + ;; This gives no error: + + (let () + (define-syntax foo (lambda (e) (let ((+ -)) (+ 1 2)))) + (define + 2) + (foo)) ;==> -1 + + ;;(let ((x #f)) + ;; (let-syntax ((foo (syntax-rules (x) + ;; ((_ x y) (define y 'outer)) + ;; ((_ _ y) (define y 'inner))))) + ;; (let () + ;; (foo x p) + ;; (define x #f) + ;; p))) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: x + + ;; Still, the following is valid. + + (let ((x #f)) + (let-syntax ((foo (syntax-rules (x) + ((_ x y) (define y 'outer)) + ((_ _ y) (define y 'inner))))) + (let () + (define x #f) + (foo x p) + p))) ;==> inner + + ;;(let ((x #f)) + ;; (let-syntax ((foo (syntax-rules (x) + ;; ((_ x y) (define y 'outer)) + ;; ((_ _ y) 1)))) + ;; (let () + ;; (foo x p) + ;; (define x #f) + ;; p))) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: x + + ;;(let-syntax ((def0 (syntax-rules () + ;; ((_ x) (define x 0))))) + ;; (let () + ;; (def0 z) + ;; (define def0 '(def 0)) + ;; (list z def0))) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: def0 + + ;;(let () + ;; (define define 17) + ;; define) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: define + + ;; (define-syntax foo (syntax-rules () ((_ x) (define x 1)))) + ;; (let ((b 2)) + ;; (foo a) + ;; (define (foo x) 2) + ;; (foo b) + ;; (values a b)) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: foo + + ;; (define-syntax foo (syntax-rules () ((_ x) (define x 1)))) + ;; (let () + ;; (foo a) + ;; (define-syntax foo (syntax-rules () ((_ x) (define x 2)))) + ;; (foo b) + ;; (values a b)) ; Syntax violation: Definition of identifier that may have + ;; ; already affected meaning of undeferred portions of body: foo + + ;; This should still be valid. + + (let () + (define-syntax foo + (syntax-rules () + ((_ def0) (def0 define 17)))) + (foo define) + 0) + + ;; Distinguishing literals from non-literal data: + + (let () + (define-syntax list-macro + (syntax-rules () + ((_ x ...) (list x ...)))) + ;; This must give violation: + ;;(define ... 1) ; Syntax violation: Definition of identifier that may have already + ;; ; affected meaning of undeferred portions of body: ... + ;; But this must not: + (define list cons) + (list-macro 1 2)) ;==> (1 . 2) + + ;;(let () + ;; (define-syntax macro + ;; (let ((x `(1 ,2))) + ;; (lambda (form) x))) + ;; (define unquote 2) + ;; (macro)) ; Syntax violation: Definition of identifier that may have already + ;; ; affected meaning of undeferred portions of body: unquote + + ;; Have to make sure that previous does give violation but this does not. + (let () + (define-syntax macro + (let ((x `(+ ,2))) + (lambda (form) (cadr x)))) + (define + 2) + (macro)) ;==> 2 + + ;;====================================================== + ;; + ;; Eval: + ;; + ;;====================================================== + + (import (rnrs eval)) + + (eval '(+ 1 2) + (environment '(rnrs))) ;==> 3 + + ;; This gives a syntax error as required by r6rs. + + ;;(eval '(begin (define x 1) x) + ;; (environment '(rnrs))) + ;; ==> Syntax violation: define + ;; Invalid form in expression sequence + ;; Form: (define x 1) + + (library (foo) + (export foo-x foo-y) + (import (rnrs)) + (define foo-x 4) + (define-syntax foo-y (syntax-rules () ((_) 22)))) + + (eval '(+ 1 (let-syntax ((foo (lambda (_) (+ foo-x (foo-y))))) + (foo))) + (environment '(rnrs) '(for (foo) expand))) ;==> 27 + + (library (bar) + (export) + (import (rnrs) + (rnrs eval)) + + (display + (eval '(+ 1 (let-syntax ((foo (lambda (_) foo-x))) + (foo))) + (environment '(rnrs) '(for (foo) expand))))) + + (import (bar)) ;==> 5 + + ;;====================================================== + ;; + ;; General syntax-case expander tests: + ;; + ;;====================================================== + + (import (for (rnrs) run expand (meta 2))) + + (let-syntax ((m (lambda (e) + (let-syntax ((n (lambda (e) 3))) + (n))))) + (m)) ;==> 3 + + ;; Some simple patern and template pitfalls: + + (syntax-case '((1 2) (3 4)) () + (((x ...) ...) (syntax (x ... ...)))) ;==> (1 2 3 4) + + ;; rnrs pattern extensions: + + (syntax-case '(1 2 3 4) () + ((x ... y z) (syntax ((x ...) y z)))) ;==> ((1 2) 3 4) + + (syntax-case '(1 2 3 . 4) () + ((x ... y . z) (syntax ((x ...) y z)))) ;==> ((1 2) 3 4) + + (syntax-case '#(1 2 3 4) () + (#(x ... y z) (syntax (#(x ...) y z)))) ;==> (#(1 2) 3 4) + + (syntax-case '((1 2) (3 4)) () + (((a b) ...) (syntax ((a ...) (b ...))))) ;==> ((1 3) (2 4)) + + (syntax-case '((1 2) 3) () + (((a b) ...) (syntax ((a ...) (b ...)))) + (_ #f)) ;==> #f + + (syntax-case '((1 2) (3 4) . 3) () + (((a b) ... . c) (syntax ((a ...) (b ...))))) ;==> ((1 3) (2 4)) + + ;; Wildcards: + + (let-syntax ((foo (syntax-rules () + ((_ _ _) 'yes)))) + (foo 3 4)) + + ;; Identifier macros: + + (define-syntax foo + (lambda (e) + (or (identifier? e) + (syntax-violation 'foo "Invalid expression" e)) + 40)) + + foo ;==> 40 + ;; (set! foo 1) ;==> Syntax violation: Syntax being set! is not a variable transformer + ;; (foo) ;==> syntax violation: foo - Invalid expression + + (import (rnrs mutable-pairs)) + + (define p (cons 4 5)) + (define-syntax p.car + (make-variable-transformer + (lambda (x) + (syntax-case x (set!) + ((set! _ e) (syntax (set-car! p e))) + ((_ . rest) (syntax ((car p) . rest))) + (_ (syntax (car p))))))) + (set! p.car 15) + p.car ;==> 15 + p ;==> (15 . 5) + + (define p (cons 4 5)) + (define-syntax p.car (identifier-syntax (car p))) + p.car ;==> 4 + ;;(set! p.car 15) ;==> Syntax violation: Keyword being set! is not a variable transformer + + (define p (cons 4 5)) + (define-syntax p.car + (identifier-syntax + (_ (car p)) + ((set! _ e) (set-car! p e)))) + (set! p.car 15) + p.car ;==> 15 + p ;==> (15 . 5) + + ;; Check displaced identifier error: + + ;; (let ((x 1)) + ;; (let-syntax ((foo (lambda (x) + ;; (syntax x)))) + ;; (foo))) + ;; ;==> Syntax error: Attempt to use binding of x at invalid level 0 + ;; Binding is valid at levels: 1 + + ;; Testing toplevel forward references: + + (define (f) (g)) + (define (g) 15) + (f) ;==> 15 + + (define-syntax foo (lambda (_) (syntax (bar)))) + (define-syntax bar (lambda (_) 1)) + (foo) ;==> 1 + + ;; The following must give an error, since g-0 is bound at level 0 but used at level 1: + + ;; (define-syntax foo (lambda (_) (g-0))) ;==> Syntax violation: invalid reference + ;; ; No binding available for g-0 at level 1 + ;; (define (g-0) 1) + ;; (foo) + + ;; Correct forward reference (*): + + (let ((x 'outer)) + (define-syntax foo + (syntax-rules () + ((_ lhs) (define lhs x)))) + (foo (f)) + (define x 'inner) + (f)) ;==> inner + + ;; This must give an error: + ;; + ;; (let () + ;; (let-syntax ((foo (lambda (_) (let ((x 2)) (syntax x))))) + ;; (define (f) (foo))) + ;; (define x 1) + ;; (f)) + ;==> Attempt to use binding of x at invalid level 0. Binding is only valid at levels: 1 + + ;; Forward references for internal define-syntax works correctly. + + (let () + (define-syntax odd + (syntax-rules () + ((odd) #t) + ((odd x . y) (not (even . y))))) + (define-syntax even + (syntax-rules () + ((even) #f) + ((even x . y) (not (odd . y))))) + (odd x x x)) ;==> #t + + ;; Forward reference to procedure from transformer. + + (let () + (define-syntax foo + (syntax-rules () + ((_) bar))) + (define bar 1) + (foo)) ;==> 1 + + ;; Secrecy of generated toplevel defines: + + (define x 1) + (let-syntax ((foo (lambda (e) + (syntax (begin + (define x 2) + x))))) + (foo)) ;==> 2 + x ;==> 1 + + ;; Stress testing expander with internal letrec-generated body, + ;; begins, etc. + + (let () + (letrec-syntax ((foo (syntax-rules () + ((_) (begin (define (x) 1) + (begin + (define-syntax y + (syntax-rules () + ((_) (x)))) + (bar y)))))) + (bar (syntax-rules () + ((_ y) (begin (define (z) (baz (y))) + (z))))) + (baz (syntax-rules () + ((baz z) z)))) + (foo))) ;==> 1 + + ;; Big stress test, including nested let-syntax and + ;; forward reference to later define-syntax. + + (let ((foo /)) + (letrec-syntax ((foo (syntax-rules () + ((_ z) (begin (define (x) 4) + (define-syntax y + (syntax-rules () + ((_) (x)))) + (bar z y))))) + (bar (syntax-rules () + ((_ z y) (define (z) (baz (y)))))) + (baz (syntax-rules () + ((baz z) z)))) + (let-syntax ((foobar (syntax-rules () ;; test nested let-syntax + ((_ u z) + (define-syntax u + (syntax-rules () + ((_ x y) (z x y)))))))) + (foo a) + (foobar gaga goo))) ;; foobar creates forward reference to goo + ;; from expanded transformer. + (define-syntax goo (syntax-rules () + ((_ x y) (define-syntax x + (syntax-rules () + ((_) y)))))) + (gaga b (a)) + (foo (b))) ;==> 1/4 + + ;; Internal let-syntax, but in a library: + ;; which is the same algorithm as in a lambda body. + + (library (test) + (export) + (import (rnrs)) + (let-syntax ((foo (syntax-rules () + ((_ bar) + (begin + (define x 7) + (define-syntax bar + (syntax-rules () + ((_) (display x))))))))) + (foo baz) + (baz))) + + (import (test)) ;==> 7 + + (let ((a 1) + (b 2)) + (+ a b)) ;==> 3 + + (define-syntax swap! + (lambda (exp) + (syntax-case exp () + ((_ a b) + (syntax + (let ((temp a)) + (set! a b) + (set! b temp))))))) + + (let ((temp 1) + (set! 2)) + (swap! set! temp) + (values temp set!)) ;==> 2 1 + + (let ((x 'outer)) + (let-syntax ((foo (lambda (exp) (syntax x)))) + (let ((x 'inner)) + (foo)))) ;==> outer + + ;; SRFI-93 example of expansion of internal definitions + + (let () + (define-syntax foo + (syntax-rules () + ((foo x) (define x 37)))) + (foo a) + a) ;==> 37 + + (case 'a + ((b c) 'no) + ((d a) 'yes)) ;==> yes + + (let ((x 1)) + (let-syntax ((foo (lambda (exp) (syntax x)))) + (let ((x 2)) + (foo)))) ;==> 1 + + (let ((x 1)) + (let-syntax ((foo (lambda (exp) (datum->syntax (syntax y) 'x)))) + (let ((x 2)) + (foo)))) ;==> 1 + + (let-syntax ((foo (lambda (exp) + (let ((id (cadr exp))) + (bound-identifier=? (syntax x) + (syntax id)))))) + (foo x)) ;==> #f + + (cond (#f 1) (else 2)) ;==> 2 + (let ((else #f)) (cond (else 2))) ;==> unspecified + + (let-syntax ((m (lambda (form) + (syntax-case form () + ((_ x) (syntax + (let-syntax ((n (lambda (_) + (syntax (let ((x 4)) x))))) + (n)))))))) + (m z)) ;==> 4 + + ;; Expression let-syntax and sequences: + + (+ (let-syntax ((foo (lambda (e) 1))) + (display 'foo) + (foo)) + 2) ;==> foo 3 + + (+ (begin (display 'foo) + 1) + 2) ;==> foo 3 + + ;;;========================================================================= + ;; + ;; Composing macros with intentional variable capture using DATUM->SYNTAX + ;; + ;;;========================================================================= + + (define-syntax if-it + (lambda (x) + (syntax-case x () + ((k e1 e2 e3) + (with-syntax ((it (datum->syntax (syntax k) 'it))) + (syntax (let ((it e1)) + (if it e2 e3)))))))) + + (define-syntax when-it + (lambda (x) + (syntax-case x () + ((k e1 e2) + (with-syntax ((it* (datum->syntax (syntax k) 'it))) + (syntax (if-it e1 + (let ((it* it)) e2) + (if #f #f)))))))) + + (define-syntax my-or + (lambda (x) + (syntax-case x () + ((k e1 e2) + (syntax (if-it e1 it e2)))))) + + (if-it 2 it 3) ;==> 2 + (when-it 42 it) ;==> 42 + (my-or 2 3) ;==> 2 + ;;(my-or #f it) ;==> undefined identifier: it + + (let ((it 1)) (if-it 42 it #f)) ;==> 42 + (let ((it 1)) (when-it 42 it)) ;==> 42 + (let ((it 1)) (my-or #f it)) ;==> 1 + (let ((if-it 1)) (when-it 42 it)) ;==> 42 + + ;;;========================================================================= + ;; + ;; Escaping ellipses: + ;; + ;;;========================================================================= + + (let-syntax ((m (lambda (form) + (syntax-case form () + ((_ x ...) + (with-syntax ((___ (datum->syntax (syntax here) '...))) + (syntax + (let-syntax ((n (lambda (form) + (syntax-case form () + ((_ x ... ___) + (syntax `(x ... ___))))))) + (n a b c d))))))))) + (m u v)) + + ;;==> (a b c d) + + (let-syntax ((m (lambda (form) + (syntax-case form () + ((_ x ...) + (syntax + (let-syntax ((n (lambda (form) + (syntax-case form () + ((_ x ... (... ...)) + (syntax `(x ... (... ...)))))))) + (n a b c d)))))))) + (m u v)) + + ;;==> (a b c d) + + ;;;========================================================================= + ;; + ;; From R5RS: + ;; + ;;;========================================================================= + + (define-syntax or + (syntax-rules () + ((or) #f) + ((or e) e) + ((or e1 e ...) (let ((temp e1)) + (if temp temp (or e ...)))))) + + (or #f #f 1) ;==> 1 + + (define-syntax or + (lambda (form) + (syntax-case form () + ((or) (syntax #f)) + ((or e) (syntax e)) + ((or e1 e ...) (syntax (let ((temp e1)) + (if temp temp (or e ...)))))))) + + (or #f #f 1) ;==> 1 + + (let-syntax ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if)) ;===> now + + (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m)))) ;===> outer + + (letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y))) ;===> 7 + + (define-syntax cond + (syntax-rules (else =>) + ((cond (else result1 result2 ...)) + (begin result1 result2 ...)) + ((cond (test => result)) + (let ((temp test)) + (if temp (result temp)))) + ((cond (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (cond clause1 clause2 ...)))) + ((cond (test)) test) + ((cond (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (cond clause1 clause2 ...)))) + ((cond (test result1 result2 ...)) + (if test (begin result1 result2 ...))) + ((cond (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (cond clause1 clause2 ...))))) + + (let ((=> #f)) + (cond (#t => 'ok))) ;===> ok + + (cond ('(1 2) => cdr)) ;===> (2) + + (cond ((> 3 2) 'greater) + ((< 3 2) 'less)) ;===> greater + (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal)) ;===> equal + + ;; Eli Barzilay + ;; In thread: + ;; R5RS macros... + ;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu + + (let-syntax ((foo + (syntax-rules () + ((_ expr) (+ expr 1))))) + (let ((+ *)) + (foo 3))) ;==> 4 + + ;; Al Petrofsky again + ;; In thread: + ;; Buggy use of begin in core:primitives cond and case macros. + ;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org + + (let-syntax ((foo (syntax-rules () + ((_ var) (define var 1))))) + (let ((x 2)) + (begin (define foo +)) + (cond (else (foo x))) + x)) ;==> 2 + + ;; Al Petrofsky + ;; In thread: + ;; An Advanced syntax-rules Primer for the Mildly Insane + ;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org + + (let ((x 1)) + (let-syntax + ((foo (syntax-rules () + ((_ y) (let-syntax + ((bar (syntax-rules () + ((_) (let ((x 2)) y))))) + (bar)))))) + (foo x))) ;==> 1 + + ;; another example: + + (let ((x 1)) + (let-syntax + ((foo (syntax-rules () + ((_ y) (let-syntax + ((bar (syntax-rules () + ((_ x) y)))) + (bar 2)))))) + (foo x))) ;==> 1 + + ;; Al Petrofsky + + (let ((a 1)) + (letrec-syntax + ((foo (syntax-rules () + ((_ b) + (bar a b)))) + (bar (syntax-rules () + ((_ c d) + (cons c (let ((c 3)) + (list d c 'c))))))) + (let ((a 2)) + (foo a)))) ;==> (1 2 3 a) + + (let ((=> #f)) + (cond (#t => 'ok))) ;===> ok + + (cond ('(1 2) => cdr)) ;===> (2) + + (cond ((< 3 2) 'less) + ((> 3 2) 'greater)) ;===> greater + + (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal)) ;===> equal + + (define-syntax loop ;; no change + (lambda (x) + (syntax-case x () + ((k e ...) + (with-syntax ((break (datum->syntax (syntax k) 'break))) + (syntax (call-with-current-continuation + (lambda (break) + (let f () e ... (f)))))))))) + + (let ((n 3) (ls '())) + (loop + (if (= n 0) (break ls)) + (set! ls (cons 'a ls)) + (set! n (- n 1)))) ;==> (a a a) + + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum))) ;==> 25 + + (define-syntax define-structure + (lambda (x) + (define gen-id + (lambda (template-id . args) + (datum->syntax template-id + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string + (syntax->datum x)))) + args)))))) + (syntax-case x () + ((_ name field ...) + (with-syntax + ((constructor (gen-id (syntax name) "make-" (syntax name))) + (predicate (gen-id (syntax name) (syntax name) "?")) + ((access ...) + (map (lambda (x) (gen-id x (syntax name) "-" x)) + (syntax (field ...)))) + ((assign ...) + (map (lambda (x) (gen-id x "set-" (syntax name) "-" x "!")) + (syntax (field ...)))) + (structure-length (+ (length (syntax (field ...))) 1)) + ((index ...) (let f ((i 1) (ids (syntax (field ...)))) + (if (null? ids) + '() + (cons i (f (+ i 1) (cdr ids))))))) + (syntax (begin + (define constructor + (lambda (field ...) + (vector 'name field ...))) + (define predicate + (lambda (x) + (and (vector? x) + (= (vector-length x) structure-length) + (eq? (vector-ref x 0) 'name)))) + (define access (lambda (x) (vector-ref x index))) ... + (define assign + (lambda (x update) + (vector-set! x index update))) + ...))))))) + + (define-structure tree left right) + (define t + (make-tree + (make-tree 0 1) + (make-tree 2 3))) + + t ;==> #(tree #(tree 0 1) #(tree 2 3)) + (tree? t) ;==> #t + (tree-left t) ;==> #(tree 0 1) + (tree-right t) ;==> #(tree 2 3) + (set-tree-left! t 0) + t ;==> #(tree 0 #(tree 2 3)) + + ;; Quasisyntax tests: + + (define-syntax swap! + (lambda (e) + (syntax-case e () + ((_ a b) + (let ((a (syntax a)) + (b (syntax b))) + (quasisyntax + (let ((temp (unsyntax a))) + (set! (unsyntax a) (unsyntax b)) + (set! (unsyntax b) temp)))))))) + + (let ((temp 1) + (set! 2)) + (swap! set! temp) + (values temp set!)) ;==> 2 1 + + (define-syntax case + (lambda (x) + (syntax-case x () + ((_ e c1 c2 ...) + (quasisyntax + (let ((t e)) + (unsyntax + (let f ((c1 (syntax c1)) + (cmore (syntax (c2 ...)))) + (if (null? cmore) + (syntax-case c1 (else) + ((else e1 e2 ...) (syntax (begin e1 e2 ...))) + (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) + (begin e1 e2 ...))))) + (syntax-case c1 () + (((k ...) e1 e2 ...) + (quasisyntax + (if (memv t '(k ...)) + (begin e1 e2 ...) + (unsyntax + (f (car cmore) (cdr cmore)))))))))))))))) + + (case 'a + ((b c) 'no) + ((d a) 'yes)) ;==> yes + + (define-syntax let-in-order + (lambda (form) + (syntax-case form () + ((_ ((i e) ...) e0 e1 ...) + (let f ((ies (syntax ((i e) ...))) + (its (syntax ()))) + (syntax-case ies () + (() (quasisyntax (let (unsyntax its) e0 e1 ...))) + (((i e) . ies) (with-syntax (((t) (generate-temporaries '(t)))) + (quasisyntax + (let ((t e)) + (unsyntax + (f (syntax ies) + (quasisyntax + ((i t) (unsyntax-splicing its))))))))))))))) + + (let-in-order ((x 1) + (y 2)) + (+ x y)) ;==> 3 + + (let-syntax ((test-ellipses-over-unsyntax + (lambda (e) + (let ((a (syntax a))) + (with-syntax (((b ...) '(1 2 3))) + (quasisyntax + (quote ((b (unsyntax a)) ...)))))))) + (test-ellipses-over-unsyntax)) + + ;==> ((1 a) (2 a) (3 a)) + + ;; Some tests found online (Guile?) + + (let-syntax ((test + (lambda (_) + (quasisyntax + '(list (unsyntax (+ 1 2)) 4))))) + (test)) + ;==> (list 3 4) + + (let-syntax ((test + (lambda (_) + (let ((name (syntax a))) + (quasisyntax '(list (unsyntax name) '(unsyntax name))))))) + (test)) + ;==> (list a 'a) + + (let-syntax ((test + (lambda (_) + (quasisyntax '(a (unsyntax (+ 1 2)) (unsyntax-splicing (map abs '(4 -5 6))) b))))) + (test)) + ;==> (a 3 4 5 6 b) + + (let-syntax ((test + (lambda (_) + (quasisyntax '((foo (unsyntax (- 10 3))) (unsyntax-splicing (cdr '(5))) . (unsyntax (car '(7)))))))) + (test)) + ;==> ((foo 7) . 7) + + (let-syntax ((test + (lambda (_) + (quasisyntax (unsyntax (+ 2 3)))))) + (test)) + ;==> 5 + + (let-syntax ((test + (lambda (_) + (quasisyntax + '(a (quasisyntax (b (unsyntax (+ 1 2)) (unsyntax (foo (unsyntax (+ 1 3)) d)) e)) f))))) + (test)) + ;==> (a (quasisyntax (b #,(+ 1 2) #,(foo 4 d) e)) f) + + (let-syntax ((test + (lambda (_) + (let ((name1 (syntax x)) (name2 (syntax y))) + (quasisyntax + '(a (quasisyntax (b (unsyntax (unsyntax name1)) (unsyntax (syntax (unsyntax name2))) d)) e)))))) + (test)) + ;==> (a (quasisyntax (b #,x #,(syntax y) d)) e) + + ;; Bawden's extensions: + + (let-syntax ((test + (lambda (_) + (quasisyntax '(a (unsyntax 1 2) b))))) + (test)) + ;==> (a 1 2 b) + + (let-syntax ((test + (lambda (_) + (quasisyntax '(a (unsyntax-splicing '(1 2) '(3 4)) b))))) + (test)) + ;==> (a 1 2 3 4 b) + + (let-syntax ((test + (lambda (_) + (let ((x (syntax (a b c)))) + (quasisyntax '(quasisyntax ((unsyntax (unsyntax x)) + (unsyntax-splicing (unsyntax x)) + (unsyntax (unsyntax-splicing x)) + (unsyntax-splicing (unsyntax-splicing x))))))))) + (test)) + + ;;==> (quasisyntax (#,(a b c) #,@(a b c) (unsyntax a b c) (unsyntax-splicing a b c))) + ;; which is equivalent to + ;; (quasisyntax (#,(a b c) #,@(a b c) #,a #,b #,c #,@a #,@b #,@c) + ;; in the Bawden prescripion + + ;; QUASIQUOTE tests: + + `(list ,(+ 1 2) 4) ;==> (list 3 4) + + (let ((name 'a)) `(list ,name ',name)) ;==> (list a (quote a)) + + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b) ;==> (a 3 4 5 6 b) + + `(( foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))) ;==> ((foo 7) . cons) + + `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8) ;==> #(10 5 2 4 3 8) + + (let ((name 'foo)) + `((unquote name name name))) ;==> (foo foo foo) + + (let ((name '(foo))) + `((unquote-splicing name name name))) ;==> (foo foo foo) + + (let ((q '((append x y) (sqrt 9)))) + ``(foo ,,@q)) ;==> `(foo (unquote (append x y) (sqrt 9))) + + (let ((x '(2 3)) + (y '(4 5))) + `(foo (unquote (append x y) (sqrt 9)))) ;==> (foo (2 3 4 5) 3) + + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) ;==> (a `(b ,(+ 1 2) ,(foo 4 d) e) f) + + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e)) ;==> (a `(b ,x ,'y d) e) + + ;; Test control library + + (import (rnrs control)) + + (when (> 3 2) 'greater) ;==> greater + (when (< 3 2) 'greater) ;==> unspecified + (unless (> 3 2) 'less) ;==> unspecified + (unless (< 3 2) 'less) ;==> less + + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i)) ;==> #(0 1 2 3 4) + + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum))) ;==> 25 + + (define foo + (case-lambda + (() 'zero) + ((x) (list 'one x)) + ((x y) (list 'two x y)) + ((a b c d . e) (list 'four a b c d e)) + (rest (list 'rest rest)))) + + (foo) ;==> zero + (foo 1) ;==> (one 1) + (foo 1 2) ;==> (two 1 2) + (foo 1 2 3) ;==> (rest (1 2 3)) + (foo 1 2 3 4) ;==> (four 1 2 3 4 ()) + + ;;;===================================================================== + ;;; + ;;; (RNRS R5RS): scheme-report-environment and null-environment + ;;; + ;;;===================================================================== + + (program + (import (rnrs base) + (rnrs io simple) + (rnrs eval) + (rnrs r5rs)) + + (display + (eval '(let ((x 1)) x) + (null-environment 5))) ;==> 1 + + (display + (eval '(let ((x (+ 1 2 3 4))) + (list x x)) + (scheme-report-environment 5))) ;==> (10 10) + + (let ((x (delay (begin (display 'boo))))) + (force x) + (force x)) ;==> displays "boo" once + ) + + ;;;===================================================================== + ;;; + ;;; Library (explicit-renaming) - tests and examples: + ;;; + ;;;===================================================================== + + (program + + (import (for (rnrs base) expand run) + (for (explicit-renaming) expand) + (rnrs io simple)) + + (define-syntax swap! + (er-transformer + (lambda (exp rename compare) + (let ((a (cadr exp)) + (b (caddr exp))) + `(,(rename 'let) ((,(rename 'temp) ,a)) + (,(rename 'set!) ,a ,b) + (,(rename 'set!) ,b ,(rename 'temp))))))) + + (let ((temp 1) + (set! 2)) + (swap! set! temp) + (values temp set!)) ;==> 2 1 + + ;; IMPLICIT IDENTIFIERS: + + ;; Datum->syntax must be used for implicit identifiers. + ;; The old trick of inserting a raw symbol to break hygiene + ;; will not work since the output must be a syntax object + ;; and may therefore not contain symbols. + ;; The old way of using raw symbols was unmodular anyway. + ;; To understand this, note that the syntax-rules + ;; definition of while below, which uses loop, would + ;; not have worked with the traditional way of using + ;; a raw symbol for exit. In other words, all macros + ;; depending on loop would have had to be defined using + ;; syntactic closures. This is not necessary any more. + ;; So datum->syntax gives better modularity. + + (define-syntax loop + (er-transformer + (lambda (x r c) + (let ((k (car x)) + (body (cdr x))) + `(,(r 'call-with-current-continuation) + (,(r 'lambda) (,(datum->syntax k 'exit)) + (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))) + + (let ((x 5)) + (loop (if (zero? x) + (exit #f)) + (display x) + (set! x (- x 1)))) ;==> 54321 + + (define-syntax while + (syntax-rules () + ((while test body ...) + (loop (if (not test) (exit #f)) + body ...)))) + + (let ((x 5)) + (while (> x 0) + (display x) + (set! x (- x 1)))) ;==> 54321 + + ;; TEST COMPARE PROCEDURE FOR LITERALS: + + ;; Note the last line differs from the paper, which uses + ;; the raw symbol simple-cond instead of (rename 'simple-cond). + ;; We may not have raw symbols in the output. + + (define-syntax simple-cond + (er-transformer + (lambda (exp rename compare) + (let ((clauses (cdr exp))) + (if (null? clauses) + `(,(rename 'quote) unspecified) + (let* ((first (car clauses)) + (rest (cdr clauses)) + (test (car first))) + (cond ((and (identifier? test) + (compare test (rename 'else))) + `(,(rename 'begin) ,@(cdr first))) + (else `(,(rename 'if) + ,test + (,(rename 'begin) ,@(cdr first)) + (,(rename 'simple-cond) ,@rest)))))))))) + + (simple-cond (#f 1) + (else 2)) ;==> 2 + + ) ; program + + )) ;; repl + +;;====================================================================== +;; +;; End of sample REPL session. +;; +;;====================================================================== + + +;;====================================================================== +;; +;; SAMPLE STATIC COMPILATION SCRIPTS: +;; +;; Example of compiling a set of libraries +;; and a program all in the same file: +;; +;;====================================================================== + +;; Compiling. + +(ex:expand-file "sample-libs-and-program.scm" "sample-libs-and-program.exp") + +;; Execute an expanded program in a new session as follows: +;; +;; - The runtime include file runtime.scm contains the +;; minimal bindings necessary to run a fully expanded +;; program that does not contain runtime uses of the +;; exports of (rnrs syntax-case) or (rnrs eval). +;; - Standard-libraries.exp contains the rnrs libraries object +;; code and must be loaded before the program is executed. +;; - Loading an expanded library registers it. +;; - Loading an expanded library does not visit or invoke it. +;; - Loading an expanded program runs it after invoking the +;; appropriate imported libraries. +;; - For programs that contain runtime uses of (rnrs syntax-case) +;; or (rnrs eval), you must load the full expander.scm instead +;; of just runtime.scm. Such programs are rare. + +;(load "runtime.scm") ; unnecessary in continuous session +;(load "standard-libraries.exp") ; unnecessary in continuous session +(load "sample-libs-and-program.exp") ;==> displays 3 + +;;====================================================================== +;; +;; Compiling: (see also example REPL session below) +;; +;; Example of compiling and executing a set of libraries +;; and programs all in different files, possibly in +;; different sessions: +;; +;;====================================================================== + +;; Expand-file requires dependencies to have been loaded. +;; For example, (party) imports (stack) and (balloons), so +;; expanded versions of the latter two must be loaded into +;; memory before expanding the former. +;; This is only necessary if we expand party in a new +;; session, which is not the case here, hence the commented +;; lines. + +;(load "expander.scm") ; unnecessary in continuous session +;(load "standard-libraries.exp") ; unnecessary in continuous session +(ex:expand-file "sample-stack.scm" "sample-stack.exp") +(ex:expand-file "sample-balloons.scm" "sample-balloons.exp") +;(load "sample-stack.exp") ; unnecessary in continuous session +;(load "sample-balloons.exp") ; unnecessary in continuous session +(ex:expand-file "sample-party.scm" "sample-party.exp") +;(load "sample-party.exp") ; unnecessary in continuous session +(ex:expand-file "sample-program.scm" "sample-program.exp") + +;; Execute the expanded program as follows: +;; Stuff commented out is only necessary if run in a +;; separate session. + +;(load "runtime.scm") ; unnecessary in continuous session +;(load "standard-libraries.exp") ; unnecessary in continuous session +(load "sample-stack.exp") +(load "sample-balloons.exp") +(load "sample-party.exp") +(load "sample-program.exp") ;==> displays Boom! 108 Boom! 24 + + addfile ./test/sample-balloons.exp hunk ./test/sample-balloons.exp 1 +(begin (define &pop~1207099906~3357 ex:unspecified) (define &push~1207099906~3356 ex:unspecified) (define &make~1207099906~3355 ex:unspecified) (ex:register-library! (ex:make-library '(balloons) (lambda () '()) '((make variable &make~1207099906~3355 (0) #f (balloons)) (push variable &push~1207099906~3356 (0) #f (balloons)) (pop variable &pop~1207099906~3357 (0) #f (balloons))) '(((rnrs) 0)) '(&build~1207093581~3194) (lambda () (values)) (lambda () (set! &pop~1207099906~3357 ex:undefined) (set! &push~1207099906~3356 ex:undefined) (set! &make~1207099906~3355 ex:undefined) (set! &make~1207099906~3355 (lambda (&w~1207099906~3364 &h~1207099906~3365) (cons &w~1207099906~3364 &h~1207099906~3365))) (set! &push~1207099906~3356 (lambda (&b~1207099906~3361 &amt~1207099906~3362) (cons (- (car &b~1207099906~3361) &amt~1207099906~3362) (+ (cdr &b~1207099906~3361) &amt~1207099906~3362)))) (set! &pop~1207099906~3357 (lambda (&b~1207099906~3359) (display "Boom! ") (display (* (car &b~1207099906~3359) (cdr &b~1207099906~3359))) (newline))) (values)) '&build~1207099906~3366)) (values)) addfile ./test/sample-balloons.scm hunk ./test/sample-balloons.scm 1 - +;;; +;;; Sample library - see macros-test.scm for +;;; compilation script +;;; + +(library (balloons) + + (export make push pop) + (import (rnrs)) + + (define (make w h) + (cons w h)) + + (define (push b amt) + (cons (- (car b) amt) (+ (cdr b) amt))) + + (define (pop b) + (display "Boom! ") + (display (* (car b) (cdr b))) + (newline))) addfile ./test/sample-libs-and-program.exp hunk ./test/sample-libs-and-program.exp 1 +(begin (define &find-dup~1207099906~3240 ex:unspecified) (ex:register-library! (ex:make-library '(my-helpers id-stuff) (lambda () '()) '((find-dup variable &find-dup~1207099906~3240 (0) #f (my-helpers id-stuff))) '(((rnrs) 0)) '(&build~1207093581~3194) (lambda () (values)) (lambda () (set! &find-dup~1207099906~3240 ex:undefined) (set! &find-dup~1207099906~3240 (lambda (&l~1207099906~3242) (if (pair? &l~1207099906~3242) (((lambda (&loop~1207099906~3250) ((lambda (&temp~1207099906~3253) (set! &loop~1207099906~3250 &temp~1207099906~3253) ((lambda () &loop~1207099906~3250))) (lambda (&rest~1207099906~3258) (if (null? &rest~1207099906~3258) (begin (&find-dup~1207099906~3240 (cdr &l~1207099906~3242))) (if (ex:bound-identifier=? (car &l~1207099906~3242) (car &rest~1207099906~3258)) (begin (car &rest~1207099906~3258)) (begin (&loop~1207099906~3250 (cdr &rest~1207099906~3258)))))))) ex:undefined) (cdr &l~1207099906~3242)) #f))) (values)) '&build~1207099906~3265)) (values)) +(begin (ex:register-library! (ex:make-library '(my-helpers value-stuff) (lambda () (ex:uncompress '(((&env~1207099906~3277 0 1 2 3)) (3 (((mvlet) macro &mvlet~1207099906~3266 (0) #f (my-helpers value-stuff)) ((delete-file) variable delete-file (0 1) #f ()) ((file-exists?) variable file-exists? (0 1) #f ()) ((bitwise-arithmetic-shift-right) variable bitwise-arithmetic-shift-right (0 1) #f ()) ((bitwise-arithmetic-shift-left) variable bitwise-arithmetic-shift-left (0 1) #f ()) ((bitwise-arithmetic-shift) variable bitwise-arithmetic-shift (0 1) #f ()) ((bitwise-reverse-bit-field) variable bitwise-reverse-bit-field (0 1) #f ()) ((bitwise-rotate-bit-field) variable bitwise-rotate-bit-field (0 1) #f ()) ((bitwise-copy-bit-field) variable bitwise-copy-bit-field (0 1) #f ()) ((bitwise-bit-field) variable bitwise-bit-field (0 1) #f ()) ((bitwise-copy-bit) variable bitwise-copy-bit (0 1) #f ()) ((bitwise-bit-set?) variable bitwise-bit-set? (0 1) #f ()) ((bitwise-first-bit-set) variable bitwise-first-bit-set (0 1) #f ()) ((bitwise-length) variable bitwise-length (0 1) #f ()) ((bitwise-bit-count) variable bitwise-bit-count (0 1) #f ()) ((bitwise-if) variable bitwise-if (0 1) #f ()) ((bitwise-xor) variable bitwise-xor (0 1) #f ()) ((bitwise-ior) variable bitwise-ior (0 1) #f ()) ((bitwise-and) variable bitwise-and (0 1) #f ()) ((bitwise-not) variable bitwise-not (0 1) #f ()) ((fixnum->flonum) variable fixnum->flonum (0 1) #f ()) ((flexpt) variable flexpt (0 1) #f ()) ((flsqrt) variable flsqrt (0 1) #f ()) ((flatan) variable flatan (0 1) #f ()) ((flacos) variable flacos (0 1) #f ()) ((flasin) variable flasin (0 1) #f ()) ((fltan) variable fltan (0 1) #f ()) ((flcos) variable flcos (0 1) #f ()) ((flsin) variable flsin (0 1) #f ()) ((fllog) variable fllog (0 1) #f ()) ((flexp) variable flexp (0 1) #f ()) ((flround) variable flround (0 1) #f ()) ((fltruncate) variable fltruncate (0 1) #f ()) ((flceiling) variable flceiling (0 1) #f ()) ((flfloor) variable flfloor (0 1) #f ()) ((fldenominator) variable fldenominator (0 1) #f ()) ((flnumerator) variable flnumerator (0 1) #f ()) ((flmod0) variable flmod0 (0 1) #f ()) ((fldiv0) variable fldiv0 (0 1) #f ()) ((fldiv0-and-mod0) variable fldiv0-and-mod0 (0 1) #f ()) ((flmod) variable flmod (0 1) #f ()) ((fldiv) variable fldiv (0 1) #f ()) ((fldiv-and-mod) variable fldiv-and-mod (0 1) #f ()) ((flabs) variable flabs (0 1) #f ()) ((fl/) variable fl/ (0 1) #f ()) ((fl-) variable fl- (0 1) #f ()) ((fl*) variable fl* (0 1) #f ()) ((fl+) variable fl+ (0 1) #f ()) ((flmin) variable flmin (0 1) #f ()) ((flmax) variable flmax (0 1) #f ()) ((flnan?) variable flnan? (0 1) #f ()) ((flinfinite?) variable flinfinite? (0 1) #f ()) ((flfinite?) variable flfinite? (0 1) #f ()) ((fleven?) variable fleven? (0 1) #f ()) ((flodd?) variable flodd? (0 1) #f ()) ((flnegative?) variable flnegative? (0 1) #f ()) ((flpositive?) variable flpositive? (0 1) #f ()) ((flzero?) variable flzero? (0 1) #f ()) ((flinteger?) variable flinteger? (0 1) #f ()) ((fl>=?) variable fl>=? (0 1) #f ()) ((fl<=?) variable fl<=? (0 1) #f ()) ((fl>?) variable fl>? (0 1) #f ()) ((flflonum) variable real->flonum (0 1) #f ()) ((flonum?) variable flonum? (0 1) #f ()) ((fxarithmetic-shift-right) variable fxarithmetic-shift-right (0 1) #f ()) ((fxarithmetic-shift-left) variable fxarithmetic-shift-left (0 1) #f ()) ((fxarithmetic-shift) variable fxarithmetic-shift (0 1) #f ()) ((fxreverse-bit-field) variable fxreverse-bit-field (0 1) #f ()) ((fxrotate-bit-field) variable fxrotate-bit-field (0 1) #f ()) ((fxcopy-bit-field) variable fxcopy-bit-field (0 1) #f ()) ((fxbit-field) variable fxbit-field (0 1) #f ()) ((fxcopy-bit) variable fxcopy-bit (0 1) #f ()) ((fxbit-set?) variable fxbit-set? (0 1) #f ()) ((fxfirst-bit-set) variable fxfirst-bit-set (0 1) #f ()) ((fxlength) variable fxlength (0 1) #f ()) ((fxbit-count) variable fxbit-count (0 1) #f ()) ((fxif) variable fxif (0 1) #f ()) ((fxxor) variable fxxor (0 1) #f ()) ((fxior) variable fxior (0 1) #f ()) ((fxand) variable fxand (0 1) #f ()) ((fxnot) variable fxnot (0 1) #f ()) ((fx*/carry) variable fx*/carry (0 1) #f ()) ((fx-/carry) variable fx-/carry (0 1) #f ()) ((fx+/carry) variable fx+/carry (0 1) #f ()) ((fxmod0) variable fxmod0 (0 1) #f ()) ((fxdiv0) variable fxdiv0 (0 1) #f ()) ((fxdiv0-and-mod0) variable fxdiv0-and-mod0 (0 1) #f ()) ((fxmod) variable fxmod (0 1) #f ()) ((fxdiv) variable fxdiv (0 1) #f ()) ((fxdiv-and-mod) variable fxdiv-and-mod (0 1) #f ()) ((fx*) variable fx* (0 1) #f ()) ((fx-) variable fx- (0 1) #f ()) ((fx+) variable fx+ (0 1) #f ()) ((fxmin) variable fxmin (0 1) #f ()) ((fxmax) variable fxmax (0 1) #f ()) ((fxeven?) variable fxeven? (0 1) #f ()) ((fxodd?) variable fxodd? (0 1) #f ()) ((fxnegative?) variable fxnegative? (0 1) #f ()) ((fxpositive?) variable fxpositive? (0 1) #f ()) ((fxzero?) variable fxzero? (0 1) #f ()) ((fx<=?) variable fx<=? (0 1) #f ()) ((fx>=?) variable fx>=? (0 1) #f ()) ((fx?) variable fx>? (0 1) #f ()) ((fx=?) variable fx=? (0 1) #f ()) ((greatest-fixnum) variable greatest-fixnum (0 1) #f ()) ((least-fixnum) variable least-fixnum (0 1) #f ()) ((fixnum-width) variable fixnum-width (0 1) #f ()) ((fixnum?) variable fixnum? (0 1) #f ()) ((record-field-mutable?) variable record-field-mutable? (0 1) #f ()) ((record-type-field-names) variable record-type-field-names (0 1) #f ()) ((record-type-opaque?) variable record-type-opaque? (0 1) #f ()) ((record-type-sealed?) variable record-type-sealed? (0 1) #f ()) ((record-type-generative?) variable record-type-generative? (0 1) #f ()) ((record-type-uid) variable record-type-uid (0 1) #f ()) ((record-type-parent) variable record-type-parent (0 1) #f ()) ((record-type-name) variable record-type-name (0 1) #f ()) ((record-rtd) variable record-rtd (0 1) #f ()) ((record?) variable record? (0 1) #f ()) ((record-mutator) variable record-mutator (0 1) #f ()) ((record-accessor) variable record-accessor (0 1) #f ()) ((record-predicate) variable record-predicate (0 1) #f ()) ((record-constructor) variable record-constructor (0 1) #f ()) ((make-record-constructor-descriptor) variable make-record-constructor-descriptor (0 1) #f ()) ((record-type-descriptor?) variable record-type-descriptor? (0 1) #f ()) ((make-record-type-descriptor) variable make-record-type-descriptor (0 1) #f ()) ((vector-sort!) variable &vector-merge-sort!~1207093581~2707 (0 1) #f (rnrs sorting)) ((vector-sort) variable &vector-merge-sort~1207093581~2708 (0 1) #f (rnrs sorting)) ((list-sort) variable &list-merge-sort~1207093581~2706 (0 1) #f (rnrs sorting)) ((string-normalize-nfkc) variable string-normalize-nfkc (0 1) #f ()) ((string-normalize-nfc) variable string-normalize-nfc (0 1) #f ()) ((string-normalize-nfkd) variable string-normalize-nfkd (0 1) #f ()) ((string-normalize-nfd) variable string-normalize-nfd (0 1) #f ()) ((string-ci>=?) variable string-ci>=? (0 1) #f ()) ((string-ci<=?) variable string-ci<=? (0 1) #f ()) ((string-ci>?) variable string-ci>? (0 1) #f ()) ((string-ci=?) variable char-ci>=? (0 1) #f ()) ((char-ci<=?) variable char-ci<=? (0 1) #f ()) ((char-ci>?) variable char-ci>? (0 1) #f ()) ((char-cidatum) variable ex:syntax->datum (0 1) #f ()) ((datum->syntax) variable ex:datum->syntax (0 1) #f ()) ((generate-temporaries) variable ex:generate-temporaries (0 1) #f ()) ((free-identifier=?) variable ex:free-identifier=? (0 1) #f ()) ((bound-identifier=?) variable ex:bound-identifier=? (0 1) #f ()) ((identifier?) variable ex:identifier? (0 1) #f ()) ((make-variable-transformer) variable ex:make-variable-transformer (0 1) #f ()) ((call/cc) variable call/cc (0 1) #f ()) ((assertion-violation) variable assertion-violation (0 1) #f ()) ((error) variable &error~1207093581~1524 (0 1) #f (rnrs base)) ((vector-for-each) variable vector-for-each (0 1) #f ()) ((vector-map) variable vector-map (0 1) #f ()) ((string-for-each) variable string-for-each (0 1) #f ()) ((symbol=?) variable symbol=? (0 1) #f ()) ((boolean=?) variable boolean=? (0 1) #f ()) ((exact-integer-sqrt) variable exact-integer-sqrt (0 1) #f ()) ((div0-and-mod0) variable div0-and-mod0 (0 1) #f ()) ((mod0) variable mod0 (0 1) #f ()) ((div0) variable div0 (0 1) #f ()) ((div-and-mod) variable div-and-mod (0 1) #f ()) ((mod) variable mod (0 1) #f ()) ((div) variable div (0 1) #f ()) ((nan?) variable nan? (0 1) #f ()) ((infinite?) variable infinite? (0 1) #f ()) ((finite?) variable finite? (0 1) #f ()) ((inexact) variable inexact (0 1) #f ()) ((exact) variable exact (0 1) #f ()) ((integer-valued?) variable integer-valued? (0 1) #f ()) ((rational-valued?) variable rational-valued? (0 1) #f ()) ((real-valued?) variable real-valued? (0 1) #f ()) ((zero?) variable zero? (0 1) #f ()) ((vector?) variable vector? (0 1) #f ()) ((vector-set!) variable vector-set! (0 1) #f ()) ((vector-ref) variable vector-ref (0 1) #f ()) ((vector-length) variable vector-length (0 1) #f ()) ((vector-fill!) variable vector-fill! (0 1) #f ()) ((vector->list) variable vector->list (0 1) #f ()) ((vector) variable vector (0 1) #f ()) ((values) variable values (0 1) #f ()) ((truncate) variable truncate (0 1) #f ()) ((tan) variable tan (0 1) #f ()) ((symbol?) variable symbol? (0 1) #f ()) ((symbol->string) variable symbol->string (0 1) #f ()) ((substring) variable substring (0 1) #f ()) ((string?) variable string? (0 1) #f ()) ((string>?) variable string>? (0 1) #f ()) ((string>=?) variable string>=? (0 1) #f ()) ((string=?) variable string=? (0 1) #f ()) ((stringsymbol) variable string->symbol (0 1) #f ()) ((string->number) variable string->number (0 1) #f ()) ((string->list) variable string->list (0 1) #f ()) ((string) variable string (0 1) #f ()) ((sqrt) variable sqrt (0 1) #f ()) ((sin) variable sin (0 1) #f ()) ((round) variable round (0 1) #f ()) ((reverse) variable reverse (0 1) #f ()) ((real?) variable real? (0 1) #f ()) ((real-part) variable real-part (0 1) #f ()) ((rationalize) variable rationalize (0 1) #f ()) ((rational?) variable rational? (0 1) #f ()) ((procedure?) variable procedure? (0 1) #f ()) ((positive?) variable positive? (0 1) #f ()) ((pair?) variable pair? (0 1) #f ()) ((odd?) variable odd? (0 1) #f ()) ((numerator) variable numerator (0 1) #f ()) ((number?) variable number? (0 1) #f ()) ((number->string) variable number->string (0 1) #f ()) ((null?) variable null? (0 1) #f ()) ((not) variable not (0 1) #f ()) ((negative?) variable negative? (0 1) #f ()) ((min) variable min (0 1) #f ()) ((max) variable max (0 1) #f ()) ((map) variable map (0 1) #f ()) ((make-vector) variable make-vector (0 1) #f ()) ((make-string) variable make-string (0 1) #f ()) ((make-rectangular) variable make-rectangular (0 1) #f ()) ((make-polar) variable make-polar (0 1) #f ()) ((magnitude) variable magnitude (0 1) #f ()) ((log) variable log (0 1) #f ()) ((list?) variable list? (0 1) #f ()) ((list-tail) variable list-tail (0 1) #f ()) ((list-ref) variable list-ref (0 1) #f ()) ((list->vector) variable list->vector (0 1) #f ()) ((list->string) variable list->string (0 1) #f ()) ((list) variable list (0 1) #f ()) ((length) variable length (0 1) #f ()) ((lcm) variable lcm (0 1) #f ()) ((integer?) variable integer? (0 1) #f ()) ((integer->char) variable integer->char (0 1) #f ()) ((inexact?) variable inexact? (0 1) #f ()) ((imag-part) variable imag-part (0 1) #f ()) ((gcd) variable gcd (0 1) #f ()) ((for-each) variable for-each (0 1) #f ()) ((floor) variable floor (0 1) #f ()) ((expt) variable expt (0 1) #f ()) ((exp) variable exp (0 1) #f ()) ((exact?) variable exact? (0 1) #f ()) ((even?) variable even? (0 1) #f ()) ((eqv?) variable eqv? (0 1) #f ()) ((equal?) variable equal? (0 1) #f ()) ((eq?) variable eq? (0 1) #f ()) ((dynamic-wind) variable dynamic-wind (0 1) #f ()) ((denominator) variable denominator (0 1) #f ()) ((cos) variable cos (0 1) #f ()) ((cons) variable cons (0 1) #f ()) ((complex?) variable complex? (0 1) #f ()) ((char>=?) variable char>=? (0 1) #f ()) ((char<=?) variable char<=? (0 1) #f ()) ((char>?) variable char>? (0 1) #f ()) ((charinteger) variable char->integer (0 1) #f ()) ((char?) variable char? (0 1) #f ()) ((ceiling) variable ceiling (0 1) #f ()) ((cddddr) variable cddddr (0 1) #f ()) ((cdddar) variable cdddar (0 1) #f ()) ((cddadr) variable cddadr (0 1) #f ()) ((cddaar) variable cddaar (0 1) #f ()) ((cdaddr) variable cdaddr (0 1) #f ()) ((cdadar) variable cdadar (0 1) #f ()) ((cdaadr) variable cdaadr (0 1) #f ()) ((cdaaar) variable cdaaar (0 1) #f ()) ((cadddr) variable cadddr (0 1) #f ()) ((caddar) variable caddar (0 1) #f ()) ((cadadr) variable cadadr (0 1) #f ()) ((cadaar) variable cadaar (0 1) #f ()) ((caaddr) variable caaddr (0 1) #f ()) ((caadar) variable caadar (0 1) #f ()) ((caaadr) variable caaadr (0 1) #f ()) ((caaaar) variable caaaar (0 1) #f ()) ((cdddr) variable cdddr (0 1) #f ()) ((cddar) variable cddar (0 1) #f ()) ((cdadr) variable cdadr (0 1) #f ()) ((cdaar) variable cdaar (0 1) #f ()) ((caddr) variable caddr (0 1) #f ()) ((cadar) variable cadar (0 1) #f ()) ((caadr) variable caadr (0 1) #f ()) ((caaar) variable caaar (0 1) #f ()) ((cddr) variable cddr (0 1) #f ()) ((cdar) variable cdar (0 1) #f ()) ((cadr) variable cadr (0 1) #f ()) ((caar) variable caar (0 1) #f ()) ((cdr) variable cdr (0 1) #f ()) ((car) variable car (0 1) #f ()) ((call-with-values) variable call-with-values (0 1) #f ()) ((call-with-current-continuation) variable call-with-current-continuation (0 1) #f ()) ((boolean?) variable boolean? (0 1) #f ()) ((angle) variable angle (0 1) #f ()) ((atan) variable atan (0 1) #f ()) ((asin) variable asin (0 1) #f ()) ((apply) variable apply (0 1) #f ()) ((append) variable append (0 1) #f ()) ((acos) variable acos (0 1) #f ()) ((abs) variable abs (0 1) #f ()) ((>=) variable >= (0 1) #f ()) ((>) variable > (0 1) #f ()) ((=) variable = (0 1) #f ()) ((<=) variable <= (0 1) #f ()) ((<) variable < (0 1) #f ()) ((/) variable / (0 1) #f ()) ((-) variable - (0 1) #f ()) ((+) variable + (0 1) #f ()) ((*) variable * (0 1) #f ()) ((identifier-syntax) macro &identifier-syntax~1207093581~501 (0 1) #f (core identifier-syntax)) ((syntax-rules) macro &syntax-rules~1207093581~69 (0 1) #f (core syntax-rules)) ((unquote-splicing) macro &unquote-splicing~1207093581~1212 (0 1) #f (core quasiquote)) ((unquote) macro &unquote~1207093581~1208 (0 1) #f (core quasiquote)) ((quasiquote) macro &quasiquote~1207093581~774 (0 1) #f (core quasiquote)) ((assert) macro &assert~1207093581~1525 (0 1) #f (rnrs base)) ((=>) macro &=>~1207093581~492 (0 1) #f (core derived)) ((else) macro &else~1207093581~496 (0 1) #f (core derived)) ((cond) macro &cond~1207093581~296 (0 1) #f (core derived)) ((case) macro &case~1207093581~412 (0 1) #f (core derived)) ((let*-values) macro &let*-values~1207093581~1357 (0 1) #f (core let-values)) ((let-values) macro &let-values~1207093581~1217 (0 1) #f (core let-values)) ((letrec*) macro &letrec*~1207093581~190 (0 1) #f (core let)) ((letrec) macro &letrec~1207093581~159 (0 1) #f (core let)) ((let*) macro &let*~1207093581~215 (0 1) #f (core derived)) ((let) macro &let~1207093581~111 (0 1) #f (core let)) ((...) macro ... (0 1) #f ()) ((_) macro _ (0 1) #f ()) ((letrec-syntax) macro letrec-syntax (0 1) #f ()) ((let-syntax) macro let-syntax (0 1) #f ()) ((define-syntax) macro define-syntax (0 1) #f ()) ((define) macro define (0 1) #f ()) ((or) macro or (0 1) #f ()) ((and) macro and (0 1) #f ()) ((set!) macro set! (0 2 1) #f ()) ((quote) macro quote (0 1) #f ()) ((lambda) macro lambda (0 1) #f ()) ((if) macro if (0 1) #f ()) ((begin) macro begin (0 1) #f ()) ((find-dup) variable &find-dup~1207099906~3240 (1) #f (my-helpers id-stuff)))) (2 (((stx) variable &stx~1207099906~3268 (1) #f (my-helpers value-stuff)))) (1 ()) (0 (((id) . #f) ((expr) . #f) ((body0) . #f) ((body) . #f)))))) '((mvlet macro &mvlet~1207099906~3266 (0) #f (my-helpers value-stuff))) '(((my-helpers id-stuff) 1) ((rnrs) 0)) '(&build~1207099906~3265 &build~1207093581~3194) (lambda () (ex:register-macro! '&mvlet~1207099906~3266 (lambda (&stx~1207099906~3268) (let ((&input~1207099906~3270 &stx~1207099906~3268)) (let ((&fail~1207099906~3271 (lambda () (ex:invalid-form &input~1207099906~3270)))) (if (pair? &input~1207099906~3270) (let ((&temp~1207099906~3288 (car &input~1207099906~3270))) (let ((&temp~1207099906~3279 (cdr &input~1207099906~3270))) (if (pair? &temp~1207099906~3279) (let ((&temp~1207099906~3283 (car &temp~1207099906~3279))) (if (pair? &temp~1207099906~3283) (let ((&temp~1207099906~3287 (car &temp~1207099906~3283))) (if (list? &temp~1207099906~3287) (let ((&id~1207099906~3272 &temp~1207099906~3287)) (let ((&temp~1207099906~3284 (cdr &temp~1207099906~3283))) (if (pair? &temp~1207099906~3284) (let ((&temp~1207099906~3286 (car &temp~1207099906~3284))) (let ((&expr~1207099906~3273 &temp~1207099906~3286)) (let ((&temp~1207099906~3285 (cdr &temp~1207099906~3284))) (if (null? &temp~1207099906~3285) (let ((&temp~1207099906~3280 (cdr &temp~1207099906~3279))) (if (pair? &temp~1207099906~3280) (let ((&temp~1207099906~3282 (car &temp~1207099906~3280))) (let ((&body0~1207099906~3274 &temp~1207099906~3282)) (let ((&temp~1207099906~3281 (cdr &temp~1207099906~3280))) (if (list? &temp~1207099906~3281) (let ((&body~1207099906~3275 &temp~1207099906~3281)) (if (not (&find-dup~1207099906~3240 &id~1207099906~3272)) (cons (ex:syntax-rename 'call-with-values '() '(&env~1207099906~3277) 0 '(my-helpers value-stuff)) (cons (cons (ex:syntax-rename 'lambda '() '(&env~1207099906~3277) 0 '(my-helpers value-stuff)) (cons '() (cons &expr~1207099906~3273 '()))) (cons (cons (ex:syntax-rename 'lambda '() '(&env~1207099906~3277) 0 '(my-helpers value-stuff)) (cons &id~1207099906~3272 (cons &body0~1207099906~3274 &body~1207099906~3275))) '()))) (&fail~1207099906~3271))) (&fail~1207099906~3271))))) (&fail~1207099906~3271))) (&fail~1207099906~3271))))) (&fail~1207099906~3271)))) (&fail~1207099906~3271))) (&fail~1207099906~3271))) (&fail~1207099906~3271)))) (&fail~1207099906~3271)))))) (values)) (lambda () (values)) '&build~1207099906~3289)) (values)) +(begin (define "ient+remainder~1207099906~3290 ex:unspecified) (ex:register-library! (ex:make-library '(let-div) (lambda () (ex:uncompress '(((&env~1207099906~3306 0 1 2 3)) (3 (((let-div) macro &let-div~1207099906~3291 (0) #f (let-div)) ((quotient+remainder) variable "ient+remainder~1207099906~3290 (0) #f (let-div)) ((delete-file) variable delete-file (0 1) #f ()) ((file-exists?) variable file-exists? (0 1) #f ()) ((bitwise-arithmetic-shift-right) variable bitwise-arithmetic-shift-right (0 1) #f ()) ((bitwise-arithmetic-shift-left) variable bitwise-arithmetic-shift-left (0 1) #f ()) ((bitwise-arithmetic-shift) variable bitwise-arithmetic-shift (0 1) #f ()) ((bitwise-reverse-bit-field) variable bitwise-reverse-bit-field (0 1) #f ()) ((bitwise-rotate-bit-field) variable bitwise-rotate-bit-field (0 1) #f ()) ((bitwise-copy-bit-field) variable bitwise-copy-bit-field (0 1) #f ()) ((bitwise-bit-field) variable bitwise-bit-field (0 1) #f ()) ((bitwise-copy-bit) variable bitwise-copy-bit (0 1) #f ()) ((bitwise-bit-set?) variable bitwise-bit-set? (0 1) #f ()) ((bitwise-first-bit-set) variable bitwise-first-bit-set (0 1) #f ()) ((bitwise-length) variable bitwise-length (0 1) #f ()) ((bitwise-bit-count) variable bitwise-bit-count (0 1) #f ()) ((bitwise-if) variable bitwise-if (0 1) #f ()) ((bitwise-xor) variable bitwise-xor (0 1) #f ()) ((bitwise-ior) variable bitwise-ior (0 1) #f ()) ((bitwise-and) variable bitwise-and (0 1) #f ()) ((bitwise-not) variable bitwise-not (0 1) #f ()) ((fixnum->flonum) variable fixnum->flonum (0 1) #f ()) ((flexpt) variable flexpt (0 1) #f ()) ((flsqrt) variable flsqrt (0 1) #f ()) ((flatan) variable flatan (0 1) #f ()) ((flacos) variable flacos (0 1) #f ()) ((flasin) variable flasin (0 1) #f ()) ((fltan) variable fltan (0 1) #f ()) ((flcos) variable flcos (0 1) #f ()) ((flsin) variable flsin (0 1) #f ()) ((fllog) variable fllog (0 1) #f ()) ((flexp) variable flexp (0 1) #f ()) ((flround) variable flround (0 1) #f ()) ((fltruncate) variable fltruncate (0 1) #f ()) ((flceiling) variable flceiling (0 1) #f ()) ((flfloor) variable flfloor (0 1) #f ()) ((fldenominator) variable fldenominator (0 1) #f ()) ((flnumerator) variable flnumerator (0 1) #f ()) ((flmod0) variable flmod0 (0 1) #f ()) ((fldiv0) variable fldiv0 (0 1) #f ()) ((fldiv0-and-mod0) variable fldiv0-and-mod0 (0 1) #f ()) ((flmod) variable flmod (0 1) #f ()) ((fldiv) variable fldiv (0 1) #f ()) ((fldiv-and-mod) variable fldiv-and-mod (0 1) #f ()) ((flabs) variable flabs (0 1) #f ()) ((fl/) variable fl/ (0 1) #f ()) ((fl-) variable fl- (0 1) #f ()) ((fl*) variable fl* (0 1) #f ()) ((fl+) variable fl+ (0 1) #f ()) ((flmin) variable flmin (0 1) #f ()) ((flmax) variable flmax (0 1) #f ()) ((flnan?) variable flnan? (0 1) #f ()) ((flinfinite?) variable flinfinite? (0 1) #f ()) ((flfinite?) variable flfinite? (0 1) #f ()) ((fleven?) variable fleven? (0 1) #f ()) ((flodd?) variable flodd? (0 1) #f ()) ((flnegative?) variable flnegative? (0 1) #f ()) ((flpositive?) variable flpositive? (0 1) #f ()) ((flzero?) variable flzero? (0 1) #f ()) ((flinteger?) variable flinteger? (0 1) #f ()) ((fl>=?) variable fl>=? (0 1) #f ()) ((fl<=?) variable fl<=? (0 1) #f ()) ((fl>?) variable fl>? (0 1) #f ()) ((flflonum) variable real->flonum (0 1) #f ()) ((flonum?) variable flonum? (0 1) #f ()) ((fxarithmetic-shift-right) variable fxarithmetic-shift-right (0 1) #f ()) ((fxarithmetic-shift-left) variable fxarithmetic-shift-left (0 1) #f ()) ((fxarithmetic-shift) variable fxarithmetic-shift (0 1) #f ()) ((fxreverse-bit-field) variable fxreverse-bit-field (0 1) #f ()) ((fxrotate-bit-field) variable fxrotate-bit-field (0 1) #f ()) ((fxcopy-bit-field) variable fxcopy-bit-field (0 1) #f ()) ((fxbit-field) variable fxbit-field (0 1) #f ()) ((fxcopy-bit) variable fxcopy-bit (0 1) #f ()) ((fxbit-set?) variable fxbit-set? (0 1) #f ()) ((fxfirst-bit-set) variable fxfirst-bit-set (0 1) #f ()) ((fxlength) variable fxlength (0 1) #f ()) ((fxbit-count) variable fxbit-count (0 1) #f ()) ((fxif) variable fxif (0 1) #f ()) ((fxxor) variable fxxor (0 1) #f ()) ((fxior) variable fxior (0 1) #f ()) ((fxand) variable fxand (0 1) #f ()) ((fxnot) variable fxnot (0 1) #f ()) ((fx*/carry) variable fx*/carry (0 1) #f ()) ((fx-/carry) variable fx-/carry (0 1) #f ()) ((fx+/carry) variable fx+/carry (0 1) #f ()) ((fxmod0) variable fxmod0 (0 1) #f ()) ((fxdiv0) variable fxdiv0 (0 1) #f ()) ((fxdiv0-and-mod0) variable fxdiv0-and-mod0 (0 1) #f ()) ((fxmod) variable fxmod (0 1) #f ()) ((fxdiv) variable fxdiv (0 1) #f ()) ((fxdiv-and-mod) variable fxdiv-and-mod (0 1) #f ()) ((fx*) variable fx* (0 1) #f ()) ((fx-) variable fx- (0 1) #f ()) ((fx+) variable fx+ (0 1) #f ()) ((fxmin) variable fxmin (0 1) #f ()) ((fxmax) variable fxmax (0 1) #f ()) ((fxeven?) variable fxeven? (0 1) #f ()) ((fxodd?) variable fxodd? (0 1) #f ()) ((fxnegative?) variable fxnegative? (0 1) #f ()) ((fxpositive?) variable fxpositive? (0 1) #f ()) ((fxzero?) variable fxzero? (0 1) #f ()) ((fx<=?) variable fx<=? (0 1) #f ()) ((fx>=?) variable fx>=? (0 1) #f ()) ((fx?) variable fx>? (0 1) #f ()) ((fx=?) variable fx=? (0 1) #f ()) ((greatest-fixnum) variable greatest-fixnum (0 1) #f ()) ((least-fixnum) variable least-fixnum (0 1) #f ()) ((fixnum-width) variable fixnum-width (0 1) #f ()) ((fixnum?) variable fixnum? (0 1) #f ()) ((record-field-mutable?) variable record-field-mutable? (0 1) #f ()) ((record-type-field-names) variable record-type-field-names (0 1) #f ()) ((record-type-opaque?) variable record-type-opaque? (0 1) #f ()) ((record-type-sealed?) variable record-type-sealed? (0 1) #f ()) ((record-type-generative?) variable record-type-generative? (0 1) #f ()) ((record-type-uid) variable record-type-uid (0 1) #f ()) ((record-type-parent) variable record-type-parent (0 1) #f ()) ((record-type-name) variable record-type-name (0 1) #f ()) ((record-rtd) variable record-rtd (0 1) #f ()) ((record?) variable record? (0 1) #f ()) ((record-mutator) variable record-mutator (0 1) #f ()) ((record-accessor) variable record-accessor (0 1) #f ()) ((record-predicate) variable record-predicate (0 1) #f ()) ((record-constructor) variable record-constructor (0 1) #f ()) ((make-record-constructor-descriptor) variable make-record-constructor-descriptor (0 1) #f ()) ((record-type-descriptor?) variable record-type-descriptor? (0 1) #f ()) ((make-record-type-descriptor) variable make-record-type-descriptor (0 1) #f ()) ((vector-sort!) variable &vector-merge-sort!~1207093581~2707 (0 1) #f (rnrs sorting)) ((vector-sort) variable &vector-merge-sort~1207093581~2708 (0 1) #f (rnrs sorting)) ((list-sort) variable &list-merge-sort~1207093581~2706 (0 1) #f (rnrs sorting)) ((string-normalize-nfkc) variable string-normalize-nfkc (0 1) #f ()) ((string-normalize-nfc) variable string-normalize-nfc (0 1) #f ()) ((string-normalize-nfkd) variable string-normalize-nfkd (0 1) #f ()) ((string-normalize-nfd) variable string-normalize-nfd (0 1) #f ()) ((string-ci>=?) variable string-ci>=? (0 1) #f ()) ((string-ci<=?) variable string-ci<=? (0 1) #f ()) ((string-ci>?) variable string-ci>? (0 1) #f ()) ((string-ci=?) variable char-ci>=? (0 1) #f ()) ((char-ci<=?) variable char-ci<=? (0 1) #f ()) ((char-ci>?) variable char-ci>? (0 1) #f ()) ((char-cidatum) variable ex:syntax->datum (0 1) #f ()) ((datum->syntax) variable ex:datum->syntax (0 1) #f ()) ((generate-temporaries) variable ex:generate-temporaries (0 1) #f ()) ((free-identifier=?) variable ex:free-identifier=? (0 1) #f ()) ((bound-identifier=?) variable ex:bound-identifier=? (0 1) #f ()) ((identifier?) variable ex:identifier? (0 1) #f ()) ((make-variable-transformer) variable ex:make-variable-transformer (0 1) #f ()) ((call/cc) variable call/cc (0 1) #f ()) ((assertion-violation) variable assertion-violation (0 1) #f ()) ((error) variable &error~1207093581~1524 (0 1) #f (rnrs base)) ((vector-for-each) variable vector-for-each (0 1) #f ()) ((vector-map) variable vector-map (0 1) #f ()) ((string-for-each) variable string-for-each (0 1) #f ()) ((symbol=?) variable symbol=? (0 1) #f ()) ((boolean=?) variable boolean=? (0 1) #f ()) ((exact-integer-sqrt) variable exact-integer-sqrt (0 1) #f ()) ((div0-and-mod0) variable div0-and-mod0 (0 1) #f ()) ((mod0) variable mod0 (0 1) #f ()) ((div0) variable div0 (0 1) #f ()) ((div-and-mod) variable div-and-mod (0 1) #f ()) ((mod) variable mod (0 1) #f ()) ((div) variable div (0 1) #f ()) ((nan?) variable nan? (0 1) #f ()) ((infinite?) variable infinite? (0 1) #f ()) ((finite?) variable finite? (0 1) #f ()) ((inexact) variable inexact (0 1) #f ()) ((exact) variable exact (0 1) #f ()) ((integer-valued?) variable integer-valued? (0 1) #f ()) ((rational-valued?) variable rational-valued? (0 1) #f ()) ((real-valued?) variable real-valued? (0 1) #f ()) ((zero?) variable zero? (0 1) #f ()) ((vector?) variable vector? (0 1) #f ()) ((vector-set!) variable vector-set! (0 1) #f ()) ((vector-ref) variable vector-ref (0 1) #f ()) ((vector-length) variable vector-length (0 1) #f ()) ((vector-fill!) variable vector-fill! (0 1) #f ()) ((vector->list) variable vector->list (0 1) #f ()) ((vector) variable vector (0 1) #f ()) ((values) variable values (0 1) #f ()) ((truncate) variable truncate (0 1) #f ()) ((tan) variable tan (0 1) #f ()) ((symbol?) variable symbol? (0 1) #f ()) ((symbol->string) variable symbol->string (0 1) #f ()) ((substring) variable substring (0 1) #f ()) ((string?) variable string? (0 1) #f ()) ((string>?) variable string>? (0 1) #f ()) ((string>=?) variable string>=? (0 1) #f ()) ((string=?) variable string=? (0 1) #f ()) ((stringsymbol) variable string->symbol (0 1) #f ()) ((string->number) variable string->number (0 1) #f ()) ((string->list) variable string->list (0 1) #f ()) ((string) variable string (0 1) #f ()) ((sqrt) variable sqrt (0 1) #f ()) ((sin) variable sin (0 1) #f ()) ((round) variable round (0 1) #f ()) ((reverse) variable reverse (0 1) #f ()) ((real?) variable real? (0 1) #f ()) ((real-part) variable real-part (0 1) #f ()) ((rationalize) variable rationalize (0 1) #f ()) ((rational?) variable rational? (0 1) #f ()) ((procedure?) variable procedure? (0 1) #f ()) ((positive?) variable positive? (0 1) #f ()) ((pair?) variable pair? (0 1) #f ()) ((odd?) variable odd? (0 1) #f ()) ((numerator) variable numerator (0 1) #f ()) ((number?) variable number? (0 1) #f ()) ((number->string) variable number->string (0 1) #f ()) ((null?) variable null? (0 1) #f ()) ((not) variable not (0 1) #f ()) ((negative?) variable negative? (0 1) #f ()) ((min) variable min (0 1) #f ()) ((max) variable max (0 1) #f ()) ((map) variable map (0 1) #f ()) ((make-vector) variable make-vector (0 1) #f ()) ((make-string) variable make-string (0 1) #f ()) ((make-rectangular) variable make-rectangular (0 1) #f ()) ((make-polar) variable make-polar (0 1) #f ()) ((magnitude) variable magnitude (0 1) #f ()) ((log) variable log (0 1) #f ()) ((list?) variable list? (0 1) #f ()) ((list-tail) variable list-tail (0 1) #f ()) ((list-ref) variable list-ref (0 1) #f ()) ((list->vector) variable list->vector (0 1) #f ()) ((list->string) variable list->string (0 1) #f ()) ((list) variable list (0 1) #f ()) ((length) variable length (0 1) #f ()) ((lcm) variable lcm (0 1) #f ()) ((integer?) variable integer? (0 1) #f ()) ((integer->char) variable integer->char (0 1) #f ()) ((inexact?) variable inexact? (0 1) #f ()) ((imag-part) variable imag-part (0 1) #f ()) ((gcd) variable gcd (0 1) #f ()) ((for-each) variable for-each (0 1) #f ()) ((floor) variable floor (0 1) #f ()) ((expt) variable expt (0 1) #f ()) ((exp) variable exp (0 1) #f ()) ((exact?) variable exact? (0 1) #f ()) ((even?) variable even? (0 1) #f ()) ((eqv?) variable eqv? (0 1) #f ()) ((equal?) variable equal? (0 1) #f ()) ((eq?) variable eq? (0 1) #f ()) ((dynamic-wind) variable dynamic-wind (0 1) #f ()) ((denominator) variable denominator (0 1) #f ()) ((cos) variable cos (0 1) #f ()) ((cons) variable cons (0 1) #f ()) ((complex?) variable complex? (0 1) #f ()) ((char>=?) variable char>=? (0 1) #f ()) ((char<=?) variable char<=? (0 1) #f ()) ((char>?) variable char>? (0 1) #f ()) ((charinteger) variable char->integer (0 1) #f ()) ((char?) variable char? (0 1) #f ()) ((ceiling) variable ceiling (0 1) #f ()) ((cddddr) variable cddddr (0 1) #f ()) ((cdddar) variable cdddar (0 1) #f ()) ((cddadr) variable cddadr (0 1) #f ()) ((cddaar) variable cddaar (0 1) #f ()) ((cdaddr) variable cdaddr (0 1) #f ()) ((cdadar) variable cdadar (0 1) #f ()) ((cdaadr) variable cdaadr (0 1) #f ()) ((cdaaar) variable cdaaar (0 1) #f ()) ((cadddr) variable cadddr (0 1) #f ()) ((caddar) variable caddar (0 1) #f ()) ((cadadr) variable cadadr (0 1) #f ()) ((cadaar) variable cadaar (0 1) #f ()) ((caaddr) variable caaddr (0 1) #f ()) ((caadar) variable caadar (0 1) #f ()) ((caaadr) variable caaadr (0 1) #f ()) ((caaaar) variable caaaar (0 1) #f ()) ((cdddr) variable cdddr (0 1) #f ()) ((cddar) variable cddar (0 1) #f ()) ((cdadr) variable cdadr (0 1) #f ()) ((cdaar) variable cdaar (0 1) #f ()) ((caddr) variable caddr (0 1) #f ()) ((cadar) variable cadar (0 1) #f ()) ((caadr) variable caadr (0 1) #f ()) ((caaar) variable caaar (0 1) #f ()) ((cddr) variable cddr (0 1) #f ()) ((cdar) variable cdar (0 1) #f ()) ((cadr) variable cadr (0 1) #f ()) ((caar) variable caar (0 1) #f ()) ((cdr) variable cdr (0 1) #f ()) ((car) variable car (0 1) #f ()) ((call-with-values) variable call-with-values (0 1) #f ()) ((call-with-current-continuation) variable call-with-current-continuation (0 1) #f ()) ((boolean?) variable boolean? (0 1) #f ()) ((angle) variable angle (0 1) #f ()) ((atan) variable atan (0 1) #f ()) ((asin) variable asin (0 1) #f ()) ((apply) variable apply (0 1) #f ()) ((append) variable append (0 1) #f ()) ((acos) variable acos (0 1) #f ()) ((abs) variable abs (0 1) #f ()) ((>=) variable >= (0 1) #f ()) ((>) variable > (0 1) #f ()) ((=) variable = (0 1) #f ()) ((<=) variable <= (0 1) #f ()) ((<) variable < (0 1) #f ()) ((/) variable / (0 1) #f ()) ((-) variable - (0 1) #f ()) ((+) variable + (0 1) #f ()) ((*) variable * (0 1) #f ()) ((identifier-syntax) macro &identifier-syntax~1207093581~501 (0 1) #f (core identifier-syntax)) ((syntax-rules) macro &syntax-rules~1207093581~69 (0 1) #f (core syntax-rules)) ((unquote-splicing) macro &unquote-splicing~1207093581~1212 (0 1) #f (core quasiquote)) ((unquote) macro &unquote~1207093581~1208 (0 1) #f (core quasiquote)) ((quasiquote) macro &quasiquote~1207093581~774 (0 1) #f (core quasiquote)) ((assert) macro &assert~1207093581~1525 (0 1) #f (rnrs base)) ((=>) macro &=>~1207093581~492 (0 1) #f (core derived)) ((else) macro &else~1207093581~496 (0 1) #f (core derived)) ((cond) macro &cond~1207093581~296 (0 1) #f (core derived)) ((case) macro &case~1207093581~412 (0 1) #f (core derived)) ((let*-values) macro &let*-values~1207093581~1357 (0 1) #f (core let-values)) ((let-values) macro &let-values~1207093581~1217 (0 1) #f (core let-values)) ((letrec*) macro &letrec*~1207093581~190 (0 1) #f (core let)) ((letrec) macro &letrec~1207093581~159 (0 1) #f (core let)) ((let*) macro &let*~1207093581~215 (0 1) #f (core derived)) ((let) macro &let~1207093581~111 (0 1) #f (core let)) ((...) macro ... (0 1) #f ()) ((_) macro _ (0 1) #f ()) ((letrec-syntax) macro letrec-syntax (0 1) #f ()) ((let-syntax) macro let-syntax (0 1) #f ()) ((define-syntax) macro define-syntax (0 1) #f ()) ((define) macro define (0 1) #f ()) ((or) macro or (0 1) #f ()) ((and) macro and (0 1) #f ()) ((set!) macro set! (0 2 1) #f ()) ((quote) macro quote (0 1) #f ()) ((lambda) macro lambda (0 1) #f ()) ((if) macro if (0 1) #f ()) ((begin) macro begin (0 1) #f ()) ((mvlet) macro &mvlet~1207099906~3266 (0) #f (my-helpers value-stuff)))) (2 (((x &c~1207099906~3292) variable &x~1207099906~3294 (0) #f (let-div)))) (1 ()) (0 (((dummy &c~1207099906~3292) . #f) ((n) . #f) ((d) . #f) ((q) . #f) ((r) . #f) ((body0) . #f) ((body) . #f)))))) '((let-div macro &let-div~1207099906~3291 (0) #f (let-div))) '(((my-helpers value-stuff) 0) ((rnrs) 0)) '(&build~1207099906~3289 &build~1207093581~3194) (lambda () (ex:register-macro! '&let-div~1207099906~3291 (lambda (&x~1207099906~3294) (let ((&input~1207099906~3296 &x~1207099906~3294)) (let ((&fail~1207099906~3297 (lambda () (ex:invalid-form &input~1207099906~3296)))) (if (pair? &input~1207099906~3296) (let ((&temp~1207099906~3320 (car &input~1207099906~3296))) (let ((&dummy~1207099906~3298 &temp~1207099906~3320)) (let ((&temp~1207099906~3307 (cdr &input~1207099906~3296))) (if (pair? &temp~1207099906~3307) (let ((&temp~1207099906~3319 (car &temp~1207099906~3307))) (let ((&n~1207099906~3299 &temp~1207099906~3319)) (let ((&temp~1207099906~3308 (cdr &temp~1207099906~3307))) (if (pair? &temp~1207099906~3308) (let ((&temp~1207099906~3318 (car &temp~1207099906~3308))) (let ((&d~1207099906~3300 &temp~1207099906~3318)) (let ((&temp~1207099906~3309 (cdr &temp~1207099906~3308))) (if (pair? &temp~1207099906~3309) (let ((&temp~1207099906~3313 (car &temp~1207099906~3309))) (if (pair? &temp~1207099906~3313) (let ((&temp~1207099906~3317 (car &temp~1207099906~3313))) (let ((&q~1207099906~3301 &temp~1207099906~3317)) (let ((&temp~1207099906~3314 (cdr &temp~1207099906~3313))) (if (pair? &temp~1207099906~3314) (let ((&temp~1207099906~3316 (car &temp~1207099906~3314))) (let ((&r~1207099906~3302 &temp~1207099906~3316)) (let ((&temp~1207099906~3315 (cdr &temp~1207099906~3314))) (if (null? &temp~1207099906~3315) (let ((&temp~1207099906~3310 (cdr &temp~1207099906~3309))) (if (pair? &temp~1207099906~3310) (let ((&temp~1207099906~3312 (car &temp~1207099906~3310))) (let ((&body0~1207099906~3303 &temp~1207099906~3312)) (let ((&temp~1207099906~3311 (cdr &temp~1207099906~3310))) (if (list? &temp~1207099906~3311) (let ((&body~1207099906~3304 &temp~1207099906~3311)) (cons (ex:syntax-rename 'mvlet '() '(&env~1207099906~3306) 0 '(let-div)) (cons (cons (cons &q~1207099906~3301 (cons &r~1207099906~3302 '())) (cons (cons (ex:syntax-rename 'quotient+remainder '() '(&env~1207099906~3306) 0 '(let-div)) (cons &n~1207099906~3299 (cons &d~1207099906~3300 '()))) '())) (cons &body0~1207099906~3303 &body~1207099906~3304)))) (&fail~1207099906~3297))))) (&fail~1207099906~3297))) (&fail~1207099906~3297))))) (&fail~1207099906~3297))))) (&fail~1207099906~3297))) (&fail~1207099906~3297))))) (&fail~1207099906~3297))))) (&fail~1207099906~3297))))) (&fail~1207099906~3297)))))) (values)) (lambda () (set! "ient+remainder~1207099906~3290 ex:undefined) (set! "ient+remainder~1207099906~3290 (lambda (&n~1207099906~3322 &d~1207099906~3323) ((lambda (&q~1207099906~3326) (values &q~1207099906~3326 (- &n~1207099906~3322 (* &q~1207099906~3326 &d~1207099906~3323)))) (floor (/ &n~1207099906~3322 &d~1207099906~3323))))) (values)) '&build~1207099906~3327)) (values)) +(begin (ex:import-libraries-for-run '(((rnrs) 0) ((let-div) 0)) '(&build~1207093581~3194 &build~1207099906~3327) 0) (display (call-with-values (lambda () ("ient+remainder~1207099906~3290 5 2)) (lambda (&q~1207099906~3333 &r~1207099906~3334) (+ &q~1207099906~3333 &r~1207099906~3334))))) addfile ./test/sample-libs-and-program.scm hunk ./test/sample-libs-and-program.scm 1 +;;; +;;; Joint compilation example: +;;; +;;; Libraries and program all in the same file. +;;; +;;; See macros-test.scm for compilation script. +;;; + +(library (my-helpers id-stuff) + (export find-dup) + (import (rnrs)) + + (define (find-dup l) + (and (pair? l) + (let loop ((rest (cdr l))) + (cond ((null? rest) + (find-dup (cdr l))) + ((bound-identifier=? (car l) (car rest)) + (car rest)) + (else (loop (cdr rest)))))))) + +(library (my-helpers value-stuff) + (export mvlet) + (import (rnrs) + (for (my-helpers id-stuff) expand)) + + (define-syntax mvlet + (lambda (stx) + (syntax-case stx () + ((_ ((id ...) expr) body0 body ...) + (not (find-dup (syntax (id ...)))) + (syntax + (call-with-values + (lambda () expr) + (lambda (id ...) body0 body ...)))))))) + +(library (let-div) + (export let-div) + (import (rnrs) (my-helpers value-stuff)) + + (define (quotient+remainder n d) + (let ((q (floor (/ n d)))) + (values q (- n (* q d))))) + + (define-syntax let-div + (syntax-rules () + ((_ n d (q r) body0 body ...) + (mvlet ((q r) (quotient+remainder n d)) + body0 body ...))))) + +;;; +;;; Start of program: +;;; + +(import (let-div) (rnrs)) + +(display (let-div 5 2 (q r) (+ q r))) ;==> displays 3 + addfile ./test/sample-party.exp hunk ./test/sample-party.exp 1 +(begin (define &party-pop!~1207099906~3369 ex:unspecified) (define &make-party~1207099906~3368 ex:unspecified) (ex:register-library! (ex:make-library '(party) (lambda () '()) '((make variable &make~1207099906~3355 (0) #f (balloons)) (push variable &push~1207099906~3356 (0) #f (balloons)) (push! variable &push!~1207099906~3337 (0) #f (stack)) (make-party variable &make-party~1207099906~3368 (0) #f (party)) (pop! variable &party-pop!~1207099906~3369 (0) #f (party))) '(((balloons) 0) ((stack) 0) ((rnrs) 0)) '(&build~1207099906~3366 &build~1207099906~3353 &build~1207093581~3194) (lambda () (values)) (lambda () (set! &party-pop!~1207099906~3369 ex:undefined) (set! &make-party~1207099906~3368 ex:undefined) (set! &make-party~1207099906~3368 (lambda () ((lambda (&s~1207099906~3375) (&push!~1207099906~3337 &s~1207099906~3375 (&make~1207099906~3355 10 10)) (&push!~1207099906~3337 &s~1207099906~3375 (&make~1207099906~3355 12 9)) &s~1207099906~3375) (&make~1207099906~3336)))) (set! &party-pop!~1207099906~3369 (lambda (&p~1207099906~3371) (&pop~1207099906~3357 (&pop!~1207099906~3338 &p~1207099906~3371)))) (values)) '&build~1207099906~3376)) (values)) addfile ./test/sample-party.scm hunk ./test/sample-party.scm 1 - +;;; +;;; Sample library - see macros-test.scm for +;;; compilation script +;;; + +(library (party) + + (export (rename (balloon:make make) (balloon:push push)) + push! make-party + (rename (party-pop! pop!))) + (import (only (rnrs) define let) + (only (stack) make push! pop!) ;; not empty! + (prefix (balloons) balloon:)) + + ;; Creates a party as a stack of balloons, starting with + ;; two balloons + (define (make-party) + (let ((s (make))) ;; from stack + (push! s (balloon:make 10 10)) + (push! s (balloon:make 12 9)) s)) + + (define (party-pop! p) + (balloon:pop (pop! p)))) addfile ./test/sample-program.exp hunk ./test/sample-program.exp 1 +(begin (ex:import-libraries-for-run '(((party) 0) ((rnrs) 0)) '(&build~1207099906~3376 &build~1207093581~3194) 0) (define &p~1207099906~3379 (&make-party~1207099906~3368)) (&party-pop!~1207099906~3369 &p~1207099906~3379) (&push!~1207099906~3337 &p~1207099906~3379 (&push~1207099906~3356 (&make~1207099906~3355 5 5) 1)) (&party-pop!~1207099906~3369 &p~1207099906~3379)) addfile ./test/sample-program.scm hunk ./test/sample-program.scm 1 - +;;; +;;; Separate compilation example: +;;; +;;; See macros-test.scm for compilation script. +;;; + + +;; Start of program + +(import (rnrs) (party)) + +(define p (make-party)) +(pop! p) ;; displays "Boom! 108" +(push! p (push (make 5 5) 1)) +(pop! p) ;; displays "Boom! 24" addfile ./test/sample-stack.exp hunk ./test/sample-stack.exp 1 +(begin (define &empty!~1207099906~3339 ex:unspecified) (define &pop!~1207099906~3338 ex:unspecified) (define &push!~1207099906~3337 ex:unspecified) (define &make~1207099906~3336 ex:unspecified) (ex:register-library! (ex:make-library '(stack) (lambda () '()) '((make variable &make~1207099906~3336 (0) #f (stack)) (push! variable &push!~1207099906~3337 (0) #f (stack)) (pop! variable &pop!~1207099906~3338 (0) #f (stack)) (empty! variable &empty!~1207099906~3339 (0) #f (stack))) '(((rnrs mutable-pairs) 0) ((rnrs) 0)) '(&build~1207093581~3195 &build~1207093581~3194) (lambda () (values)) (lambda () (set! &empty!~1207099906~3339 ex:undefined) (set! &pop!~1207099906~3338 ex:undefined) (set! &push!~1207099906~3337 ex:undefined) (set! &make~1207099906~3336 ex:undefined) (set! &make~1207099906~3336 (lambda () (list '()))) (set! &push!~1207099906~3337 (lambda (&s~1207099906~3349 &v~1207099906~3350) (set-car! &s~1207099906~3349 (cons &v~1207099906~3350 (car &s~1207099906~3349))))) (set! &pop!~1207099906~3338 (lambda (&s~1207099906~3344) ((lambda (&v~1207099906~3347) (set-car! &s~1207099906~3344 (cdar &s~1207099906~3344)) &v~1207099906~3347) (caar &s~1207099906~3344)))) (set! &empty!~1207099906~3339 (lambda (&s~1207099906~3341) (set-car! &s~1207099906~3341 '()))) (values)) '&build~1207099906~3353)) (values)) addfile ./test/sample-stack.scm hunk ./test/sample-stack.scm 1 - +;;; +;;; Sample library - see macros-test.scm for +;;; compilation script +;;; + +(library (stack) + (export make push! pop! empty!) + (import (rnrs) + (rnrs mutable-pairs)) + + (define (make) + (list '())) + + (define (push! s v) + (set-car! s (cons v (car s)))) + + (define (pop! s) + (let ((v (caar s))) (set-car! s (cdar s)) v)) + + (define (empty! s) + (set-car! s '())) + ) addfile ./test/test-bytevectors hunk ./test/test-bytevectors 1 +#!/usr/bin/env gsi +; vim: syntax=scheme +(load "../r6rs") + +(ex:repl '( + (program + (import (rnrs base) (rnrs control) (rnrs bytevectors) + (gambit io) (gambit extensions)) + (let ((utf (string->utf8 "Hello"))) + (pp utf) + (pp (utf8->string utf)))))) addfile ./test/test-types.scm hunk ./test/test-types.scm 1 +(load "../r6rs.o1") +(define test-rtd (make-record-type-descriptor 'test #f #f #f #f '#((mutable a) (immutable b)))) + +(define make-test (record-constructor test-rtd)) +(define get-a (record-accessor test-rtd 0)) +(define get-b (record-accessor test-rtd 1)) +(define set-a (record-mutator test-rtd 0)) +(define test? (record-predicate test-rtd)) + +(let ((instance (make-test 'a 'b))) + (pp (test? instance)) + (pp (get-a instance)) + (pp (get-b instance)) + (pp set-a) + (set-a instance 'c) + (pp (get-a instance)))