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

(fset 'substring substring)

(fset 'concat
      (lambda args
	(apply string-append
	       (map (lambda (arg)
		      (cond
		       ((string? arg) arg)
		       ((list? arg) (list->string arg))
		       ((vector? arg) (list->string (vector->list arg)))
		       (else (error "Wrong type argument for concat"))))
		    args))))

(fset 'string-to-number string->number)

(fset 'number-to-string number->string)

(fset 'string-lessp (lambda->nil string<?))
(fset 'string< 'string-lessp)

(fset 'aref
      (lambda (array idx)
	(cond ((vector? array) (vector-ref array idx))
	      ((string? array) (char->integer (string-ref array idx)))
	      (else (wta 'arrayp array 1)))))

(fset 'aset
      (lambda (array idx newelt)
	(cond ((vector? array) (vector-set! array idx newelt))
	      ((string? array) (string-set! array idx (integer->char newelt)))
	      (else (wta 'arrayp array 1)))))

(fset 'stringp (lambda->nil string?))

(fset 'vector vector)


code:
(define-module (lang elisp primitives symprop)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals null)
  #:use-module (lang elisp internals set)
  #:use-module (ice-9 optargs))

;;; {Elisp Exports}

(fset 'put set-symbol-property!)

(fset 'get (lambda->nil symbol-property))

(fset 'set set)

(fset 'set-default 'set)

(fset 'boundp
      (lambda (sym)
	(->nil (module-defined? the-elisp-module sym))))

(fset 'default-boundp 'boundp)

(fset 'symbol-value
      (lambda (sym)
	(value sym #t)))

(fset 'default-value 'symbol-value)

(fset 'symbolp
      (lambda (object)
	(or (symbol? object)
	    (keyword? object)
	    %nil)))

(fset 'local-variable-if-set-p
      (lambda* (variable #:optional buffer)
	%nil))

(fset 'symbol-name symbol->string)

license: unknown


code:
(define-module (lang elisp primitives syntax)
  #:use-module (lang elisp internals evaluation)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals lambda)
  #:use-module (lang elisp internals set)
  #:use-module (lang elisp internals trace)
  #:use-module (lang elisp transform))

;;; Define Emacs Lisp special forms as macros.  This is more flexible
;;; than handling them specially in the translator: allows them to be
;;; redefined, and hopefully allows better source location tracking.

;;; {Variables}

(define (setq exp env)
  (cons begin
	(let loop ((sets (cdr exp)))
	  (if (null? sets)
	      '()
	      (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
		    (loop (cddr sets)))))))

(fset 'setq
      (procedure->memoizing-macro setq))

(fset 'defvar
      (procedure->memoizing-macro
        (lambda (exp env)
	  (trc 'defvar (cadr exp))
	  (if (null? (cddr exp))
	      `(,quote ,(cadr exp))
	      `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
			    ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
		       (,quote ,(cadr exp)))))))

(fset 'defconst
      (procedure->memoizing-macro
        (lambda (exp env)
	  (trc 'defconst (cadr exp))
	  `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
		   (,quote ,(cadr exp))))))

;;; {lambda, function and macro definitions}

(fset 'lambda
      (procedure->memoizing-macro
       (lambda (exp env)
	 (transform-lambda/interactive exp '<elisp-lambda>))))

(fset 'defun
      (procedure->memoizing-macro
       (lambda (exp env)
	 (trc 'defun (cadr exp))
	 `(,begin (,fset (,quote ,(cadr exp))
			 ,(transform-lambda/interactive (cdr exp)
							(symbol-append '<elisp-defun:
								       (cadr exp)
								       '>)))
		  (,quote ,(cadr exp))))))

(fset 'interactive
      (procedure->memoizing-macro
        (lambda (exp env)
	  (fluid-set! interactive-spec exp)
	  #f)))

(fset 'defmacro
      (procedure->memoizing-macro
       (lambda (exp env)
	 (trc 'defmacro (cadr exp))
	 (call-with-values (lambda () (parse-formals (caddr exp)))
	   (lambda (required optional rest)
	     (let ((num-required (length required))
		   (num-optional (length optional)))
	       `(,begin (,fset (,quote ,(cadr exp))
			       (,procedure->memoizing-macro
				(,lambda (exp1 env1)
				  (,trc (,quote using) (,quote ,(cadr exp)))
				  (,let* ((%--args (,cdr exp1))
					  (%--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 (,transformer
						  (, @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 (cdddr exp)))))))))))))))))

;;; {Sequencing}

(fset 'progn
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(,begin ,@(map transformer (cdr exp))))))

(fset 'prog1
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(,let ((%--res1 ,(transformer (cadr exp))))
	     ,@(map transformer (cddr exp))
	     %--res1))))

(fset 'prog2
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(,begin ,(transformer (cadr exp))
		   (,let ((%--res2 ,(transformer (caddr exp))))
		     ,@(map transformer (cdddr exp))
		     %--res2)))))

;;; {Conditionals}

(fset 'if
      (procedure->memoizing-macro
        (lambda (exp env)
	  (let ((else-case (cdddr exp)))
	    (cond ((null? else-case)
		   `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
		  ((null? (cdr else-case))
		   `(,nil-cond ,(transformer (cadr exp))
			       ,(transformer (caddr exp))
			       ,(transformer (car else-case))))
		  (else
		   `(,nil-cond ,(transformer (cadr exp))
			       ,(transformer (caddr exp))
			       (,begin ,@(map transformer else-case)))))))))

(fset 'and
      (procedure->memoizing-macro
        (lambda (exp env)
	  (cond ((null? (cdr exp)) #t)
		((null? (cddr exp)) (transformer (cadr exp)))
		(else
		 (cons nil-cond
		       (let loop ((args (cdr exp)))
			 (if (null? (cdr args))
			     (list (transformer (car args)))
			     (cons (list not (transformer (car args)))
				   (cons %nil
					 (loop (cdr args))))))))))))

;;; NIL-COND expressions have the form:
;;;
;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
;;;
;;; The CONDs are evaluated in order until one of them returns true
;;; (in the Elisp sense, so not including empty lists).  If a COND
;;; returns true, its corresponding VAL is evaluated and returned,
;;; except if that VAL is the unspecified value, in which case the
;;; result of evaluating the COND is returned.  If none of the COND's
;;; returns true, ELSEVAL is evaluated and its value returned.

(define <-- *unspecified*)

(fset 'or
      (procedure->memoizing-macro
        (lambda (exp env)
	  (cond ((null? (cdr exp)) %nil)
		((null? (cddr exp)) (transformer (cadr exp)))
		(else
		 (cons nil-cond
		       (let loop ((args (cdr exp)))
			 (if (null? (cdr args))
			     (list (transformer (car args)))
			     (cons (transformer (car args))
				   (cons <--
					 (loop (cdr args))))))))))))

(fset 'cond
      (procedure->memoizing-macro
       (lambda (exp env)
	 (if (null? (cdr exp))
	     %nil
	     (cons
	      nil-cond
	      (let loop ((clauses (cdr exp)))
		(if (null? clauses)
		    (list %nil)
		    (let ((clause (car clauses)))
		      (if (eq? (car clause) #t)
			  (cond ((null? (cdr clause)) (list #t))
				((null? (cddr clause))
				 (list (transformer (cadr clause))))
				(else `((,begin ,@(map transformer (cdr clause))))))
			  (cons (transformer (car clause))
				(cons (cond ((null? (cdr clause)) <--)
					    ((null? (cddr clause))
					     (transformer (cadr clause)))
					    (else
					     `(,begin ,@(map transformer (cdr clause)))))
				      (loop (cdr clauses)))))))))))))

(fset 'while
      (procedure->memoizing-macro
        (lambda (exp env)
	  `((,letrec ((%--while (,lambda ()
				  (,nil-cond ,(transformer (cadr exp))
					     (,begin ,@(map transformer (cddr exp))
						     (%--while))
					     ,%nil))))
	      %--while)))))

;;; {Local binding}

(fset 'let
      (procedure->memoizing-macro
        (lambda (exp env)
	  `(, @bind ,(map (lambda (binding)
			    (trc 'let binding)
			    (if (pair? binding)
				`(,(car binding) ,(transformer (cadr binding)))
				`(,binding ,%nil)))
			  (cadr exp))
		    ,@(map transformer (cddr exp))))))

(fset 'let*
      (procedure->memoizing-macro
        (lambda (exp env)
	  (if (null? (cadr exp))
	      `(,begin ,@(map transformer (cddr exp)))
	      (car (let loop ((bindings (cadr exp)))
		     (if (null? bindings)
			 (map transformer (cddr exp))
			 `((, @bind (,(let ((binding (car bindings)))
					(if (pair? binding)
					    `(,(car binding) ,(transformer (cadr binding)))
					    `(,binding ,%nil))))
				    ,@(loop (cdr bindings)))))))))))

;;; {Exception handling}

(fset 'unwind-protect
      (procedure->memoizing-macro
        (lambda (exp env)
	  (trc 'unwind-protect (cadr exp))
	  `(,let ((%--throw-args #f))
	     (,catch #t
	       (,lambda ()
		 ,(transformer (cadr exp)))
	       (,lambda args
		 (,set! %--throw-args args)))
	     ,@(map transformer (cddr exp))
	     (,if %--throw-args
		  (,apply ,throw %--throw-args))))))


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

(fset 'system-name
      (lambda ()
	(vector-ref (uname) 1)))

(define-public system-type
  (let ((uname (vector-ref (uname) 0)))
    (if (string=? uname "Linux")
	"gnu/linux"
	uname)))

(define-public system-configuration "i386-suse-linux") ;FIXME


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

(fset 'current-time
      (lambda ()
	(let ((now (current-time)))
	  (list (ash now -16)
		(logand now (- (ash 1 16) 1))
		0))))

(fset 'format-time-string format-time-string)

(fset 'current-time-string
      (lambda* (#:optional specified-time)
	(format-time-string "%a %b %e %T %Y" specified-time)))


code:
(define-module (lang elisp transform)
  #:use-module (lang elisp internals trace)
  #:use-module (lang elisp internals fset)
  #:use-module (lang elisp internals evaluation)
  #:use-module (ice-9 session)
  #:export (transformer transform))

;;; A note on the difference between `(transform-* (cdr x))' and `(map
;;; transform-* (cdr x))'.
;;;
;;; In most cases, none, as most of the transform-* functions are
;;; recursive.
;;;
;;; However, if (cdr x) is not a proper list, the `map' version will
;;; signal an error immediately, whereas the non-`map' version will
;;; produce a similarly improper list as its transformed output.  In
;;; some cases, improper lists are allowed, so at least these cases
;;; require non-`map'.
;;;
;;; Therefore we use the non-`map' approach in most cases below, but
;;; `map' in transform-application, since in the application case we
;;; know that `(func arg . args)' is an error.  It would probably be
;;; better for the transform-application case to check for an improper
;;; list explicitly and signal a more explicit error.

(define (syntax-error x)
  (error "Syntax error in expression" x))

(define-macro (scheme exp . module)
  (let ((m (if (null? module)
	       the-root-module
	       (save-module-excursion
		(lambda ()
		  ;; In order for `resolve-module' to work as
		  ;; expected, the current module must contain the
		  ;; `app' variable.  This is not true for #:pure
		  ;; modules, specifically (lang elisp base).  So,
		  ;; switch to the root module (guile) before calling
		  ;; resolve-module.
		  (set-current-module the-root-module)
		  (resolve-module (car module)))))))
    (let ((x `(,eval (,quote ,exp) ,m)))
      ;;(write x)
      ;;(newline)
      x)))

(define (transformer x)
  (cond ((pair? x)
	 (cond ((symbol? (car x))
		(case (car x)
		  ;; Allow module-related forms through intact.
		  ((define-module use-modules use-syntax)
		   x)
		  ;; Escape to Scheme.
		  ((scheme)
		   (cons-source x scheme (cdr x)))
		  ;; Quoting.
		  ((quote function)
		   (cons-source x quote (transform-quote (cdr x))))
		  ((quasiquote)
		   (cons-source x quasiquote (transform-quasiquote (cdr x))))
		  ;; Anything else is a function or macro application.
		  (else (transform-application x))))
	       ((and (pair? (car x))
		     (eq? (caar x) 'quasiquote))
		(transformer (car x)))
	       (else (syntax-error x))))
	(else
	 (transform-datum x))))

(define (transform-datum x)
  (cond ((eq? x 'nil) %nil)
	((eq? x 't) #t)
	;; Could add other translations here, notably `?A' -> 65 etc.
	(else x)))

(define (transform-quote x)
  (trc 'transform-quote x)
  (cond ((not (pair? x))
	 (transform-datum x))
	(else
	 (cons-source x
		      (transform-quote (car x))
		      (transform-quote (cdr x))))))

(define (transform-quasiquote x)
  (trc 'transform-quasiquote x)
  (cond ((not (pair? x))
	 (transform-datum x))
	((symbol? (car x))
	 (case (car x)
	   ((unquote) (list 'unquote (transformer (cadr x))))
	   ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
	   (else (cons-source x
			      (transform-datum (car x))
			      (transform-quasiquote (cdr x))))))
	(else
	 (cons-source x
		      (transform-quasiquote (car x))
		      (transform-quasiquote (cdr x))))))

(define (transform-application x)
  (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))

(define transformer-macro
  (procedure->memoizing-macro
   (let ((cdr cdr))
     (lambda (exp env)
       (cons-source exp list (map transformer (cdr exp)))))))

(define transform transformer)


code:
(define-module (lang elisp variables))

;;; The only purpose of this module is to provide a place where the
;;; variables holding Elisp function definitions can be bound to
;;; symbols.
;;;
;;; This can be useful when looking at unmemoized procedure source
;;; code for Elisp functions and macros.  Elisp function and macro
;;; symbols get memoized into variables.  When the unmemoizer tries to
;;; unmemoize a variables, it does so by looking for a symbol that is
;;; bound to that variable, starting from the module in which the
;;; function or macro was defined and then trying the interfaces on
;;; that module's uses list.  If it can't find any such symbol, it
;;; returns the symbol '???.
;;;
;;; Normally we don't want to bind Elisp function definition variables
;;; to symbols that are visible from the Elisp evaluation module (lang
;;; elisp base), because they would pollute the namespace available
;;; to Elisp variables.  On the other hand, if we are trying to debug
;;; something, and looking at unmemoized source code, it's far more
;;; informative if that code has symbols that indicate the Elisp
;;; function being called than if it just says ??? everywhere.
;;;
;;; So we have a compromise, which achieves a reasonable balance of
;;; correctness (for general operation) and convenience (for
;;; debugging).
;;;
;;; 1. We bind Elisp function definition variables to symbols in this
;;; module (lang elisp variables).
;;;
;;; 2. By default, the Elisp evaluation module (lang elisp base) does
;;; not use (lang elisp variables), so the Elisp variable namespace
;;; stays clean.
;;;
;;; 3. When debugging, a simple (named-module-use! '(lang elisp base)
;;; '(lang elisp variables)) makes the function definition symbols
;;; visible in (lang elisp base) so that the unmemoizer can find
;;; them, which makes the unmemoized source code much easier to read.
;;;
;;; 4. To reduce the effects of namespace pollution even after step 3,
;;; the symbols that we bind are all prefixed with `<elisp' and
;;; suffixed with `>'.


code:
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008 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
 */

/* This needs to be included outside of the extern "C" block.
 */
#include <gmp.h>

#ifdef __cplusplus
extern "C" {
#endif

#include "libguile/__scm.h"
#include "libguile/alist.h"
#include "libguile/arbiters.h"
#include "libguile/async.h"
#include "libguile/boolean.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/evalext.h"
#include "libguile/extensions.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/guardians.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/init.h"
#include "libguile/ioext.h"
#include "libguile/rdelim.h"
#include "libguile/rw.h"
#include "libguile/keywords.h"
#include "libguile/list.h"
#include "libguile/load.h"
#include "libguile/macros.h"
#include "libguile/mallocs.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
#include "libguile/objects.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
#include "libguile/ports.h"
#include "libguile/posix.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/properties.h"
#include "libguile/procs.h"
#include "libguile/ramap.h"
#include "libguile/random.h"
#include "libguile/read.h"
#include "libguile/root.h"
#include "libguile/scmsigs.h"
#include "libguile/script.h"
#include "libguile/simpos.h"
#include "libguile/smob.h"
#include "libguile/snarf.h"
#include "libguile/socket.h"
#include "libguile/sort.h"
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/stime.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
#include "libguile/strorder.h"
#include "libguile/strports.h"
#include "libguile/struct.h"
#include "libguile/symbols.h"
#include "libguile/tags.h"
#include "libguile/throw.h"
#include "libguile/unif.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/srfi-4.h"
#include "libguile/version.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/stacks.h"
#include "libguile/threads.h"
#include "libguile/inline.h"

#include "libguile/discouraged.h"
#include "libguile/deprecated.h"

#ifdef __cplusplus
}
#endif

#endif  /* SCM_LIBGUILE_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
c-tokenize.c
cpp_err_symbols.c
cpp_sig_symbols.c
gen-scmconfig
gen-scmconfig.h
guile
guile-doc-snarf
guile-func-name-check
guile-procedures.texi
guile-snarf
guile-snarf-docs
guile_filter_doc_snarfage
libpath.h
scmconfig.h
version.h