guile18/lang/elisp/internals/fset.scm

   1 (define-module (lang elisp internals fset)
   2   #:use-module (lang elisp internals evaluation)
   3   #:use-module (lang elisp internals lambda)
   4   #:use-module (lang elisp internals signal)
   5   #:export (fset
   6             fref
   7             fref/error-if-void
   8             elisp-apply
   9             interactive-specification
  10             not-subr?
  11             elisp-export-module))
  12
  13 (define the-variables-module (resolve-module '(lang elisp variables)))
  14
  15 ;; By default, Guile GC's unreachable symbols.  So we need to make
  16 ;; sure they stay reachable!
  17 (define syms '())
  18
  19 ;; elisp-export-module, if non-#f, holds a module to which definitions
  20 ;; should be exported under their normal symbol names.  This is used
  21 ;; when importing Elisp definitions into Scheme.
  22 (define elisp-export-module (make-fluid))
  23
  24 ;; Store the procedure, macro or alias symbol PROC in SYM's function
  25 ;; slot.
  26 (define (fset sym proc)
  27   (or (memq sym syms)
  28       (set! syms (cons sym syms)))
  29   (let ((vcell (symbol-fref sym))
  30         (vsym #f)
  31         (export-module (fluid-ref elisp-export-module)))
  32     ;; Playing around with variables and name properties...  For the
  33     ;; reasoning behind this, see the commentary in (lang elisp
  34     ;; variables).
  35     (cond ((procedure? proc)
  36            ;; A procedure created from Elisp will already have a name
  37            ;; property attached, with value of the form
  38            ;; <elisp-defun:NAME> or <elisp-lambda>.  Any other
  39            ;; procedure coming through here must be an Elisp primitive
  40            ;; definition, so we give it a name of the form
  41            ;; <elisp-subr:NAME>.
  42            (or (procedure-name proc)
  43                (set-procedure-property! proc
  44                                         'name
  45                                         (symbol-append '<elisp-subr: sym '>)))
  46            (set! vsym (procedure-name proc)))
  47           ((macro? proc)
  48            ;; Macros coming through here must be defmacros, as all
  49            ;; primitive special forms are handled directly by the
  50            ;; transformer.
  51            (set-procedure-property! (macro-transformer proc)
  52                                     'name
  53                                     (symbol-append '<elisp-defmacro: sym '>))
  54            (set! vsym (procedure-name (macro-transformer proc))))
  55           (else
  56            ;; An alias symbol.
  57            (set! vsym (symbol-append '<elisp-defalias: sym '>))))
  58     ;; This is the important bit!
  59     (if (variable? vcell)
  60         (variable-set! vcell proc)
  61         (begin
  62           (set! vcell (make-variable proc))
  63           (symbol-fset! sym vcell)
  64           ;; Playing with names and variables again - see above.
  65           (module-add! the-variables-module vsym vcell)
  66           (module-export! the-variables-module (list vsym))))
  67     ;; Export variable to the export module, if non-#f.
  68     (if (and export-module
  69              (or (procedure? proc)
  70                  (macro? proc)))
  71         (begin
  72           (module-add! export-module sym vcell)
  73           (module-export! export-module (list sym))))))
  74
  75 ;; Retrieve the procedure or macro stored in SYM's function slot.
  76 ;; Note the asymmetry w.r.t. fset: if fref finds an alias symbol, it
  77 ;; recursively calls fref on that symbol.  Returns #f if SYM's
  78 ;; function slot doesn't contain a valid definition.
  79 (define (fref sym)
  80   (let ((var (symbol-fref sym)))
  81     (if (and var (variable? var))
  82         (let ((proc (variable-ref var)))
  83           (cond ((symbol? proc)
  84                  (fref proc))
  85                 (else
  86                  proc)))
  87         #f)))
  88
  89 ;; Same as fref, but signals an Elisp error if SYM's function
  90 ;; definition is void.
  91 (define (fref/error-if-void sym)
  92   (or (fref sym)
  93       (signal 'void-function (list sym))))
  94
  95 ;; Maps a procedure to its (interactive ...) spec.
  96 (define interactive-specification (make-object-property))
  97
  98 ;; Maps a procedure to #t if it is NOT a built-in.
  99 (define not-subr? (make-object-property))
 100
 101 (define (elisp-apply function . args)
 102   (apply apply
 103          (cond ((symbol? function)
 104                 (fref/error-if-void function))
 105                ((procedure? function)
 106                 function)
 107                ((and (pair? function)
 108                      (eq? (car function) 'lambda))
 109                 (eval (transform-lambda/interactive function '<elisp-lambda>)
 110                       the-root-module))
 111                (else
 112                 (signal 'invalid-function (list function))))
 113          args))