R5-to-R7-bridge/prelude.scm

;;; 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))))