Import guile-1.8 as multiple upstream tarball component

[lilypond.git] / guile18 / lang / elisp / internals / fset.scm

diff --git a/guile18/lang/elisp/internals/fset.scm b/guile18/lang/elisp/internals/fset.scm
new file mode 100644 (file)
index 0000000..249db7c
--- /dev/null
+++ b/guile18/lang/elisp/internals/fset.scm
@@ -0,0 +1,113 @@
+(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))