123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149 |
- ;;; prelude, using scheme9 as an example
- ;;; R7RS syntax/procedures
- (define values list)
- (define (DEFINE-VALUES-WITH-VALUES name-list expr-list)
- (cons 'begin (map (lambda (a b)
- (list 'define a b))
- name-list
- expr-list)))
- (define-syntax define-values
- (syntax-rules ()
- ((_ (name ...) expr)
- (eval
- (DEFINE-VALUES-WITH-VALUES
- (list 'name ...)
- (map (lambda (e) (list 'quote e)) expr))))))
- (define exact inexact->exact)
- (define inexact exact->inexact)
- (define (vector->string v) (list->string (vector->list v)))
- (define (string->vector s) (list->vector (string->list s)))
- (define (square n) (* n n))
- (define (exact-integer? n)
- (and (integer? n)
- (exact? n)))
- (define-syntax case-lambda
- (syntax-rules ()
- ((_ (cnt . behavior) ...)
- (let ((lams (list (cons (length 'cnt)
- (lambda cnt . behavior))
- ...)))
- (lambda args
- (apply (cdr (assv (length args) lams)) args))))))
- (define iota
- (case-lambda
- ((size) (iota size 0))
- ((size start) (iota size start 1))
- ((size start step)
- (let loop ((result '())
- (i start)
- (count 0))
- (if (< count size)
- (loop (cons i result)
- (+ i step)
- (+ count 1))
- (reverse result))))))
- (define make-list
- (case-lambda
- ((sz) (make-list sz #f))
- ((sz value)
- (let loop ((result '())
- (count 0))
- (if (< count sz)
- (loop (cons value result)
- (+ count 1))
- result)))))
- (define (reduce proc init l)
- (if (null? l)
- init
- (let loop ((value (car l))
- (next (cdr l)))
- (if (null? next)
- value
- (loop (proc value (car next))
- (cdr next))))))
- ;;; R7RS libraries
- (define defined-library-list '())
- (define loaded-library-list '())
- (define (from-defined-to-loaded library-name)
- (define lib (cdr (assoc library-name defined-library-list)))
- (let ()
- (load-library-include library-name (car (cdr (assq 'include lib))))
- (eval (list 'values (cdr (assq 'export lib))))))
- (define (get-library-path-name library-name)
- (let loop ((result '("./"))
- (next library-name))
- (if (null? next)
- (apply string-append (reverse (cons ".sld" (cdr result))))
- (loop (cons "/" (cons (symbol->string (car next)) result))
- (cdr next)))))
- (define (load-library-path library-name)
- (unless (assoc library-name defined-library-list)
- (load (get-library-path-name library-name))))
- (define (get-library-include-name library-name include-name)
- (let loop ((result '("./"))
- (next library-name))
- (if (null? next)
- (apply string-append (reverse (cons include-name (cdr (cdr result)))))
- (loop (cons "/" (cons (symbol->string (car next)) result))
- (cdr next)))))
- (define (load-library-include library-name include-name)
- (load (get-library-include-name library-name include-name)))
- (define (parse-define-library library-expression)
- (define exports (assq 'export library-expression))
- (define imports (assq 'import library-expression))
- (define includes (assq 'include library-expression))
- (define begins (assq 'begin library-expression))
- (list imports exports includes begins))
- (define (add-to-library name library-expression)
- (set! defined-library-list
- (cons (cons name (parse-define-library library-expression))
- defined-library-list)))
- (define-syntax define-library
- (syntax-rules ()
- ((_ name . expression)
- (add-to-library 'name 'expression))))
- (define-syntax import
- (syntax-rules ()
- ((_ (base-name name ...))
- (let ((lib-name '(base-name name ...)))
- (load-library-path lib-name)
- (from-defined-to-loaded lib-name)))
- ((_ (base-name name ...) others ...)
- (begin
- (import (base-name name ...))
- (import others ...)))))
- (define-syntax export
- (syntax-rules ()
- ((_ . any) #f)))
- (define-syntax include
- (syntax-rules ()
- ((_ path)
- (load path))))
|