code:
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2006 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; "test.scm" Test correctness of scheme implementations.
;;; Author: Aubrey Jaffer
;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
;;; won't pass.  Made the the tests (test-cont), (test-sc4), and
;;; (test-delay) start to run automatically.

;;; This includes examples from
;;; William Clinger and Jonathan Rees, editors.
;;; Revised^4 Report on the Algorithmic Language Scheme
;;; and the IEEE specification.

;;; The input tests read this file expecting it to be named
;;; "test.scm", so you'll have to run it from the ice-9 source
;;; directory, or copy this file elsewhere
;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
;;; these tests.  You may need to delete them in order to run
;;; "test.scm" more than once.

;;;   There are three optional tests:
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
;;;
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
;;;
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
;;;   either standard.

;;; If you are testing a R3RS version which does not have `list?' do:
;;; (define list? #f)

;;; send corrections or additions to jaffer@ai.mit.edu or
;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA

(define cur-section '())(define errs '())
(define SECTION (lambda args
		  (display "SECTION") (write args) (newline)
		  (set! cur-section args) #t))
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))

(define test
  (lambda (expect fun . args)
    (write (cons fun args))
    (display "  ==> ")
    ((lambda (res)
      (write res)
      (newline)
      (cond ((not (equal? expect res))
	     (record-error (list res expect (cons fun args)))
	     (display " BUT EXPECTED ")
	     (write expect)
	     (newline)
	     #f)
	    (else #t)))
     (if (procedure? fun) (apply fun args) (car args)))))
(define (report-errs)
  (newline)
  (if (null? errs) (display "Passed all tests")
      (begin
	(display "errors were:")
	(newline)
	(display "(SECTION (got expected (call)))")
	(newline)
	(for-each (lambda (l) (write l) (newline))
		  errs)))
  (newline))

(SECTION 2 1);; test that all symbol characters are supported.
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)

(SECTION 3 4)
(define disjoint-type-functions
  (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples
  (list
   #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
(define i 1)
(for-each (lambda (x) (display (make-string i #\ ))
		  (set! i (+ 3 i))
		  (write x)
		  (newline))
	  disjoint-type-functions)
(define type-matrix
  (map (lambda (x)
	 (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
	   (write t)
	   (write x)
	   (newline)
	   t))
       type-examples))
(SECTION 4 1 2)
(test '(quote a) 'quote (quote 'a))
(test '(quote a) 'quote ''a)
(SECTION 4 1 3)
(test 12 (if #f + *) 3 4)
(SECTION 4 1 4)
(test 8 (lambda (x) (+ x x)) 4)
(define reverse-subtract
  (lambda (x y) (- y x)))
(test 3 reverse-subtract 7 10)
(define add4
  (let ((x 4))
    (lambda (y) (+ x y))))
(test 10 add4 6)
(test '(3 4 5 6) (lambda x x) 3 4 5 6)
(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
(SECTION 4 1 5)
(test 'yes 'if (if (> 3 2) 'yes 'no))
(test 'no 'if (if (> 2 3) 'yes 'no))
(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
(SECTION 4 1 6)
(define x 2)
(test 3 'define (+ x 1))
(set! x 4)
(test 5 'set! (+ x 1))
(SECTION 4 2 1)
(test 'greater 'cond (cond ((> 3 2) 'greater)
			   ((< 3 2) 'less)))
(test 'equal 'cond (cond ((> 3 3) 'greater)
			 ((< 3 3) 'less)
			 (else 'equal)))
(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
		     (else #f)))
(test 'composite 'case (case (* 2 3)
			 ((2 3 5 7) 'prime)
			 ((1 4 6 8 9) 'composite)))
(test 'consonant 'case (case (car '(c d))
			 ((a e i o u) 'vowel)
			 ((w y) 'semivowel)
			 (else 'consonant)))
(test #t 'and (and (= 2 2) (> 2 1)))
(test #f 'and (and (= 2 2) (< 2 1)))
(test '(f g) 'and (and 1 2 'c '(f g)))
(test #t 'and (and))
(test #t 'or (or (= 2 2) (> 2 1)))
(test #t 'or (or (= 2 2) (< 2 1)))
(test #f 'or (or #f #f #f))
(test #f 'or (or))
(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
(SECTION 4 2 2)
(test 6 'let (let ((x 2) (y 3)) (* x y)))
(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
(test #t 'letrec (letrec ((even?
			   (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
			  (odd?
			   (lambda (n) (if (zero? n) #f (even? (- n 1))))))
		   (even? 88)))
(define x 34)
(test 5 'let (let ((x 3)) (define x 5) x))
(test 34 'let x)
(test 6 'let (let () (define x 6) x))
(test 34 'let x)
(test 7 'let* (let* ((x 3)) (define x 7) x))
(test 34 'let* x)
(test 8 'let* (let* () (define x 8) x))
(test 34 'let* x)
(test 9 'letrec (letrec () (define x 9) x))
(test 34 'letrec x)
(test 10 'letrec (letrec ((x 3)) (define x 10) x))
(test 34 'letrec x)
(SECTION 4 2 3)
(define x 0)
(test 6 'begin (begin (set! x 5) (+ x 1)))
(SECTION 4 2 4)
(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
			    (i 0 (+ i 1)))
			   ((= i 5) vec)
			 (vector-set! vec i i)))
(test 25 'do (let ((x '(1 3 5 7 9)))
	       (do ((x x (cdr x))
		    (sum 0 (+ sum (car x))))
		   ((null? x) sum))))
(test 1 'let (let foo () 1))
(test '((6 1 3) (-5 -2)) 'let
      (let loop ((numbers '(3 -2 1 6 -5))
		 (nonneg '())
		 (neg '()))
	(cond ((null? numbers) (list nonneg neg))
	      ((negative? (car numbers))
	       (loop (cdr numbers)
		     nonneg
		     (cons (car numbers) neg)))
	      (else
	       (loop (cdr numbers)
		     (cons (car numbers) nonneg)
		     neg)))))
(SECTION 4 2 6)
(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
(test '((foo 7) . cons)
	'quasiquote
	`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))

;;; sqt is defined here because not all implementations are required to
;;; support it.
(define (sqt x)
	(do ((i 0 (+ i 1)))
	    ((> (* i i) x) (- i 1))))

(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
(test 5 'quasiquote `,(+ 2 3))
(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
      'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
(test '(a `(b ,x ,'y d) e) 'quasiquote
	(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
(SECTION 5 2 1)
(define add3 (lambda (x) (+ x 3)))
(test 6 'define (add3 3))
(define first car)
(test 1 'define (first '(1 2)))
(SECTION 5 2 2)
(test 45 'define
	(let ((x 5))
		(define foo (lambda (y) (bar x y)))
		(define bar (lambda (a b) (+ (* a b) a)))
		(foo (+ x 3))))
(define x 34)
(define (foo) (define x 5) x)
(test 5 foo)
(test 34 'define x)
(define foo (lambda () (define x 5) x))
(test 5 foo)
(test 34 'define x)
(define (foo x) ((lambda () (define x 5) x)) x)
(test 88 foo 88)
(test 4 foo 4)
(test 34 'define x)
(SECTION 6 1)
(test #f not #t)
(test #f not 3)
(test #f not (list 3))
(test #t not #f)
(test #f not '())
(test #f not (list))
(test #f not 'nil)

(test #t boolean? #f)
(test #f boolean? 0)
(test #f boolean? '())
(SECTION 6 2)
(test #t eqv? 'a 'a)
(test #f eqv? 'a 'b)
(test #t eqv? 2 2)
(test #t eqv? '() '())
(test #t eqv? '10000 '10000)
(test #f eqv? (cons 1 2)(cons 1 2))
(test #f eqv? (lambda () 1) (lambda () 2))
(test #f eqv? #f 'nil)
(let ((p (lambda (x) x)))
  (test #t eqv? p p))
(define gen-counter
 (lambda ()
   (let ((n 0))
      (lambda () (set! n (+ n 1)) n))))
(let ((g (gen-counter))) (test #t eqv? g g))
(test #f eqv? (gen-counter) (gen-counter))
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
	 (g (lambda () (if (eqv? f g) 'g 'both))))
  (test #f eqv? f g))

(test #t eq? 'a 'a)
(test #f eq? (list 'a) (list 'a))
(test #t eq? '() '())
(test #t eq? car car)
(let ((x '(a))) (test #t eq? x x))
(let ((x '#())) (test #t eq? x x))
(let ((x (lambda (x) x))) (test #t eq? x x))

(test #t equal? 'a 'a)
(test #t equal? '(a) '(a))
(test #t equal? '(a (b) c) '(a (b) c))
(test #t equal? "abc" "abc")
(test #t equal? 2 2)
(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
(SECTION 6 3)
(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
(define x (list 'a 'b 'c))
(define y x)
(and list? (test #t list? y))
(set-cdr! x 4)
(test '(a . 4) 'set-cdr! x)
(test #t eqv? x y)
(test '(a b c . d) 'dot '(a . (b . (c . d))))
(and list? (test #f list? y))
(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))

(test #t pair? '(a . b))
(test #t pair? '(a . 1))
(test #t pair? '(a b c))
(test #f pair? '())
(test #f pair? '#(a b))

(test '(a) cons 'a '())
(test '((a) b c d) cons '(a) '(b c d))
(test '("a" b c) cons "a" '(b c))
(test '(a . 3) cons 'a 3)
(test '((a b) . c) cons '(a b) 'c)

(test 'a car '(a b c))
(test '(a) car '((a) b c d))
(test 1 car '(1 . 2))

(test '(b c d) cdr '((a) b c d))
(test 2 cdr '(1 . 2))

(test '(a 7 c) list 'a (+ 3 4) 'c)
(test '() list)

(test 3 length '(a b c))
(test 3 length '(a (b) (c d e)))
(test 0 length '())

(test '(x y) append '(x) '(y))
(test '(a b c d) append '(a) '(b c d))
(test '(a (b) (c)) append '(a (b)) '((c)))
(test '() append)
(test '(a b c . d) append '(a b) '(c . d))
(test 'a append '() 'a)

(test '(c b a) reverse '(a b c))
(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))

(test 'c list-ref '(a b c d) 2)

(test '(a b c) memq 'a '(a b c))
(test '(b c) memq 'b '(a b c))
(test '#f memq 'a '(b c d))
(test '#f memq (list 'a) '(b (a) c))
(test '((a) c) member (list 'a) '(b (a) c))
(test '(101 102) memv 101 '(100 101 102))

(define e '((a 1) (b 2) (c 3)))
(test '(a 1) assq 'a e)
(test '(b 2) assq 'b e)
(test #f assq 'd e)
(test #f assq (list 'a) '(((a)) ((b)) ((c))))
(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
(SECTION 6 4)
(test #t symbol? 'foo)
(test #t symbol? (car '(a b)))
(test #f symbol? "bar")
(test #t symbol? 'nil)
(test #f symbol? '())
(test #f symbol? #f)
;;; But first, what case are symbols in?  Determine the standard case:
(define char-standard-case char-upcase)
(if (string=? (symbol->string 'A) "a")
    (set! char-standard-case char-downcase))
;;; Not for Guile
;(test #t 'standard-case
;      (string=? (symbol->string 'a) (symbol->string 'A)))
;(test #t 'standard-case
;      (or (string=? (symbol->string 'a) "A")
;	  (string=? (symbol->string 'A) "a")))
(define (str-copy s)
  (let ((v (make-string (string-length s))))
    (do ((i (- (string-length v) 1) (- i 1)))
	((< i 0) v)
      (string-set! v i (string-ref s i)))))
(define (string-standard-case s)
  (set! s (str-copy s))
  (do ((i 0 (+ 1 i))
       (sl (string-length s)))
      ((>= i sl) s)
      (string-set! s i (char-standard-case (string-ref s i)))))
;;; Not for Guile
;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
;(test (string-standard-case "martin") symbol->string 'Martin)
(test "Malvina" symbol->string (string->symbol "Malvina"))
;;; Not for Guile
;(test #t 'standard-case (eq? 'a 'A))

(define x (string #\a #\b))
(define y (string->symbol x))
(string-set! x 0 #\c)
(test "cb" 'string-set! x)
(test "ab" symbol->string y)
(test y string->symbol "ab")

;;; Not for Guile
;(test #t eq? 'mISSISSIppi 'mississippi)
;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
(test 'JollyWog string->symbol (symbol->string 'JollyWog))

(SECTION 6 5 5)
(test #t number? 3)
(test #t complex? 3)
(test #t real? 3)
(test #t rational? 3)
(test #t integer? 3)

(test #t exact? 3)
(test #f inexact? 3)

(test #t = 22 22 22)
(test #t = 22 22)
(test #f = 34 34 35)
(test #f = 34 35)
(test #t > 3 -6246)
(test #f > 9 9 -2424)
(test #t >= 3 -4 -6246)
(test #t >= 9 9)
(test #f >= 8 9)
(test #t < -1 2 3 4 5 6 7 8)
(test #f < -1 2 3 4 4 5 6 7)
(test #t <= -1 2 3 4 5 6 7 8)
(test #t <= -1 2 3 4 4 5 6 7)
(test #f < 1 3 2)
(test #f >= 1 3 2)

(test #t zero? 0)
(test #f zero? 1)
(test #f zero? -1)
(test #f zero? -100)
(test #t positive? 4)
(test #f positive? -4)
(test #f positive? 0)
(test #f negative? 4)
(test #t negative? -4)
(test #f negative? 0)
(test #t odd? 3)
(test #f odd? 2)
(test #f odd? -4)
(test #t odd? -1)
(test #f even? 3)
(test #t even? 2)
(test #t even? -4)
(test #f even? -1)

(test 38 max 34 5 7 38 6)
(test -24 min 3  5 5 330 4 -24)

(test 7 + 3 4)
(test '3 + 3)
(test 0 +)
(test 4 * 4)
(test 1 *)

(test -1 - 3 4)
(test -3 - 3)
(test 7 abs -7)
(test 7 abs 7)
(test 0 abs 0)

(test 5 quotient 35 7)
(test -5 quotient -35 7)
(test -5 quotient 35 -7)
(test 5 quotient -35 -7)
(test 1 modulo 13 4)
(test 1 remainder 13 4)
(test 3 modulo -13 4)
(test -1 remainder -13 4)
(test -3 modulo 13 -4)
(test 1 remainder 13 -4)
(test -1 modulo -13 -4)
(test -1 remainder -13 -4)
(define (divtest n1 n2)
	(= n1 (+ (* n2 (quotient n1 n2))
		 (remainder n1 n2))))
(test #t divtest 238 9)
(test #t divtest -238 9)
(test #t divtest 238 -9)
(test #t divtest -238 -9)

(test 4 gcd 0 4)
(test 4 gcd -4 0)
(test 4 gcd 32 -36)
(test 0 gcd)
(test 288 lcm 32 -36)
(test 1 lcm)

;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
;;; Modified by jaffer.
(define (test-inexact)
  (define f3.9 (string->number "3.9"))
  (define f4.0 (string->number "4.0"))
  (define f-3.25 (string->number "-3.25"))
  (define f.25 (string->number ".25"))
  (define f4.5 (string->number "4.5"))
  (define f3.5 (string->number "3.5"))
  (define f0.0 (string->number "0.0"))
  (define f0.8 (string->number "0.8"))
  (define f1.0 (string->number "1.0"))
  (define wto write-test-obj)
  (define dto display-test-obj)
  (define lto load-test-obj)
  (newline)
  (display ";testing inexact numbers; ")
  (newline)
  (SECTION 6 5 5)
  (test #t inexact? f3.9)
  (test #t 'inexact? (inexact? (max f3.9 4)))
  (test f4.0 'max (max f3.9 4))
  (test f4.0 'exact->inexact (exact->inexact 4))
  (test (- f4.0) round (- f4.5))
  (test (- f4.0) round (- f3.5))
  (test (- f4.0) round (- f3.9))
  (test f0.0 round f0.0)
  (test f0.0 round f.25)
  (test f1.0 round f0.8)
  (test f4.0 round f3.5)
  (test f4.0 round f4.5)
  (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
  (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
  (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
  (test #t call-with-output-file
      "tmp3"
      (lambda (test-file)
	(write-char #\; test-file)
	(display write-test-obj test-file)
	(newline test-file)
	(write load-test-obj test-file)
	(output-port? test-file)))
  (check-test-file "tmp3")
  (set! write-test-obj wto)
  (set! display-test-obj dto)
  (set! load-test-obj lto)
  (let ((x (string->number "4195835.0"))
	(y (string->number "3145727.0")))
    (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
  (report-errs))

(define (test-bignum)
  (define tb
    (lambda (n1 n2)
      (= n1 (+ (* n2 (quotient n1 n2))
	       (remainder n1 n2)))))
  (newline)
  (display ";testing bignums; ")
  (newline)
  (SECTION 6 5 5)
  (test 0 modulo -2177452800 86400)
  (test 0 modulo 2177452800 -86400)
  (test 0 modulo 2177452800 86400)
  (test 0 modulo -2177452800 -86400)
  (test #t 'remainder (tb 281474976710655 65535))
  (test #t 'remainder (tb 281474976710654 65535))
  (SECTION 6 5 6)
  (test 281474976710655 string->number "281474976710655")
  (test "281474976710655" number->string 281474976710655)
  (report-errs))

(SECTION 6 5 6)
(test "0" number->string 0)
(test "100" number->string 100)
(test "100" number->string 256 16)
(test 100 string->number "100")
(test 256 string->number "100" 16)
(test #f string->number "")
(test #f string->number ".")
(test #f string->number "d")
(test #f string->number "D")
(test #f string->number "i")
(test #f string->number "I")
(test #f string->number "3i")
(test #f string->number "3I")
(test #f string->number "33i")
(test #f string->number "33I")
(test #f string->number "3.3i")
(test #f string->number "3.3I")
(test #f string->number "-")
(test #f string->number "+")

(SECTION 6 6)
(test #t eqv? '#\  #\Space)
(test #t eqv? #\space '#\Space)
(test #t char? #\a)
(test #t char? #\()
(test #t char? #\ )
(test #t char? '#\newline)

(test #f char=? #\A #\B)
(test #f char=? #\a #\b)
(test #f char=? #\9 #\0)
(test #t char=? #\A #\A)

(test #t char<? #\A #\B)
(test #t char<? #\a #\b)
(test #f char<? #\9 #\0)
(test #f char<? #\A #\A)

(test #f char>? #\A #\B)
(test #f char>? #\a #\b)
(test #t char>? #\9 #\0)
(test #f char>? #\A #\A)

(test #t char<=? #\A #\B)
(test #t char<=? #\a #\b)
(test #f char<=? #\9 #\0)
(test #t char<=? #\A #\A)

(test #f char>=? #\A #\B)
(test #f char>=? #\a #\b)
(test #t char>=? #\9 #\0)
(test #t char>=? #\A #\A)

(test #f char-ci=? #\A #\B)
(test #f char-ci=? #\a #\B)
(test #f char-ci=? #\A #\b)
(test #f char-ci=? #\a #\b)
(test #f char-ci=? #\9 #\0)
(test #t char-ci=? #\A #\A)
(test #t char-ci=? #\A #\a)

(test #t char-ci<? #\A #\B)
(test #t char-ci<? #\a #\B)
(test #t char-ci<? #\A #\b)
(test #t char-ci<? #\a #\b)
(test #f char-ci<? #\9 #\0)
(test #f char-ci<? #\A #\A)
(test #f char-ci<? #\A #\a)

(test #f char-ci>? #\A #\B)
(test #f char-ci>? #\a #\B)
(test #f char-ci>? #\A #\b)
(test #f char-ci>? #\a #\b)
(test #t char-ci>? #\9 #\0)
(test #f char-ci>? #\A #\A)
(test #f char-ci>? #\A #\a)

(test #t char-ci<=? #\A #\B)
(test #t char-ci<=? #\a #\B)
(test #t char-ci<=? #\A #\b)
(test #t char-ci<=? #\a #\b)
(test #f char-ci<=? #\9 #\0)
(test #t char-ci<=? #\A #\A)
(test #t char-ci<=? #\A #\a)

(test #f char-ci>=? #\A #\B)
(test #f char-ci>=? #\a #\B)
(test #f char-ci>=? #\A #\b)
(test #f char-ci>=? #\a #\b)
(test #t char-ci>=? #\9 #\0)
(test #t char-ci>=? #\A #\A)
(test #t char-ci>=? #\A #\a)

(test #t char-alphabetic? #\a)
(test #t char-alphabetic? #\A)
(test #t char-alphabetic? #\z)
(test #t char-alphabetic? #\Z)
(test #f char-alphabetic? #\0)
(test #f char-alphabetic? #\9)
(test #f char-alphabetic? #\space)
(test #f char-alphabetic? #\;)

(test #f char-numeric? #\a)
(test #f char-numeric? #\A)
(test #f char-numeric? #\z)
(test #f char-numeric? #\Z)
(test #t char-numeric? #\0)
(test #t char-numeric? #\9)
(test #f char-numeric? #\space)
(test #f char-numeric? #\;)

(test #f char-whitespace? #\a)
(test #f char-whitespace? #\A)
(test #f char-whitespace? #\z)
(test #f char-whitespace? #\Z)
(test #f char-whitespace? #\0)
(test #f char-whitespace? #\9)
(test #t char-whitespace? #\space)
(test #f char-whitespace? #\;)

(test #f char-upper-case? #\0)
(test #f char-upper-case? #\9)
(test #f char-upper-case? #\space)
(test #f char-upper-case? #\;)

(test #f char-lower-case? #\0)
(test #f char-lower-case? #\9)
(test #f char-lower-case? #\space)
(test #f char-lower-case? #\;)

(test #\. integer->char (char->integer #\.))
(test #\A integer->char (char->integer #\A))
(test #\a integer->char (char->integer #\a))
(test #\A char-upcase #\A)
(test #\A char-upcase #\a)
(test #\a char-downcase #\A)
(test #\a char-downcase #\a)
(SECTION 6 7)
(test #t string? "The word \"recursion\\\" has many meanings.")
(test #t string? "")
(define f (make-string 3 #\*))
(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
(test "abc" string #\a #\b #\c)
(test "" string)
(test 3 string-length "abc")
(test #\a string-ref "abc" 0)
(test #\c string-ref "abc" 2)
(test 0 string-length "")
(test "" substring "ab" 0 0)
(test "" substring "ab" 1 1)
(test "" substring "ab" 2 2)
(test "a" substring "ab" 0 1)
(test "b" substring "ab" 1 2)
(test "ab" substring "ab" 0 2)
(test "foobar" string-append "foo" "bar")
(test "foo" string-append "foo")
(test "foo" string-append "foo" "")
(test "foo" string-append "" "foo")
(test "" string-append)
(test "" make-string 0)
(test #t string=? "" "")
(test #f string<? "" "")
(test #f string>? "" "")
(test #t string<=? "" "")
(test #t string>=? "" "")
(test #t string-ci=? "" "")
(test #f string-ci<? "" "")
(test #f string-ci>? "" "")
(test #t string-ci<=? "" "")
(test #t string-ci>=? "" "")

(test #f string=? "A" "B")
(test #f string=? "a" "b")
(test #f string=? "9" "0")
(test #t string=? "A" "A")

(test #t string<? "A" "B")
(test #t string<? "a" "b")
(test #f string<? "9" "0")
(test #f string<? "A" "A")

(test #f string>? "A" "B")
(test #f string>? "a" "b")
(test #t string>? "9" "0")
(test #f string>? "A" "A")

(test #t string<=? "A" "B")
(test #t string<=? "a" "b")
(test #f string<=? "9" "0")
(test #t string<=? "A" "A")

(test #f string>=? "A" "B")
(test #f string>=? "a" "b")
(test #t string>=? "9" "0")
(test #t string>=? "A" "A")

(test #f string-ci=? "A" "B")
(test #f string-ci=? "a" "B")
(test #f string-ci=? "A" "b")
(test #f string-ci=? "a" "b")
(test #f string-ci=? "9" "0")
(test #t string-ci=? "A" "A")
(test #t string-ci=? "A" "a")

(test #t string-ci<? "A" "B")
(test #t string-ci<? "a" "B")
(test #t string-ci<? "A" "b")
(test #t string-ci<? "a" "b")
(test #f string-ci<? "9" "0")
(test #f string-ci<? "A" "A")
(test #f string-ci<? "A" "a")

(test #f string-ci>? "A" "B")
(test #f string-ci>? "a" "B")
(test #f string-ci>? "A" "b")
(test #f string-ci>? "a" "b")
(test #t string-ci>? "9" "0")
(test #f string-ci>? "A" "A")
(test #f string-ci>? "A" "a")

(test #t string-ci<=? "A" "B")
(test #t string-ci<=? "a" "B")
(test #t string-ci<=? "A" "b")
(test #t string-ci<=? "a" "b")
(test #f string-ci<=? "9" "0")
(test #t string-ci<=? "A" "A")
(test #t string-ci<=? "A" "a")

(test #f string-ci>=? "A" "B")
(test #f string-ci>=? "a" "B")
(test #f string-ci>=? "A" "b")
(test #f string-ci>=? "a" "b")
(test #t string-ci>=? "9" "0")
(test #t string-ci>=? "A" "A")
(test #t string-ci>=? "A" "a")
(SECTION 6 8)
(test #t vector? '#(0 (2 2 2 2) "Anna"))
(test #t vector? '#())
(test '#(a b c) vector 'a 'b 'c)
(test '#() vector)
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
(test 0 vector-length '#())
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
	(let ((vec (vector 0 '(2 2 2 2) "Anna")))
	  (vector-set! vec 1 '("Sue" "Sue"))
	  vec))
(test '#(hi hi) make-vector 2 'hi)
(test '#() make-vector 0)
(test '#() make-vector 0 'a)
(SECTION 6 9)
(test #t procedure? car)
(test #f procedure? 'car)
(test #t procedure? (lambda (x) (* x x)))
(test #f procedure? '(lambda (x) (* x x)))
(test #t call-with-current-continuation procedure?)
(test 7 apply + (list 3 4))
(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
(test 17 apply + 10 (list 3 4))
(test '() apply list '())
(define compose (lambda (f g) (lambda args (f (apply g args)))))
(test 30 (compose sqt *) 12 75)

(test '(b e h) map cadr '((a b) (d e) (g h)))
(test '(5 7 9) map + '(1 2 3) '(4 5 6))
(test '#(0 1 4 9 16) 'for-each
	(let ((v (make-vector 5)))
		(for-each (lambda (i) (vector-set! v i (* i i)))
			'(0 1 2 3 4))
		v))
(test -3 call-with-current-continuation
		(lambda (exit)
		 (for-each (lambda (x) (if (negative? x) (exit x)))
		 	'(54 0 37 -3 245 19))
		#t))
(define list-length
 (lambda (obj)
  (call-with-current-continuation
   (lambda (return)
    (letrec ((r (lambda (obj) (cond ((null? obj) 0)
				((pair? obj) (+ (r (cdr obj)) 1))
				(else (return #f))))))
	(r obj))))))
(test 4 list-length '(1 2 3 4))
(test #f list-length '(a b . c))
(test '() map cadr '())

;;; This tests full conformance of call-with-current-continuation.  It
;;; is a separate test because some schemes do not support call/cc
;;; other than escape procedures.  I am indebted to
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
;;; trees constructed of conses.
(define (next-leaf-generator obj eot)
  (letrec ((return #f)
	   (cont (lambda (x)
		   (recur obj)
		   (set! cont (lambda (x) (return eot)))
		   (cont #f)))
	   (recur (lambda (obj)
		      (if (pair? obj)
			  (for-each recur obj)
			  (call-with-current-continuation
			   (lambda (c)
			     (set! cont c)
			     (return obj)))))))
    (lambda () (call-with-current-continuation
		(lambda (ret) (set! return ret) (cont #f))))))
(define (leaf-eq? x y)
  (let* ((eot (list 'eot))
	 (xf (next-leaf-generator x eot))
	 (yf (next-leaf-generator y eot)))
    (letrec ((loop (lambda (x y)
		     (cond ((not (eq? x y)) #f)
			   ((eq? eot x) #t)
			   (else (loop (xf) (yf)))))))
      (loop (xf) (yf)))))
(define (test-cont)
  (newline)
  (display ";testing continuations; ")
  (newline)
  (SECTION 6 9)
  (test #t leaf-eq? '(a (b (c))) '((a) b c))
  (test #f leaf-eq? '(a (b (c))) '((a) b c d))
  (report-errs))

;;; Test Optional R4RS DELAY syntax and FORCE procedure
(define (test-delay)
  (newline)
  (display ";testing DELAY and FORCE; ")
  (newline)
  (SECTION 6 9)
  (test 3 'delay (force (delay (+ 1 2))))
  (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
			(list (force p) (force p))))
  (test 2 'delay (letrec ((a-stream
			   (letrec ((next (lambda (n)
					    (cons n (delay (next (+ n 1)))))))
			     (next 0)))
			  (head car)
			  (tail (lambda (stream) (force (cdr stream)))))
		   (head (tail (tail a-stream)))))
  (letrec ((count 0)
	   (p (delay (begin (set! count (+ count 1))
			    (if (> count x)
				count
				(force p)))))
	   (x 5))
    (test 6 force p)
    (set! x 10)
    (test 6 force p))
  (test 3 'force
	(letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
		 (c #f))
	  (force p)))
  (report-errs))

(SECTION 6 10 1)
(test #t input-port? (current-input-port))
(test #t output-port? (current-output-port))
(test #t call-with-input-file "test.scm" input-port?)
(define this-file (open-input-file "test.scm"))
(test #t input-port? this-file)
(SECTION 6 10 2)
(test #\; peek-char this-file)
(test #\; read-char this-file)
(test '(define cur-section '()) read this-file)
(test #\( peek-char this-file)
(test '(define errs '()) read this-file)
(close-input-port this-file)
(close-input-port this-file)
(define (check-test-file name)
  (define test-file (open-input-file name))
  (test #t 'input-port?
	(call-with-input-file
	    name
	  (lambda (test-file)
	    (test load-test-obj read test-file)
	    (test #t eof-object? (peek-char test-file))
	    (test #t eof-object? (read-char test-file))
	    (input-port? test-file))))
  (test #\; read-char test-file)
  (test display-test-obj read test-file)
  (test load-test-obj read test-file)
  (close-input-port test-file))
(SECTION 6 10 3)
(define write-test-obj
  '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
(define display-test-obj
  '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
(define load-test-obj
  (list 'define 'foo (list 'quote write-test-obj)))
(test #t call-with-output-file
      "tmp1"
      (lambda (test-file)
	(write-char #\; test-file)
	(display write-test-obj test-file)
	(newline test-file)
	(write load-test-obj test-file)
	(output-port? test-file)))
(check-test-file "tmp1")

(define test-file (open-output-file "tmp2"))
(write-char #\; test-file)
(display write-test-obj test-file)
(newline test-file)
(write load-test-obj test-file)
(test #t output-port? test-file)
(close-output-port test-file)
(check-test-file "tmp2")
(define (test-sc4)
  (newline)
  (display ";testing scheme 4 functions; ")
  (newline)
  (SECTION 6 7)
  (test '(#\P #\space #\l) string->list "P l")
  (test '() string->list "")
  (test "1\\\"" list->string '(#\1 #\\ #\"))
  (test "" list->string '())
  (SECTION 6 8)
  (test '(dah dah didah) vector->list '#(dah dah didah))
  (test '() vector->list '#())
  (test '#(dididit dah) list->vector '(dididit dah))
  (test '#() list->vector '())
  (SECTION 6 10 4)
  (load "tmp1")
  (test write-test-obj 'load foo)
  (report-errs))

(report-errs)
(if (and (string->number "0.0") (inexact? (string->number "0.0")))
    (test-inexact))

(let ((n (string->number "281474976710655")))
  (if (and n (exact? n))
      (test-bignum)))
(newline)
(test-cont)
(newline)
(test-sc4)
(newline)
(test-delay)
(newline)
"last item in file"


code:
;;;; 	Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;; ----------------------------------------------------------------
;;;; threads.scm -- User-level interface to Guile's thread system
;;;; 4 March 1996, Anthony Green <green@cygnus.com>
;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
;;;; Modified 6 April 2001, ttn
;;;; ----------------------------------------------------------------
;;;;

;;; Commentary:

;; This module is documented in the Guile Reference Manual.
;; Briefly, one procedure is exported: `%thread-handler';
;; as well as four macros: `make-thread', `begin-thread',
;; `with-mutex' and `monitor'.

;;; Code:

(define-module (ice-9 threads)
  :export (par-map
	   par-for-each
	   n-par-map
	   n-par-for-each
	   n-for-each-par-map
	   %thread-handler)
  :export-syntax (begin-thread
		  parallel
		  letpar
		  make-thread
		  with-mutex
		  monitor))

(define ((par-mapper mapper)  proc . arglists)
  (mapper join-thread
	  (apply map
		 (lambda args
		   (begin-thread (apply proc args)))
		 arglists)))

(define par-map (par-mapper map))
(define par-for-each (par-mapper for-each))

(define (n-par-map n proc . arglists)
  (let* ((m (make-mutex))
	 (threads '())
	 (results (make-list (length (car arglists))))
	 (result results))
    (do ((i 0 (+ 1 i)))
	((= i n)
	 (for-each join-thread threads)
	 results)
      (set! threads
	    (cons (begin-thread
		   (let loop ()
		     (lock-mutex m)
		     (if (null? result)
			 (unlock-mutex m)
			 (let ((args (map car arglists))
			       (my-result result))
			   (set! arglists (map cdr arglists))
			   (set! result (cdr result))
			   (unlock-mutex m)
			   (set-car! my-result (apply proc args))
			   (loop)))))
		  threads)))))

(define (n-par-for-each n proc . arglists)
  (let ((m (make-mutex))
	(threads '()))
    (do ((i 0 (+ 1 i)))
	((= i n)
	 (for-each join-thread threads))
      (set! threads
	    (cons (begin-thread
		   (let loop ()
		     (lock-mutex m)
		     (if (null? (car arglists))
			 (unlock-mutex m)
			 (let ((args (map car arglists)))
			   (set! arglists (map cdr arglists))
			   (unlock-mutex m)
			   (apply proc args)
			   (loop)))))
		  threads)))))

;;; The following procedure is motivated by the common and important
;;; case where a lot of work should be done, (not too much) in parallel,
;;; but the results need to be handled serially (for example when
;;; writing them to a file).
;;;
(define (n-for-each-par-map n s-proc p-proc . arglists)
  "Using N parallel processes, apply S-PROC in serial order on the results
of applying P-PROC on ARGLISTS."
  (let* ((m (make-mutex))
	 (threads '())
	 (no-result '(no-value))
	 (results (make-list (length (car arglists)) no-result))
	 (result results))
    (do ((i 0 (+ 1 i)))
	((= i n)
	 (for-each join-thread threads))
      (set! threads
	    (cons (begin-thread
		   (let loop ()
		     (lock-mutex m)
		     (cond ((null? results)
			    (unlock-mutex m))
			   ((not (eq? (car results) no-result))
			    (let ((arg (car results)))
			      ;; stop others from choosing to process results
			      (set-car! results no-result)
			      (unlock-mutex m)
			      (s-proc arg)
			      (lock-mutex m)
			      (set! results (cdr results))
			      (unlock-mutex m)
			      (loop)))
			   ((null? result)
			    (unlock-mutex m))
			   (else
			    (let ((args (map car arglists))
				  (my-result result))
			      (set! arglists (map cdr arglists))
			      (set! result (cdr result))
			      (unlock-mutex m)
			      (set-car! my-result (apply p-proc args))
			      (loop))))))
		  threads)))))

(define (thread-handler tag . args)
  (fluid-set! the-last-stack #f)
  (let ((n (length args))
	(p (current-error-port)))
    (display "In thread:" p)
    (newline p)
    (if (>= n 3)
        (display-error #f
                       p
                       (car args)
                       (cadr args)
                       (caddr args)
                       (if (= n 4)
                           (cadddr args)
                           '()))
        (begin
          (display "uncaught throw to " p)
          (display tag p)
          (display ": " p)
          (display args p)
          (newline p)))
    #f))

;;; Set system thread handler
(define %thread-handler thread-handler)

; --- MACROS -------------------------------------------------------

(define-macro (begin-thread . forms)
  (if (null? forms)
      '(begin)
      `(call-with-new-thread
	(lambda ()
	  ,@forms)
	%thread-handler)))

(define-macro (parallel . forms)
  (cond ((null? forms) '(values))
	((null? (cdr forms)) (car forms))
	(else
	 (let ((vars (map (lambda (f)
			    (make-symbol "f"))
			  forms)))
	   `((lambda ,vars
	       (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
	     ,@(map (lambda (form) `(begin-thread ,form)) forms))))))

(define-macro (letpar bindings . body)
  (cond ((or (null? bindings) (null? (cdr bindings)))
	 `(let ,bindings ,@body))
	(else
	 (let ((vars (map car bindings)))
	   `((lambda ,vars
	       ((lambda ,vars ,@body)
		,@(map (lambda (v) `(join-thread ,v)) vars)))
	     ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))

(define-macro (make-thread proc . args)
  `(call-with-new-thread
    (lambda ()
      (,proc ,@args))
    %thread-handler))

(define-macro (with-mutex m . body)
  `(dynamic-wind
       (lambda () (lock-mutex ,m))
       (lambda () (begin ,@body))
       (lambda () (unlock-mutex ,m))))

(define-macro (monitor first . rest)
  `(with-mutex ,(make-mutex)
     (begin
       ,first ,@rest)))

;;; threads.scm ends here

license: unknown


code:
;;;; 	Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

;;; Commentary:

;; This module exports a single macro: `time'.
;; Usage: (time exp)
;;
;; Example:
;; guile> (time (sleep 3))
;; clock utime stime cutime cstime gctime
;; 3.01  0.00  0.00   0.00   0.00   0.00
;; 0

;;; Code:

(define-module (ice-9 time)
  :use-module (ice-9 format)
  :export (time))

(define (time-proc proc)
  (let* ((gc-start (gc-run-time))
         (tms-start (times))
         (result (proc))
         (tms-end (times))
         (gc-end (gc-run-time)))
    ;; FIXME: We would probably like format ~f to accept rationals, but
    ;; currently it doesn't so we force to a flonum with exact->inexact.
    (define (get proc start end)
      (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
    (display "clock utime stime cutime cstime gctime\n")
    (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
            (get tms:clock tms-start tms-end)
            (get tms:utime tms-start tms-end)
            (get tms:stime tms-start tms-end)
            (get tms:cutime tms-start tms-end)
            (get tms:cstime tms-start tms-end)
            (get identity gc-start gc-end))
    result))

(define-macro (time exp)
  `(,time-proc (lambda () ,exp)))

;;; time.scm ends here


code:
;;; installed-scm-file

;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (ice-9 weak-vector)
  :export (make-weak-vector list->weak-vector weak-vector weak-vector?
	   make-weak-key-alist-vector
	   make-weak-value-alist-vector
	   make-doubly-weak-alist-vector
	   weak-key-alist-vector?
	   weak-value-alist-vector?
	   doubly-weak-alist-vector?)  ; C
  )

(%init-weaks-builtins) ; defined in libguile/weaks.c


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 2000, 2006, 2009 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as
##   published by the Free Software Foundation; either version 2, or
##   (at your option) any later version.
##
##   GUILE is distributed in the hope that it will be useful, but
##   WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU General Public License for more details.
##
##   You should have received a copy of the GNU General Public
##   License along with GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

# These should be installed and distributed.

elisp_sources =					\
	elisp/base.scm				\
	elisp/example.el			\
	elisp/interface.scm			\
	elisp/transform.scm			\
	elisp/variables.scm			\
						\
	elisp/primitives/buffers.scm		\
	elisp/primitives/char-table.scm		\
	elisp/primitives/features.scm		\
	elisp/primitives/fns.scm		\
	elisp/primitives/format.scm		\
	elisp/primitives/guile.scm		\
	elisp/primitives/keymaps.scm		\
	elisp/primitives/lists.scm		\
	elisp/primitives/load.scm		\
	elisp/primitives/match.scm		\
	elisp/primitives/numbers.scm		\
	elisp/primitives/pure.scm		\
	elisp/primitives/read.scm		\
	elisp/primitives/signal.scm		\
	elisp/primitives/strings.scm		\
	elisp/primitives/symprop.scm		\
	elisp/primitives/syntax.scm		\
	elisp/primitives/system.scm		\
	elisp/primitives/time.scm		\
						\
	elisp/internals/evaluation.scm		\
	elisp/internals/format.scm		\
	elisp/internals/fset.scm		\
	elisp/internals/lambda.scm		\
	elisp/internals/load.scm		\
	elisp/internals/null.scm		\
	elisp/internals/set.scm			\
	elisp/internals/signal.scm		\
	elisp/internals/time.scm		\
	elisp/internals/trace.scm

subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang
nobase_subpkgdata_DATA = $(elisp_sources)
TAGS_FILES = $(nobase_subpkgdata_DATA)

EXTRA_DIST = $(elisp_sources) elisp/ChangeLog-2008


code:
2008-04-14  Neil Jerram  <neil@ossau.uklinux.net>

	* primitives/symprop.scm (get): Use lambda->nil.

	* primitives/strings.scm (aset): New primitive.

	* internals/load.scm (load): Use in-vicinity (instead of
	string-append) to add a slash if needed.

2004-02-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* primitives/Makefile.am (TAGS_FILES), internals/Makefile.am
	(TAGS_FILES), Makefile.am (TAGS_FILES): Use this variable instead
	of ETAGS_ARGS so that TAGS can be built using separate build
	directory.

2003-11-01  Neil Jerram  <neil@ossau.uklinux.net>

	* internals/format.scm (format), internals/signal.scm (error),
	internals/load.scm (load): Export using #:replace to avoid
	duplicate binding warnings.

2003-01-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* primitives/Makefile.am (elisp_sources): Added char-table.scm.

2002-12-28  Neil Jerram  <neil@ossau.uklinux.net>

	* base.scm (lang): Use char-table module.

	* primitives/char-table.scm (lang): New (stub definitions).

2002-12-08  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.

	* primitives/Makefile.am (subpkgdatadir): VERSION ->
	GUILE_EFFECTIVE_VERSION.

	* internals/Makefile.am (subpkgdatadir): VERSION ->
	GUILE_EFFECTIVE_VERSION.

2002-02-13  Neil Jerram  <neil@ossau.uklinux.net>

	* base.scm (load-emacs): Add optional parameters for specifying an
	alternative load path, and for debugging this.  (Thanks to
	Thien-Thi Nguyen!)

	* primitives/syntax.scm (setq): Use `set'.

	* internals/set.scm (set): Fixed to support variables that are
	imported from other modules.

2002-02-12  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm (scheme): Use set-current-module to ensure
	expected behaviour of resolve-module.

2002-02-08  Neil Jerram  <neil@ossau.uklinux.net>

	* STATUS: New file.

	* README: Updated.

	* interface.scm (translate-elisp): New exported procedure.
	(elisp-function): Symbol var is `obj', not `symbol'.

	* internals/lambda.scm, primitives/fns.scm: Fix confusion between
	interactive-spec and interactive-specification.

	* internals/lambda.scm (transform-lambda), primitives/syntax.scm
	(defmacro): Bind unspecified optional and rest arguments to #nil,
	not #f.

	* internals/null.scm (->nil, lambda->nil): New, exported.
	(null): Use ->nil.

	* primitives/features.scm (featurep), primitives/fns.scm
	(fboundp, subrp): Use ->nil.

	* internals/lists.scm (cons, setcdr, memq, member, assq, assoc):
	Simplified.
	(car, cdr): Return #nil rather than #f.

	* primitives/load.scm (current-load-list), primitives/pure.scm
	(purify-flag): Set to #nil, not #f.

	* primitives/match.scm (string-match): Return #nil rather than #f.

	* primitives/numbers.scm (integerp, numberp),
	primitives/strings.scm (string-lessp, stringp): Use lambda->nil.

	* primitives/symprop.scm (boundp): Use ->nil.
	(symbolp, local-variable-if-set-p): Return #nil rather than #f.

	* primitives/syntax.scm (prog1, prog2): Mangle variable names
	further to lessen possibility of conflicts.
	(if, and, or, cond): Return #nil rather than #f.
	(cond): Return #t rather than t (which is undefined).
	(let, let*): Bind uninitialized variables to #nil, not #f.

	* transform.scm: Resolve inconsistency in usage of `map', and add
	an explanatory note.  Also cleaned up use of subsidiary
	transformation functions.  Also use cons-source wherever possible.
	(transform-datum, transform-quote): New.
	(transform-quasiquote): Renamed from `transform-inside-qq'.
	(transform-application): Apply `transform-quote' to application
	args.
	(cars->nil): Removed.

	* internals/null.scm (null), primitives/lists.scm (cons, car, cdr,
	setcdr, memq, member, assq, assoc, nth): Update to take into
	account new libguile support for Elisp nil value.

2002-02-06  Neil Jerram  <neil@ossau.uklinux.net>

	* example.el (time): New macro, for performance measurement.
	Accompanying comment compares results for Guile and Emacs.

	* transform.scm (scheme): New macro.
	(transformer): New implementation of `scheme' escape that doesn't
	rely on (lang elisp base) importing Guile bindings.

	* base.scm: No longer import anything from (guile).
	(load-emacs): Add scheme form to ensure that keywords
	read option is set correctly.

	* primitives/syntax.scm (defmacro, let, let*): Unquote uses of
	`@bind' in transformed code.
	(if): Unquote uses of `nil-cond' in transformed code.

	* internals/lambda.scm (transform-lambda): Unquote use of `@bind'
	in transformed code.

	* transform.scm (transformer-macro): Don't quote `list' in
	transformed code.
	(transform-application): Don't quote `@fop' in transformed code.
	(transformer): No need to treat `@bind' and `@fop' as special
	cases in input to the transformer.

2002-02-04  Neil Jerram  <neil@ossau.uklinux.net>

	* primitives/syntax.scm (parse-formals, transform-lambda,
	interactive-spec, set-not-subr!, transform-lambda/interactive):
	Move into internals/lambda.scm so that these can also be used
	by...

	* internals/fset.scm (elisp-apply): Use `eval' and
	`transform-lambda/interactive' to turn a quoted lambda expression
	into a Scheme procedure.

	* transform.scm (m-quasiquote): Don't quote `quasiquote' in
	transformed code.
	(transformer): Transform '() to #nil.

2002-02-03  Neil Jerram  <neil@ossau.uklinux.net>

	* internals/Makefile.am (elisp_sources): Add lambda.scm.

	* internals/lambda.scm (lang): New file.

2002-02-01  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm (transformer), primitives/syntax.scm (let*):
	Unquote uses of `begin' in transformed code.

2002-01-29  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm (transform-1, transform-2, transform-3,
	transform-list): Removed (unused).

	* transform.scm, primitives/syntax.scm: Add commas everywhere
	before use of (guile) primitives in generated code, so that (lang
	elisp base) doesn't have to import bindings from (guile).

	* base.scm: Move use-modules expressions inside the define-module,
	and add #:pure so that we don't import bindings from (guile).

2002-01-25  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm (transform-application): Preserve source
	properties of original elisp expression by using cons-source.

	* transform.scm: Don't handle special forms specially in the
	translator.  Instead, define them as macros in ...

	* primitives/syntax.scm: New file; special form definitions.

	* primitives/fns.scm (run-hooks): Rewritten correctly.

	* primitives/symprop.scm (symbol-value): Use `value'.

	* internals/set.scm (value): New function.

	* primitives/fns.scm: Use (lang elisp internals null), as null is
	no longer a primitive.  Change generated #f values to %nil.

	* internals/null.scm (null): Handle nil symbol.

	* primitives/lists.scm (memq, member, assq, assoc): Handle all
	possible nil values.

	* transform.scm (transformer): Translate `nil' and `t' to #nil and
	#t.

	* base.scm: Remove setting of 'language read-option.

2001-11-03  Neil Jerram  <neil@ossau.uklinux.net>

	* README (Resources): Fill in missing URLs.

2001-11-02  Neil Jerram  <neil@ossau.uklinux.net>

	* Makefile.am (elisp_sources): Added base.scm, example.el,
	interface.scm; removed emacs.scm.

	* README: Updated accordingly.

	* internals/load.scm (load): Avoid using `load-path' if the
	supplied file name begins with a slash.

	* internals/fset.scm: Support export of defuns, defmacros and
	defvars to a module specified by the fluid `elisp-export-module'.
	This allows us to automate the importing of Elisp definitions into
	Scheme.

	* example.el: New file: example code for `load-elisp-file'.

	* interface.scm: New file - mechanisms to exchange definitions
	between Scheme and Elisp.

	Following changes try to make the Elisp evaluation module less
	Emacs-dependent; in other words, so that it isn't necessary to try
	to load the whole Emacs environment before evaluating basic
	non-Emacs-specific Elisp code.

	* variables.scm, internals/evaluation.scm: Changed (lang elisp
	emacs) to (lang elisp base).

	* emacs.scm (lang): Removed.

	* base.scm (lang): New file (non-emacs-specific replacement for
	emacs.scm).

2001-10-28  Neil Jerram  <neil@ossau.uklinux.net>

	* primitives/symprop.scm (symbol-name): New primitive.

	* primitives/strings.scm (stringp): New primitive.

	* primitives/pure.scm (purify-flag): New variable.

	* primitives/numbers.scm (numberp): New primitive.

	* internals/fset.scm (fset): Set procedure and macro name
	properties usefully to match Elisp symbol names.  Also bind Elisp
	function definition variables to similarly named symbols in the
	(lang elisp variables) module.

	* transform.scm (transformer, m-unwind-protect): Added support for
	`unwind-protect'.
	(m-quasiquote): Use 'quasiquote rather than 'quote.
	(transform-lambda, m-defmacro): When no rest arguments, set the
	rest parameter to '() rather than #f.  It shouldn't make any
	difference, but it feels more right.

	* README: Enlarged description of current status.

	* Makefile.am (elisp_sources): Added variables.scm.

	* variables.scm: New file.

2001-10-26  Neil Jerram  <neil@ossau.uklinux.net>

	* buffers.scm, calling.scm: Removed.  These should have
	disappeared during the reorganization described below, but I
	missed them by mistake.

	* primitives/symprop.scm (set, boundp, symbol-value): Changed to
	use (module-xx the-elisp-module ...) rather than (local-xx ...).
	(symbolp): Accept either symbols or keywords.
	(set-default, default-boundp, default-value,
	local-variable-if-set-p): New.

	* primitives/match.scm (string-match, match-data): Store last
	match data in Emacs rather than Guile form, to simplify
	implementation of ...
	(set-match-data, store-match-data): New.

	* primitives/load.scm (autoload, current-load-list): New.  (But
	autoload is just stubbed, not properly implemented.)

	* primitives/lists.scm (nth, listp, consp, nconc): New.

	* primitives/fns.scm (byte-code-function-p, run-hooks): New.

	* transform.scm (transform-application, transformer-macro): New
	scheme for transforming procedure arguments while leaving macro
	args untransformed.  (See also associated change in libguile.)
	(m-defconst): Simplified, now uses m-setq.

	* Makefile.am: Changed so that it only deals with files directly
	in this directory; otherwise files don't install cleanly.

	* internals/Makefile.am, primitives/Makefile.am,
	internals/.cvsignore, primitives/.cvsignore: New files.

2001-10-26  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm (transformer): New handling for (1) quasiquoting
	syntax like "(` ...)" as well as the more normal "` ..."; (2)
	`function'; (3) interactive specification in lambda body.
	Simplied handling for `setq'.
	(transform-inside-qq): Fixed to handle improper as well as proper
	lists.
	(transform-lambda/interactive): New; wraps transform-lambda to
	handle setting of various procedure properties.
	(transform-lambda, m-defmacro): Changed `args' and `num-args' to
	`%--args' and `%--num-args' in the hope of avoiding lexical
	vs. dynamic name clashes.
	(m-and): Use #f instead of '() where a condition fails.

	Plus big hierarchy reorganization, in which most of the previous
	occupants of lang/elisp moved to lang/elisp/primitives, with some
	internal processing being split out into lang/elisp/internals.
	The upshot looks like this:

	* internals/trace.scm, internals/set.scm, internals/load.scm,
	internals/fset.scm, internals/signal.scm, internals/time.scm,
	internals/format.scm, internals/null.scm,
	internals/evaluation.scm, primitives/buffers.scm,
	primitives/features.scm, primitives/format.scm,
	primitives/time.scm, primitives/guile.scm, primitives/keymaps.scm,
	primitives/lists.scm, primitives/load.scm, primitives/match.scm,
	primitives/numbers.scm, primitives/pure.scm, primitives/read.scm,
	primitives/signal.scm, primitives/strings.scm,
	primitives/symprop.scm, primitives/system.scm, primitives/fns.scm:
	New files.

	* features.scm, format.scm, fset.scm, guile.scm, keymaps.scm,
	lists.scm, load.scm, match.scm, numbers.scm, pure.scm, read.scm,
	signal.scm, strings.scm, symprop.scm, system.scm, time.scm,
	trace.scm: Removed files.

2001-10-23  Neil Jerram  <neil@ossau.uklinux.net>

	* match.scm (string-match): New implementation using new
	`make-emacs-regexp' primitive; old workaround implementation
	renamed to `string-match-workaround'.

2001-10-21  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm (m-defun, m-defmacro, m-let, m-defvar,
	m-defconst): Use more selective tracing mechanism (provided by new
	file trace.scm).

	* symprop.scm (get, boundp), transform.scm (transform-lambda,
	m-defmacro): Remove unnecessary uses of nil-ify and t-ify.

	* match.scm (string-match): Workaround Guile/libc regex
	parenthesis bug.

	* emacs.scm: Move elisp primitive definitions into more specific
	files, so that emacs.scm contains only overall code.

	* Makefile.am: Added new files.

	* numbers.scm, trace.scm, time.scm, pure.scm, system.scm,
	read.scm, calling.scm, guile.scm: New files.

2001-10-20  Neil Jerram  <neil@ossau.uklinux.net>

	* Makefile.am (elisp_sources): Added match.scm and strings.scm.

	* match.scm, strings.scm: New files.

2001-10-19  Neil Jerram  <neil@ossau.uklinux.net>

	* transform.scm: Replace uses of `nil' by `#f' or `'()'.

	* Makefile.am (elisp_sources): Added lists.scm.

	* load.scm (the-elisp-module): Corrected (lang elisp emacs) module
	name.

	* lists.scm (lang): New file containing list-related primitives.

	* emacs.scm: Corrected module name.

2001-10-19  Neil Jerram  <neil@ossau.uklinux.net>

	Initial implementation of an Emacs Lisp translator, based on
	transformer code originally written by Mikael Djurfeldt.

	* Makefile.am, .cvsignore: New.

	* ChangeLog, README, buffers.scm, emacs.scm, features.scm,
	format.scm, fset.scm, keymaps.scm, load.scm, signal.scm,
	symprop.scm, transform.scm: New files.


code:
                                                    -*- outline -*-

This directory holds the Scheme side of a translator for Emacs Lisp.

* Usage

To load up the base Elisp environment:

    (use-modules (lang elisp base))

Then you can switch into this module

    (define-module (lang elisp base))

and start typing away in Elisp, or evaluate an individual Elisp
expression from Scheme:

    (eval EXP (resolve-module '(lang elisp base)))

A more convenient, higher-level interface is provided by (lang elisp
interface):

    (use-modules (lang elisp interface))

With this interface, you can evaluate an Elisp expression

    (eval-elisp EXP)

load an Elisp file with no effect on the Scheme world

    (load-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")

load an Elisp file, automatically importing top level definitions into
Scheme

    (use-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")

export Scheme objects to Elisp

    (export-to-elisp + - * my-func 'my-var)

and try to bootstrap a complete Emacs environment:

    (load-emacs)

* Status

Please see the STATUS file for the full position.

** Trying to load a complete Emacs environment.

To try this, type `(use-modules (lang elisp interface))' and then
`(load-emacs)'.  The following output shows how far I get when I try
this.

guile> (use-modules (lang elisp interface))
guile> (load-emacs)
Calling loadup.el to clothe the bare Emacs...
Loading /usr/share/emacs/20.7/lisp/loadup.el...
Using load-path ("/usr/share/emacs/20.7/lisp/" "/usr/share/emacs/20.7/lisp/emacs-lisp/")
Loading /usr/share/emacs/20.7/lisp/byte-run.el...
Loading /usr/share/emacs/20.7/lisp/byte-run.el...done
Loading /usr/share/emacs/20.7/lisp/subr.el...
Loading /usr/share/emacs/20.7/lisp/subr.el...done
Loading /usr/share/emacs/20.7/lisp/version.el...
Loading /usr/share/emacs/20.7/lisp/version.el...done
Loading /usr/share/emacs/20.7/lisp/map-ynp.el...
Loading /usr/share/emacs/20.7/lisp/map-ynp.el...done
Loading /usr/share/emacs/20.7/lisp/widget.el...
Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...
Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...done
Loading /usr/share/emacs/20.7/lisp/widget.el...done
Loading /usr/share/emacs/20.7/lisp/custom.el...
Loading /usr/share/emacs/20.7/lisp/custom.el...done
Loading /usr/share/emacs/20.7/lisp/cus-start.el...
Note, built-in variable `abbrev-all-caps' not bound
  ... [many other variable not bound messages] ...
Loading /usr/share/emacs/20.7/lisp/cus-start.el...done
Loading /usr/share/emacs/20.7/lisp/international/mule.el...
<unnamed port>: In procedure make-char-table in expression (@fop make-char-table (# #)):
<unnamed port>: Symbol's function definition is void
ABORT: (misc-error)

Type "(backtrace)" to get more information or "(debug)" to enter the debugger.
guile>

That's 3279 lines ("wc -l") of Elisp code already, which isn't bad!

I think that progress beyond this point basically means implementing
multilingual and multibyte strings properly for Guile.  Which is a
_lot_ of work and requires IMO a very clear plan for Guile's role with
respect to Emacs.

* Design

When thinking about how to implement an Elisp translator for Guile, it
is important to realize that the great power of Emacs does not arise
from Elisp (seen as a language in syntactic terms) alone, but from the
combination of this language with the collection of primitives
provided by the Emacs C source code.  Therefore, to be of practical
use, an Elisp translator needs to be more than just a transformer that
translates sexps to Scheme expressions.

The finished translator should consist of several parts...

** Syntax transformation

Although syntax transformation isn't all we need, we do still need it!

This part is implemented by the (lang elisp transform) module; it is
close to complete and seems to work pretty reliably.

Note that transformed expressions use the `@fop' and `@bind' macros
provided by...

** C support for transformed expressions

For performance and historical reasons (and perhaps necessity - I
haven't thought about it enough yet), some of the transformation
support is written in C.

*** @fop

The `@fop' macro is used to dispatch Elisp applications.  Its first
argument is a symbol, and this symbol's function slot is examined to
find a procedure or macro to apply to the remaining arguments.  `@fop'
also handles aliasing (`defalias'): in this case the function slot
contains another symbol.

Once `@fop' has found the appropriate procedure or macro to apply, it
returns an application expression in which that procedure or macro
replaces the `@fop' and the original symbol.  Hence no Elisp-specific
evaluator support is required to perform the application.

*** @bind

Currently, Elisp variables are the same as Scheme variables, so
variable references are effectively untransformed.

The `@bind' macro does Elisp-style dynamic variable binding.
Basically, it locates the named top level variables, `set!'s them to
new values, evaluates its body, and then uses `set!' again to restore
the original values.

Because of the body evaluation, `@bind' requires evaluator support.
In fact, the `@bind' macro code does little more than replace itself
with the memoized SCM_IM_BIND.  Most of the work is done by the
evaluator when it hits SCM_IM_BIND.

One theoretical problem with `@bind' is that any local Scheme variable
in the same scope and with the same name as an Elisp variable will
shadow the Elisp variable.  But in practice it's difficult to set up
such a situation; an exception is the translator code itself, so there
we mangle the relevant Scheme variable names a bit to avoid the
problem.

Other possible problems with this approach are that it might not be
possible to implement buffer local variables properly, and that
`@bind' might become too inefficient when we implement full support
for undefining Scheme variables.  So we might in future have to
transform Elisp variable references after all.

*** Truth value stuff

Following extensive discussions on the Guile mailing list between
September 2001 and January 2002, we decided to go with Jim Blandy's
proposal.  See devel/translation/lisp-and-scheme.text for details.

- The Elisp nil value is a new immediate SCM_MAKIFLAG, eq?-distinct
from both #f and '() (and of course any other Scheme value).  It can
be accessed via the (guile) binding `%nil', and prints as `#nil'.

- All Elisp primitives treat #nil, #f and '() as identical.

- Scheme truth-testing primitives have been modified so that they
treat #nil the same as #f.

- Scheme list-manipulating primitives have been modified so that they
treat #nil the same as '().

- The Elisp t value is the same as #t.

** Emacs editing primitives

Buffers, keymaps, text properties, windows, frames etc. etc.

Basically, everything that is implemented as a primitive in the Emacs
C code needs to be implemented either in Scheme or in C for Guile.

The Scheme files in the primitives subdirectory implement some of
these primitives in Scheme.  Not because that is the right decision,
but because this is a proof of concept and it's quicker to write badly
performing code in Scheme.

Ultimately, most of these primitive definitions should really come
from the Emacs C code itself, translated or preprocessed in a way that
makes it compile with Guile.  I think this is pretty close to the work
that Ken Raeburn has been doing on the Emacs codebase.

** Reading and printing support

Elisp is close enough to Scheme that it's convenient to coopt the
existing Guile reader rather than to write a new one from scratch, but
there are a few syntactic differences that will require changes in
reading and printing.  None of the following changes has yet been
implemented.

- Character syntax is `?a' rather than `#\a'.  (Not done.  More
  precisely, `?a' in Elisp isn't character syntax but an alternative
  integer syntax.  Note that we could support most of the `?a' syntax
  simply by doing

      (define ?a (char->integer #\a)
      (define ?b (char->integer #\b)

  and so on.)

- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'.

- When in an Elisp environment, #nil and #t should print as `nil' and
  `t'.

** The Elisp evaluation module (lang elisp base)

Fundamentally, Guile's module system can't be used to package Elisp
code in the same way it is used for Scheme code, because Elisp
function definitions are stored as symbol properties (in the symbol's
"function slot") and so are global.  On the other hand, it is useful
(necessary?) to associate some particular module with Elisp evaluation
because

- Elisp variables are currently implemented as Scheme variables and so
  need to live in some module

- a syntax transformer is a property of a module.

Therefore we have the (lang elisp base) module, which acts as the
repository for all Elisp variables and the site of all Elisp
evaluation.

The initial environment provided by this module is intended to be a
non-Emacs-dependent subset of Elisp.  To get the idea, imagine someone
who wants to write an extension function for, say Gnucash, and simply
prefers to write in Elisp rather than in Scheme.  He/she therefore
doesn't buffers, keymaps and so on, just the basic language syntax and
core data functions like +, *, concat, length etc., plus specific
functions made available by Gnucash.

(lang elisp base) achieves this by

- importing Scheme definitions for some Emacs primitives from the
  files in the primitives subdirectory

- then switching into Elisp syntax.

After this point, `(eval XXX (resolve-module '(lang elisp base)))'
will evaluate XXX as an Elisp expression in the (lang elisp base)
module.  (`eval-elisp' in (lang elisp interface) is a more convenient
wrapper for this.)

** Full Emacs environment

The difference between the initial (lang elisp base) environment and a
fully loaded Emacs equivalent is

- more primitives: buffers, char-tables and many others

- the bootstrap Elisp code that an undumped Emacs loads during
  installation by calling `(load "loadup.el")'.

We don't have all the missing primitives, but we can already get
through some of loadup.el.  The Elisp function `load-emacs' (defined
in (lang elisp base) initiates the loading of loadup.el; (lang elisp
interface) exports `load-emacs' to Scheme.

`load-emacs' loads so much Elisp code that it's an excellent way to
test the translator.  In current practice, it runs for a while and
then fails when it gets to an undefined primitive or a bug in the
translator.  Eventually, it should go all the way.  (And then we can
worry about adding unexec support to Guile!)  For the output that
currently results from calling `(load-emacs)', see above in the Status
section.

* Resources

** Ken Raeburn's Guile Emacs page

http://www.mit.edu/~raeburn/guilemacs/

** Keisuke Nishida's Gemacs project

http://gemacs.sourceforge.net

** Jim Blandy's nil/#f/() notes

http://sanpietro.red-bean.com/guile/guile/old/3114.html

Also now stored as guile-core/devel/translation/lisp-and-scheme.text
in Guile CVS.

** Mikael Djurfeldt's notes on translation

See file guile-core/devel/translation/langtools.text in Guile CVS.

path: lang/elisp/README


code:
                                                        -*-text-*-

I've now finished my currently planned work on the Emacs Lisp
translator in guile-core CVS.

It works well enough for experimentation and playing around with --
see the README file for details of what it _can_ do -- but has two
serious restrictions:

- Most Emacs Lisp primitives are not yet implemented.  In particular,
  there are no buffer-related primitives.

- Performance compares badly with Emacs.  Using a handful of
  completely unscientific tests, I found that Guile was between 2 and
  20 times slower than Emacs.  (See the comment in
  lang/elisp/example.el for details of tests and results.)

Interestingly, both these restrictions point in the same direction:
the way forward is to define the primitives by compiling a
preprocessed version of the Emacs source code, not by trying to
implement them in Scheme.  (Which, of course, is what Ken Raeburn's
project is already trying to do.)

Given this conclusion, I expect that most of the translator's Scheme
code will eventually become obsolete, replaced by bits of Emacs C
code.  Until then, though, it should have a role:

- as a guide to the Guile Emacs project on how to interface to the
  Elisp support in libguile (notably, usage of `@fop' and `@bind')

- as a proof of concept and fun thing to experiment with

- as a working translator that could help us develop our picture of
  how we want to integrate translator usage in general with the rest
  of Guile.

path: lang/elisp/STATUS


code:
(define-module (lang elisp base)

  ;; Be pure.  Nothing in this module requires symbols that map to the
  ;; standard Guile builtins, and it creates a problem if this module
  ;; has access to them, as @bind can dynamically change their values.
  ;; Transformer output always uses the values of builtin procedures
  ;; and macros directly.
  #:pure

  ;; {Elisp Primitives}
  ;;
  ;; In other words, Scheme definitions of elisp primitives.  This
  ;; should (ultimately) include everything that Emacs defines in C.
  #:use-module (lang elisp primitives buffers)
  #:use-module (lang elisp primitives char-table)
  #:use-module (lang elisp primitives features)
  #:use-module (lang elisp primitives format)
  #:use-module (lang elisp primitives fns)
  #:use-module (lang elisp primitives guile)
  #:use-module (lang elisp primitives keymaps)
  #:use-module (lang elisp primitives lists)
  #:use-module (lang elisp primitives load)
  #:use-module (lang elisp primitives match)
  #:use-module (lang elisp primitives numbers)
  #:use-module (lang elisp primitives pure)
  #:use-module (lang elisp primitives read)
  #:use-module (lang elisp primitives signal)
  #:use-module (lang elisp primitives strings)
  #:use-module (lang elisp primitives symprop)
  #:use-module (lang elisp primitives syntax)
  #:use-module (lang elisp primitives system)
  #:use-module (lang elisp primitives time)

  ;; Now switch into Emacs Lisp syntax.
  #:use-syntax (lang elisp transform))

;;; Everything below here is written in Elisp.

(defun load-emacs (&optional new-load-path debug)
  (if debug (message "load-path: %s" load-path))
  (cond (new-load-path
         (message "Setting load-path to: %s" new-load-path)
         (setq load-path new-load-path)))
  (if debug (message "load-path: %s" load-path))
  (scheme (read-set! keywords 'prefix))
  (message "Calling loadup.el to clothe the bare Emacs...")
  (load "loadup.el")
  (message "Guile Emacs now fully clothed"))


code:
(defun html-page (title &rest contents)
  (concat "\n"
	  "\n"
	  "<TITLE>" title "</TITLE>\n"
	  "\n"
	  "\n"
	  (apply 'concat contents)
	  "\n"
	  "\n"))

(defmacro time (repeat-count &rest body)
  `(let ((count ,repeat-count)
	 (beg (current-time))
	 end)
     (while (> count 0)
       (setq count (- count 1))
       ,@body)
     (setq end (current-time))
     (+ (* 1000000.0 (+ (* 65536.0 (- (car end) (car beg)))
			(- (cadr end) (cadr beg))))
	(* 1.0 (- (caddr end) (caddr beg))))))

;Non-scientific performance measurements (Guile measurements are with
;`guile -q --no-debug'):
;
;(time 100000 (+ 3 4))
; => 225,071 (Emacs) 4,000,000 (Guile)
;(time 100000 (lambda () 1))
; => 2,410,456 (Emacs) 4,000,000 (Guile)
;(time 100000 (apply 'concat (mapcar (lambda (s) (concat s "." s)) '("a" "b" "c" "d"))))
; => 10,185,792 (Emacs) 136,000,000 (Guile)
;(defun sc (s) (concat s "." s))
;(time 100000 (apply 'concat (mapcar 'sc  '("a" "b" "c" "d"))))
; => 7,870,055 (Emacs) 26,700,000 (Guile)
;
;Sadly, it looks like the translator's performance sucks quite badly
;when compared with Emacs.  But the translator is still very new, so
;there's probably plenty of room of improvement.


code:
(define-module (lang elisp interface)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals fset)
  #:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
  #:use-module ((lang elisp transform) #:select (transformer))
  #:export (eval-elisp
	    translate-elisp
	    elisp-function
	    elisp-variable
	    load-elisp-file
	    load-elisp-library
	    use-elisp-file
	    use-elisp-library
	    export-to-elisp
	    load-emacs))

;;; This file holds my ideas for the mechanisms that would be useful
;;; to exchange definitions between Scheme and Elisp.

(define (eval-elisp x)
  "Evaluate the Elisp expression @var{x}."
  (eval x the-elisp-module))

(define (translate-elisp x)
  "Translate the Elisp expression @var{x} to equivalent Scheme code."
  (transformer x))

(define (elisp-function sym)
  "Return the procedure or macro that implements @var{sym} in Elisp.
If @var{sym} has no Elisp function definition, return @code{#f}."
  (fref sym))

(define (elisp-variable sym)
  "Return the variable that implements @var{sym} in Elisp.
If @var{sym} has no Elisp variable definition, return @code{#f}."
  (module-variable the-elisp-module sym))

(define (load-elisp-file file-name)
  "Load @var{file-name} into the Elisp environment.
@var{file-name} is assumed to name a file containing Elisp code."
  ;; This is the same as Elisp's `load-file', so use that if it is
  ;; available, otherwise duplicate the definition of `load-file' from
  ;; files.el.
  (let ((load-file (elisp-function 'load-file)))
    (if load-file
	(load-file file-name)
	(elisp:load file-name #f #f #t))))

(define (load-elisp-library library)
  "Load library @var{library} into the Elisp environment.
@var{library} should name an Elisp code library that can be found in
one of the directories of @code{load-path}."
  ;; This is the same as Elisp's `load-file', so use that if it is
  ;; available, otherwise duplicate the definition of `load-file' from
  ;; files.el.
  (let ((load-library (elisp-function 'load-library)))
    (if load-library
	(load-library library)
	(elisp:load library))))

(define export-module-name
  (let ((counter 0))
    (lambda ()
      (set! counter (+ counter 1))
      (list 'lang 'elisp
	    (string->symbol (string-append "imports:"
					   (number->string counter)))))))

(define-macro (use-elisp-file file-name . imports)
  "Load Elisp code file @var{file-name} and import its definitions
into the current Scheme module.  If any @var{imports} are specified,
they are interpreted as selection and renaming specifiers as per
@code{use-modules}."
  (let ((export-module-name (export-module-name)))
    `(begin
       (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
       (beautify-user-module! (resolve-module ',export-module-name))
       (load-elisp-file ,file-name)
       (use-modules (,export-module-name ,@imports))
       (fluid-set! ,elisp-export-module #f))))

(define-macro (use-elisp-library library . imports)
  "Load Elisp library @var{library} and import its definitions into
the current Scheme module.  If any @var{imports} are specified, they
are interpreted as selection and renaming specifiers as per
@code{use-modules}."
  (let ((export-module-name (export-module-name)))
    `(begin
       (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
       (beautify-user-module! (resolve-module ',export-module-name))
       (load-elisp-library ,library)
       (use-modules (,export-module-name ,@imports))
       (fluid-set! ,elisp-export-module #f))))

(define (export-to-elisp . defs)
  "Export procedures and variables specified by @var{defs} to Elisp.
Each @var{def} is either an object, in which case that object must be
a named procedure or macro and is exported to Elisp under its Scheme
name; or a symbol, in which case the variable named by that symbol is
exported under its Scheme name; or a pair @var{(obj . name)}, in which
case @var{obj} must be a procedure, macro or symbol as already
described and @var{name} specifies the name under which that object is
exported to Elisp."
  (for-each (lambda (def)
	      (let ((obj (if (pair? def) (car def) def))
		    (name (if (pair? def) (cdr def) #f)))
		(cond ((procedure? obj)
		       (or name
			   (set! name (procedure-name obj)))
		       (if name
			   (fset name obj)
			   (error "No procedure name specified or deducible:" obj)))
		      ((macro? obj)
		       (or name
			   (set! name (macro-name obj)))
		       (if name
			   (fset name obj)
			   (error "No macro name specified or deducible:" obj)))
		      ((symbol? obj)
		       (or name
			   (set! name obj))
		       (module-add! the-elisp-module name
				    (module-ref (current-module) obj)))
		      (else
		       (error "Can't export this kind of object to Elisp:" obj)))))
	    defs))

(define load-emacs (elisp-function 'load-emacs))


code:
(define-module (lang elisp internals evaluation)
  #:export (the-elisp-module))

;;;; {Elisp Evaluation}

;;;; All elisp evaluation happens within the same module - namely
;;;; (lang elisp base).  This is necessary both because elisp itself
;;;; has no concept of different modules - reflected for example in
;;;; its single argument `eval' function - and because Guile's current
;;;; implementation of elisp stores elisp function definitions in
;;;; slots in global symbol objects.

(define the-elisp-module (resolve-module '(lang elisp base)))


code:
(define-module (lang elisp internals format)
  #:pure
  #:use-module (ice-9 r5rs)
  #:use-module ((ice-9 format) #:select ((format . scheme:format)))
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals signal)
  #:replace (format)
  #:export (message))

(define (format control-string . args)

  (define (cons-string str ls)
    (let loop ((sl (string->list str))
	       (ls ls))
      (if (null? sl)
	  ls
	  (loop (cdr sl) (cons (car sl) ls)))))

  (let loop ((input (string->list control-string))
	     (args args)
	     (output '())
	     (mid-control #f))
    (if (null? input)
	(if mid-control
	    (error "Format string ends in middle of format specifier")
	    (list->string (reverse output)))
	(if mid-control
	    (case (car input)
	      ((#\%)
	       (loop (cdr input)
		     args
		     (cons #\% output)
		     #f))
	      (else
	       (loop (cdr input)
		     (cdr args)
		     (cons-string (case (car input)
				    ((#\s) (scheme:format #f "~A" (car args)))
				    ((#\d) (number->string (car args)))
				    ((#\o) (number->string (car args) 8))
				    ((#\x) (number->string (car args) 16))
				    ((#\e) (number->string (car args))) ;FIXME
				    ((#\f) (number->string (car args))) ;FIXME
				    ((#\g) (number->string (car args))) ;FIXME
				    ((#\c) (let ((a (car args)))
					     (if (char? a)
						 (string a)
						 (string (integer->char a)))))
				    ((#\S) (scheme:format #f "~S" (car args)))
				    (else
				     (error "Invalid format operation %%%c" (car input))))
				  output)
		     #f)))
	    (case (car input)
	      ((#\%)
	       (loop (cdr input) args output #t))
	      (else
	       (loop (cdr input) args (cons (car input) output) #f)))))))

(define (message control-string . args)
  (display (apply format control-string args))
  (newline))


code:
(define-module (lang elisp internals fset)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals lambda)
  #:use-module (lang elisp internals signal)
  #:export (fset
	    fref
	    fref/error-if-void
	    elisp-apply
	    interactive-specification
	    not-subr?
	    elisp-export-module))

(define the-variables-module (resolve-module '(lang elisp variables)))

;; By default, Guile GC's unreachable symbols.  So we need to make
;; sure they stay reachable!
(define syms '())

;; elisp-export-module, if non-#f, holds a module to which definitions
;; should be exported under their normal symbol names.  This is used
;; when importing Elisp definitions into Scheme.
(define elisp-export-module (make-fluid))

;; Store the procedure, macro or alias symbol PROC in SYM's function
;; slot.
(define (fset sym proc)
  (or (memq sym syms)
      (set! syms (cons sym syms)))
  (let ((vcell (symbol-fref sym))
	(vsym #f)
	(export-module (fluid-ref elisp-export-module)))
    ;; Playing around with variables and name properties...  For the
    ;; reasoning behind this, see the commentary in (lang elisp
    ;; variables).
    (cond ((procedure? proc)
	   ;; A procedure created from Elisp will already have a name
	   ;; property attached, with value of the form
	   ;; <elisp-defun:NAME> or <elisp-lambda>.  Any other
	   ;; procedure coming through here must be an Elisp primitive
	   ;; definition, so we give it a name of the form
	   ;; <elisp-subr:NAME>.
	   (or (procedure-name proc)
	       (set-procedure-property! proc
					'name
					(symbol-append '<elisp-subr: sym '>)))
	   (set! vsym (procedure-name proc)))
	  ((macro? proc)
	   ;; Macros coming through here must be defmacros, as all
	   ;; primitive special forms are handled directly by the
	   ;; transformer.
	   (set-procedure-property! (macro-transformer proc)
				    'name
				    (symbol-append '<elisp-defmacro: sym '>))
	   (set! vsym (procedure-name (macro-transformer proc))))
	  (else
	   ;; An alias symbol.
	   (set! vsym (symbol-append '<elisp-defalias: sym '>))))
    ;; This is the important bit!
    (if (variable? vcell)
	(variable-set! vcell proc)
	(begin
	  (set! vcell (make-variable proc))
	  (symbol-fset! sym vcell)
	  ;; Playing with names and variables again - see above.
	  (module-add! the-variables-module vsym vcell)
	  (module-export! the-variables-module (list vsym))))
    ;; Export variable to the export module, if non-#f.
    (if (and export-module
	     (or (procedure? proc)
		 (macro? proc)))
	(begin
	  (module-add! export-module sym vcell)
	  (module-export! export-module (list sym))))))

;; Retrieve the procedure or macro stored in SYM's function slot.
;; Note the asymmetry w.r.t. fset: if fref finds an alias symbol, it
;; recursively calls fref on that symbol.  Returns #f if SYM's
;; function slot doesn't contain a valid definition.
(define (fref sym)
  (let ((var (symbol-fref sym)))
    (if (and var (variable? var))
	(let ((proc (variable-ref var)))
	  (cond ((symbol? proc)
		 (fref proc))
		(else
		 proc)))
	#f)))

;; Same as fref, but signals an Elisp error if SYM's function
;; definition is void.
(define (fref/error-if-void sym)
  (or (fref sym)
      (signal 'void-function (list sym))))

;; Maps a procedure to its (interactive ...) spec.
(define interactive-specification (make-object-property))

;; Maps a procedure to #t if it is NOT a built-in.
(define not-subr? (make-object-property))

(define (elisp-apply function . args)
  (apply apply
	 (cond ((symbol? function)
		(fref/error-if-void function))
	       ((procedure? function)
		function)
	       ((and (pair? function)
		     (eq? (car function) 'lambda))
		(eval (transform-lambda/interactive function '<elisp-lambda>)
		      the-root-module))
	       (else
		(signal 'invalid-function (list function))))
	 args))


code:
(define-module (lang elisp internals lambda)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp transform)
  #:export (parse-formals
	    transform-lambda/interactive
	    interactive-spec))

;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
;;; returns three values: (i) list of symbols for required arguments,
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
;;; #f if there is no rest argument.
(define (parse-formals formals)
  (letrec ((do-required
	    (lambda (required formals)
	      (if (null? formals)
		  (values (reverse required) '() #f)
		  (let ((next-sym (car formals)))
		    (cond ((not (symbol? next-sym))
			   (error "Bad formals (non-symbol in required list)"))
			  ((eq? next-sym '&optional)
			   (do-optional required '() (cdr formals)))
			  ((eq? next-sym '&rest)
			   (do-rest required '() (cdr formals)))
			  (else
			   (do-required (cons next-sym required)
					(cdr formals))))))))
	   (do-optional
	    (lambda (required optional formals)
	      (if (null? formals)
		  (values (reverse required) (reverse optional) #f)
		  (let ((next-sym (car formals)))
		    (cond ((not (symbol? next-sym))
			   (error "Bad formals (non-symbol in optional list)"))
			  ((eq? next-sym '&rest)
			   (do-rest required optional (cdr formals)))
			  (else
			   (do-optional required
					(cons next-sym optional)
					(cdr formals))))))))
	   (do-rest
	    (lambda (required optional formals)
	      (if (= (length formals) 1)
		  (let ((next-sym (car formals)))
		    (if (symbol? next-sym)
			(values (reverse required) (reverse optional) next-sym)
			(error "Bad formals (non-symbol rest formal)")))
		  (error "Bad formals (more than one rest formal)")))))

    (do-required '() (cond ((list? formals)
			    formals)
			   ((symbol? formals)
			    (list '&rest formals))
			   (else
			    (error "Bad formals (not a list or a single symbol)"))))))

(define (transform-lambda exp)
  (call-with-values (lambda () (parse-formals (cadr exp)))
    (lambda (required optional rest)
      (let ((num-required (length required))
	    (num-optional (length optional)))
	`(,lambda %--args
	   (,let ((%--num-args (,length %--args)))
	     (,cond ((,< %--num-args ,num-required)
		     (,error "Wrong number of args (not enough required args)"))
		    ,@(if rest
			  '()
			  `(((,> %--num-args ,(+ num-required num-optional))
			     (,error "Wrong number of args (too many args)"))))
		    (else
		     (, @bind ,(append (map (lambda (i)
					      (list (list-ref required i)
						    `(,list-ref %--args ,i)))
					    (iota num-required))
				       (map (lambda (i)
					      (let ((i+nr (+ i num-required)))
						(list (list-ref optional i)
						      `(,if (,> %--num-args ,i+nr)
							    (,list-ref %--args ,i+nr)
							    ,%nil))))
					    (iota num-optional))
				       (if rest
					   (list (list rest
						       `(,if (,> %--num-args
								 ,(+ num-required
								     num-optional))
							     (,list-tail %--args
									 ,(+ num-required
									     num-optional))
							     ,%nil)))
					   '()))
			      ,@(map transformer (cddr exp)))))))))))

(define (set-not-subr! proc boolean)
  (set! (not-subr? proc) boolean))

(define (transform-lambda/interactive exp name)
  (fluid-set! interactive-spec #f)
  (let* ((x (transform-lambda exp))
	 (is (fluid-ref interactive-spec)))
    `(,let ((%--lambda ,x))
       (,set-procedure-property! %--lambda (,quote name) (,quote ,name))
       (,set-not-subr! %--lambda #t)
       ,@(if is
	     `((,set! (,interactive-specification %--lambda) (,quote ,is)))
	     '())
       %--lambda)))

(define interactive-spec (make-fluid))


code:
(define-module (lang elisp internals load)
  #:use-module (ice-9 optargs)
  #:use-module (lang elisp internals signal)
  #:use-module (lang elisp internals format)
  #:use-module (lang elisp internals evaluation)
  #:replace (load)
  #:export (load-path))

(define load-path '("/usr/share/emacs/20.7/lisp/"
		    "/usr/share/emacs/20.7/lisp/emacs-lisp/"))

(define* (load file #:optional noerror nomessage nosuffix must-suffix)
  (define (load1 filename)
    (let ((pathname (let loop ((dirs (if (char=? (string-ref filename 0) #\/)
					 '("")
					 load-path)))
		      (cond ((null? dirs) #f)
			    ((file-exists? (in-vicinity (car dirs) filename))
			     (in-vicinity (car dirs) filename))
			    (else (loop (cdr dirs)))))))
      (if pathname
	  (begin
	    (or nomessage
		(message "Loading %s..." pathname))
	    (with-input-from-file pathname
	      (lambda ()
		(let loop ((form (read)))
		  (or (eof-object? form)
		      (begin
			;; Note that `eval' already incorporates use
			;; of the specified module's transformer.
			(eval form the-elisp-module)
			(loop (read)))))))
	    (or nomessage
		(message "Loading %s...done" pathname))
	    #t)
	  #f)))
  (or (and (not nosuffix)
	   (load1 (string-append file ".el")))
      (and (not must-suffix)
	   (load1 file))
      noerror
      (signal 'file-error
	      (list "Cannot open load file" file))))


code:
(define-module (lang elisp internals null)
  #:export (->nil lambda->nil null))

(define (->nil x)
  (or x %nil))

(define (lambda->nil proc)
  (lambda args
    (->nil (apply proc args))))

(define (null obj)
  (->nil (or (not obj)
	     (null? obj))))


code:
(define-module (lang elisp internals set)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals signal)
  #:export (set value))

;; Set SYM's variable value to VAL, and return VAL.
(define (set sym val)
  (if (module-defined? the-elisp-module sym)
      (module-set! the-elisp-module sym val)
      (module-define! the-elisp-module sym val))
  val)

;; Return SYM's variable value.  If it has none, signal an error if
;; MUST-EXIST is true, just return #nil otherwise.
(define (value sym must-exist)
  (if (module-defined? the-elisp-module sym)
      (module-ref the-elisp-module sym)
      (if must-exist
	  (error "Symbol's value as variable is void:" sym)
	  %nil)))


code:
(define-module (lang elisp internals signal)
  #:use-module (lang elisp internals format)
  #:replace (error)
  #:export (signal
	    wta))

(define (signal error-symbol data)
  (scm-error 'elisp-signal
	     #f
	     "Signalling ~A with data ~S"
	     (list error-symbol data)
	     #f))

(define (error . args)
  (signal 'error (list (apply format args))))

(define (wta expected actual pos)
  (signal 'wrong-type-argument (list expected actual)))


code:
(define-module (lang elisp internals time)
  #:use-module (ice-9 optargs)
  #:export (format-time-string))

(define* (format-time-string format-string #:optional time universal)
  (strftime format-string
	    ((if universal gmtime localtime)
	     (if time
		 (+ (ash (car time) 16)
		    (let ((time-cdr (cdr time)))
		      (if (pair? time-cdr)
			  (car time-cdr)
			  time-cdr)))
		 (current-time)))))


code:
(define-module (lang elisp internals trace)
  #:export (trc trc-syms trc-all trc-none))

(define *syms* #f)

(define (trc-syms . syms)
  (set! *syms* syms))

(define (trc-all)
  (set! *syms* #f))

(define (trc-none)
  (set! *syms* '()))

(define (trc . args)
  (let ((sym (car args))
	(args (cdr args)))
    (if (or (and *syms*
		 (memq sym *syms*))
	    (not *syms*))
	(begin
	  (write sym)
	  (display ": ")
	  (write args)
	  (newline)))))

;; Default to no tracing.
(trc-none)


code:
(define-module (lang elisp primitives buffers)
  #:use-module (ice-9 optargs)
  #:use-module (lang elisp internals fset))

(fset 'buffer-disable-undo
      (lambda* (#:optional buffer)
	'unimplemented))

(fset 're-search-forward
      (lambda* (regexp #:optional bound noerror count)
	'unimplemented))

(fset 're-search-backward
      (lambda* (regexp #:optional bound noerror count)
	'unimplemented))


code:
(define-module (lang elisp primitives char-table)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals null)
  #:use-module (ice-9 optargs))

(fset 'make-char-table
      (lambda* (purpose #:optional init)
	"Return a newly created char-table, with purpose PURPOSE.
Each element is initialized to INIT, which defaults to nil.
PURPOSE should be a symbol which has a `char-table-extra-slots' property.
The property's value should be an integer between 0 and 10."
	(list purpose (vector init))))

(fset 'define-charset
      (lambda (charset-id charset-symbol info-vector)
	(list 'charset charset-id charset-symbol info-vector)))

(fset 'setup-special-charsets
      (lambda ()
	'unimplemented))

(fset 'make-char-internal
      (lambda ()
	'unimplemented))


code:
(define-module (lang elisp primitives features)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals load)
  #:use-module (lang elisp internals null)
  #:use-module (ice-9 optargs))

(define-public features '())

(fset 'provide
      (lambda (feature)
	(or (memq feature features)
	    (set! features (cons feature features)))))

(fset 'featurep
      (lambda (feature)
	(->nil (memq feature features))))

(fset 'require
      (lambda* (feature #:optional file-name noerror)
	(or (memq feature features)
	    (load (or file-name
		      (symbol->string feature))
		  noerror
		  #f
		  #f
		  #t))))


code:
(define-module (lang elisp primitives fns)
  #:use-module (lang elisp internals set)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals null))

(fset 'fset fset)
(fset 'defalias fset)

(fset 'apply elisp-apply)

(fset 'funcall
      (lambda (function . args)
	(elisp-apply function args)))

(fset 'interactive-p
      (lambda ()
	%nil))

(fset 'commandp
      (lambda (sym)
	(if (interactive-specification (fref sym)) #t %nil)))

(fset 'fboundp
      (lambda (sym)
	(->nil (variable? (symbol-fref sym)))))

(fset 'symbol-function fref/error-if-void)

(fset 'macroexpand macroexpand)

(fset 'subrp
      (lambda (obj)
	(->nil (not (not-subr? obj)))))

(fset 'byte-code-function-p
      (lambda (object)
	%nil))

(fset 'run-hooks
      (lambda hooks
	(for-each (lambda (hooksym)
		    (for-each (lambda (fn)
				(elisp-apply fn '()))
			      (value hooksym #f)))
		  hooks)))


code:
(define-module (lang elisp primitives format)
  #:use-module (lang elisp internals format)
  #:use-module (lang elisp internals fset))

(fset 'format format)
(fset 'message message)


code:
(define-module (lang elisp primitives guile)
  #:use-module (lang elisp internals fset))

;;; {Importing Guile procedures into Elisp}

;; It may be worthwhile to import some Guile procedures into the Elisp
;; environment.  For now, though, we don't do this.

(if #f
    (let ((accessible-procedures
	   (apropos-fold (lambda (module name var data)
			   (cons (cons name var) data))
			 '()
			 ""
			 (apropos-fold-accessible (current-module)))))
      (for-each (lambda (name var)
		  (if (procedure? var)
		      (fset name var)))
		(map car accessible-procedures)
		(map cdr accessible-procedures))))


code:
(define-module (lang elisp primitives keymaps)
  #:use-module (lang elisp internals fset))

(define (make-sparse-keymap)
  (list 'keymap))

(define (define-key keymap key def)
  (set-cdr! keymap
	    (cons (cons key def) (cdr keymap))))

(define global-map (make-sparse-keymap))
(define esc-map (make-sparse-keymap))
(define ctl-x-map (make-sparse-keymap))
(define ctl-x-4-map (make-sparse-keymap))
(define ctl-x-5-map (make-sparse-keymap))

;;; {Elisp Exports}

(fset 'make-sparse-keymap make-sparse-keymap)
(fset 'define-key define-key)

(export global-map
	esc-map
	ctl-x-map
	ctl-x-4-map
	ctl-x-5-map)


code:
(define-module (lang elisp primitives lists)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals null)
  #:use-module (lang elisp internals signal))

(fset 'cons cons)

(fset 'null null)

(fset 'not null)

(fset 'car
      (lambda (l)
	(if (null l)
	    %nil
	    (car l))))

(fset 'cdr
      (lambda (l)
	(if (null l)
	    %nil
	    (cdr l))))

(fset 'eq
      (lambda (x y)
	(or (eq? x y)
	    (and (null x) (null y)))))

(fset 'equal
      (lambda (x y)
	(or (equal? x y)
	    (and (null x) (null y)))))

(fset 'setcar set-car!)

(fset 'setcdr set-cdr!)

(for-each (lambda (sym proc)
	    (fset sym
		  (lambda (elt list)
		    (if (null list)
			%nil
			(if (null elt)
			    (let loop ((l list))
			      (cond ((null l) %nil)
				    ((null (car l)) l)
				    (else (loop (cdr l)))))
			    (proc elt list))))))
	  '( memq  member  assq  assoc)
	  `(,memq ,member ,assq ,assoc))

(fset 'length
      (lambda (x)
	(cond ((null x) 0)
	      ((pair? x) (length x))
	      ((vector? x) (vector-length x))
	      ((string? x) (string-length x))
	      (else (wta 'sequencep x 1)))))

(fset 'copy-sequence
      (lambda (x)
	(cond ((list? x) (list-copy x))
	      ((vector? x) (error "Vector copy not yet implemented"))
	      ((string? x) (string-copy x))
	      (else (wta 'sequencep x 1)))))

(fset 'elt
      (lambda (obj i)
	(cond ((pair? obj) (list-ref obj i))
	      ((vector? obj) (vector-ref obj i))
	      ((string? obj) (char->integer (string-ref obj i))))))

(fset 'list list)

(fset 'mapcar
      (lambda (function sequence)
	(map (lambda (elt)
	       (elisp-apply function (list elt)))
	     (cond ((null sequence) '())
		   ((list? sequence) sequence)
		   ((vector? sequence) (vector->list sequence))
		   ((string? sequence) (map char->integer (string->list sequence)))
		   (else (wta 'sequencep sequence 2))))))

(fset 'nth
      (lambda (n list)
	(if (or (null list)
		(>= n (length list)))
	    %nil
	    (list-ref list n))))

(fset 'listp
      (lambda (object)
	(or (null object)
	    (list? object))))

(fset 'consp pair?)

(fset 'nconc
      (lambda args
	(apply append! (map (lambda (arg)
			      (if arg arg '()))
			    args))))


code:
(define-module (lang elisp primitives load)
  #:use-module (lang elisp internals load)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals fset))

(fset 'load load)
(re-export load-path)

(fset 'eval
      (lambda (form)
	(eval form the-elisp-module)))

(fset 'autoload
      (lambda args
	#t))

(define-public current-load-list %nil)


code:
(define-module (lang elisp primitives match)
  #:use-module (lang elisp internals fset)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 optargs))

(define last-match #f)

(fset 'string-match
      (lambda (regexp string . start)

	(define emacs-string-match

	  (if (defined? 'make-emacs-regexp)

	      ;; This is what we would do if we had an
	      ;; Emacs-compatible regexp primitive, here called
	      ;; `make-emacs-regexp'.
	      (lambda (pattern str . args)
		(let ((rx (make-emacs-regexp pattern))
		      (start (if (pair? args) (car args) 0)))
		  (regexp-exec rx str start)))

	      ;; But we don't have Emacs-compatible regexps, and I
	      ;; don't think it's worthwhile at this stage to write
	      ;; generic regexp conversion code.  So work around the
	      ;; discrepancies between Guile/libc and Emacs regexps by
	      ;; substituting the regexps that actually occur in the
	      ;; elisp code that we want to read.
	      (lambda (pattern str . args)
		(let loop ((discrepancies '(("^[0-9]+\\.\\([0-9]+\\)" .
					     "^[0-9]+\\.([0-9]+)"))))
		  (or (null? discrepancies)
		      (if (string=? pattern (caar discrepancies))
			  (set! pattern (cdar discrepancies))
			  (loop (cdr discrepancies)))))
		(apply string-match pattern str args))))

	(let ((match (apply emacs-string-match regexp string start)))
	  (set! last-match
		(if match
		    (apply append!
			   (map (lambda (n)
				  (list (match:start match n)
					(match:end match n)))
				(iota (match:count match))))
		    #f)))

	(if last-match (car last-match) %nil)))

(fset 'match-beginning
      (lambda (subexp)
	(list-ref last-match (* 2 subexp))))

(fset 'match-end
      (lambda (subexp)
	(list-ref last-match (+ (* 2 subexp) 1))))

(fset 'substring substring)

(fset 'match-data
      (lambda* (#:optional integers reuse)
	last-match))

(fset 'set-match-data
      (lambda (list)
	(set! last-match list)))

(fset 'store-match-data 'set-match-data)


code:
(define-module (lang elisp primitives numbers)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals null))

(fset 'logior logior)
(fset 'logand logand)
(fset 'integerp (lambda->nil integer?))
(fset '= =)
(fset '< <)
(fset '> >)
(fset '<= <=)
(fset '>= >=)
(fset '* *)
(fset '+ +)
(fset '- -)
(fset '1- 1-)
(fset 'ash ash)

(fset 'lsh
      (let ()
	(define (lsh num shift)
	  (cond ((= shift 0)
		 num)
		((< shift 0)
		 ;; Logical shift to the right.  Do an arithmetic
		 ;; shift and then mask out the sign bit.
		 (lsh (logand (ash num -1) most-positive-fixnum)
		      (+ shift 1)))
		(else
		 ;; Logical shift to the left.  Guile's ash will
		 ;; always preserve the sign of the result, which is
		 ;; not what we want for lsh, so we need to work
		 ;; around this.
		 (let ((new-sign-bit (ash (logand num
						  (logxor most-positive-fixnum
							  (ash most-positive-fixnum -1)))
					  1)))
		   (lsh (logxor new-sign-bit
				(ash (logand num most-positive-fixnum) 1))
			(- shift 1))))))
	lsh))

(fset 'numberp (lambda->nil number?))


code:
(define-module (lang elisp primitives pure)
  #:use-module (lang elisp internals fset))

;; Purification, unexec etc. are not yet implemented...

(fset 'purecopy identity)

(define-public purify-flag %nil)


code:
(define-module (lang elisp primitives read)
  #:use-module (lang elisp internals fset))

;;; MEGA HACK!!!!

(fset 'read (lambda (str)
	      (cond ((string=? str "?\\M-\\^@")
		     -134217728)
		    (else
		     (with-input-from-string str read)))))


code:
(define-module (lang elisp primitives signal)
  #:use-module (lang elisp internals signal)
  #:use-module (lang elisp internals fset))

(fset 'signal signal)
(fset 'error error)