home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / lang / elisp / internals / fset.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  3.7 KB  |  114 lines
  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))
  114.