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