closure.el

Download

;;; closure.el --- Experimental closure prototypes

;; Copyright (C) 2008 Mike Mattie

;; Author: Mike Mattie
;; Version: 961
;; License: LGPL-V3

;;; Commentary:

;; these are experimental prototypes. The final versions need to be
;; implemented at the C level.

;;; Code:

;;----------------------------------------------------------------------
;; definition and creation
;;----------------------------------------------------------------------

(defmacro closure-define ( symbol &rest definitions )
  (set symbol
    (mapcar
      (lambda ( def )
        (cons (car def) (cadr def)))
      definitions))
  symbol)

(defvar closure-objarray-bucket-tuning 13
  "objarray creation requires a tuning value.")

(defun closure-copy ( closure )
  "copy CLOSURE an objarray so that the values are not shared unlike copy-sequence."
  (lexical-let
    ((copy (make-vector closure-objarray-bucket-tuning 0)))

    (mapatoms
      (lambda ( s )
        (lexical-let
          ((name (symbol-name s)))
          (set (intern name copy) (symbol-value (intern name closure))))) closure)
    copy))

(defun closure-create ( definition )
  "create a symbol table initializing SYMBOL with eval'd VALUE"
  (lexical-let
    ((table (make-vector closure-objarray-bucket-tuning 0)))

    (mapc (lambda ( pair )
            (set (intern (symbol-name (car pair)) table) (eval (cdr pair)))) definition)
    table))

;;----------------------------------------------------------------------
;; binding
;;----------------------------------------------------------------------

(defun closure-bind-scope ( closure body )
  "traverse the tree depth first pre-binding any symbol found in closure."
  ;; might be better to just use a cl low level library function.
  (if (consp body)
    (lexical-let
      ((atom (car body)))

      (cons
        (if (listp atom)
          (closure-bind-scope closure atom)

          (if (symbolp atom)
            (or
              (intern-soft (symbol-name atom) closure)
              atom)
            atom))

        (closure-bind-scope closure (cdr body))))
    body))

(defmacro save-lexical-closure ( closure &rest body )
  "a persistent lexical binding. The objarray CLOSURE appears lexically
   scoped in that a recursive traversal binds symbols of equal name
   in CLOSURE. altering these pre-bound symbols with setq changes the
   value in CLOSURE allowing the values to persist beyond the form in
   objarray CLOSURE.

   Currently this is a experimental hack so it incurs the cost
   of a recursive pre-bind in addition to eval each time evaluated."
  (declare (debug (symbolp body)))
  `(eval (closure-bind-scope ,closure ',(if (eq 'lambda (car body))
                                          body
                                          (cons 'progn body)))))

(defun closure-let-binding ( s closure )
  `(,(read (symbol-name s)) ,(closure-symbol s closure)))

(defmacro use-dynamic-closure ( with-def &rest body )
  "use a saved closure as a dynamic scope with private copy."
  (declare (debug (form body)))
  (lexical-let
    ((definition    (eval (car with-def)))
     (closure       (eval (cadr with-def)))
     (bindings      nil))

    `(let
       ,(progn
          (mapc
            (lambda ( def )
              (push (closure-let-binding (car def) closure) bindings))
            definition)
          bindings)
       ,@body)))

(defmacro use-dynamic-closure-with ( with-def let-spec &rest body )
  "FIXME"
  (declare (debug (form form body)))

  (lexical-let
    ((definition    (eval (car with-def)))
     (closure       (eval (cadr with-def)))
     (bindings      nil))

    `(let
       ,(progn
          (mapc
            (lambda ( def )
              (push (closure-let-binding (car def) closure) bindings))
            definition)
          (append
            let-spec
            bindings))
       ,@body)))

;;----------------------------------------------------------------------
;; direct access
;;----------------------------------------------------------------------

(defun closure-value ( symbol closure )
  "closure-value SYMBOL CLOSURE

   return the value of SYMBOL in CLOSURE.
  "
  (symbol-value (intern (symbol-name symbol) closure)))

(defun closure-symbol ( symbol closure )
  "closure-symbol SYBMOL CLOSURE

   return SYMBOL from closure.
  "
  (intern (symbol-name symbol) closure))

;;----------------------------------------------------------------------
;; utilities
;;----------------------------------------------------------------------

(defun pp-closure ( closure )
  "pretty print a closure returning a string."
  (lexical-let
    ((strings nil))

    (mapatoms
      (lambda ( s )
        (push (format "symbol: %s = %s\n"
                (symbol-name s)
                (pp-to-string (symbol-value (intern (symbol-name s) closure)))) strings)) closure)
    (apply 'concat strings)))

(defun pp-closure-filtered ( filter closure )
  "pretty print a closure returning a string with filtering."
  (lexical-let
    ((strings nil))

    (mapatoms
      (lambda ( s )
        (lexical-let*
          ((name (symbol-name s))
           (value (symbol-value s)))

          (unless (funcall filter value)
            (push (format "symbol: %s = %s\n"
                    name
                    (pp-to-string value)) strings)) )) closure)
    (apply 'concat strings)))

(provide 'closure)