Commit 1c742208 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Move various unbaked ideas to new repository fare-unbaked

parent 45843bb9
......@@ -18,7 +18,6 @@
......@@ -33,12 +33,6 @@ and Lisp extensions for memoization and reader interception."
(:file "files")
(:file "atomic")))
;;; Half-baked stuff
(:module "unbaked"
:depends-on ("base")
((:file "msv"))) ; Magic Special Variables
;;; Stateful containers
(:module "stateful"
:depends-on ("base")
(in-package :molicle)
(defvar *molicles-by-name* (make-hash-table :test 'equal)
"table of all molicles, by name")
(defvar *molicles-by-truename* (make-hash-table :test 'equal)
"table of all molicles, by truename")
(defgeneric find-molicle (designator))
(defgeneric compile-molicle (designator))
(defgeneric load-molicle (designator))
(defgeneric post-compile-molicle (designator))
(defmethod find-molicle ((pathname pathname))
(let* ((merged (merge-pathnames* pathname))
(truename (probe-file merged))
(fasl (asdf:compile-file-pathname* truename)))
(unless truename
(error "Cannot find molicle at ~A" pathname))
(or (gethash truename *molicles-by-truename*)
:pathname merged
:truename truename
:fasl fasl
:name (list :unnamed "molicle at" merged)))))
(defmethod compile-molicle ((pathname pathname))
(compile-molicle (find-molicle pathname)))
(defmethod compile-molicle ((molicle molicle))
(let ((*molicle* molicle)
(*package* (find-package :molicle-user))
(*evaluation-time* +coffee-time+)
(fasl (molicle-fasl molicle)))
(unless (null (state *molicle*))
(error "molicle already compiled"))
(ensure-directories-exist fasl)
(compile-file (molicle-pathname molicle) :output-file fasl)
(post-compile-molicle molicle)
(defmethod load-molicle ((pathname pathname))
(load-molicle (find-molicle pathname)))
(defmethod load-molicle :before ((molicle molicle))
(unless (eq (state *molicle*) :post-compiled)
(error "molicle not compiled yet")))
(defmethod load-molicle ((molicle molicle))
(let ((*molicle* molicle)
(*package* (find-package :molicle-user))
(*evaluation-time* +load-time+))
(load (molicle-fasl molicle))))
(defmethod post-compile-molicle ((molicle molicle))
(dolist (hook (reverse (post-compile-hook molicle)))
(funcall hook)))
#+xcvb (module (:depends-on "pkgdcl"))
(in-package :molicle)
(defclass evaluation-time ()
((name :initarg :name :reader name)))
(macrolet ((def (name)
`(defconstant* ,name
(make-instance 'evaluation-time :name ',name))))
(def +read-time+)
(def +compile-time+)
(def +load-time+)
(def +load-source-time+)
(def +run-time+)
(def +coffee-time+))
(defvar *evaluation-time* nil)
(defun equal-time (time1 time2)
(check-type time1 evaluation-time)
(check-type time2 evaluation-time)
((not (equal (name time1) (name time2)))
((not (eq time1 time2))
(warn "interestingly there or two different same-named time ~S and ~S" time1 time2)
(t t)))
(defmacro check-evaluation-time (&optional time)
(check-type *evaluation-time* evaluation-time)
,(when time `(assert (equal-time ,time *evaluation-time*)))))
(defun call-with-evaluation-time (time thunk)
(let ((*evaluation-time* time))
(funcall thunk)))
(defmacro with-evaluation-time ((time) &body body)
`(call-with-evaluation-time ,time #'(lambda () ,@body)))
(defmacro initialize-evaluation-time ()
(check-evaluation-time +coffee-time+)
(setf *evaluation-time* +read-time+)
#| (eval-when (:execute)
(warn "Thou shall compile molicles with COMPILE-MOLICLE. Thou shall not LOAD them directly as Lisp files"))|#
(eval-when (:compile-toplevel)
(setf *evaluation-time* +compile-time+))
(eval-when (:load-toplevel)
(setf *evaluation-time* +load-time+))))
(defmacro finalize-evaluation-time ()
(setf *evaluation-time* +coffee-time+)
(defmethod print-object ((time evaluation-time) stream)
(format stream "~S" (name time)))
;; -*- Lisp -*-
#.(begin :name "foo")
(eval-when (:compile-toplevel :execute)
(defmacro initialize-foo ()
(defparameter *foo* 0)
(molicle:register-final-form '(finalize-foo))
(eval-when (:compile-toplevel :execute)
(defmacro foo ()
`(format t "~&Executing the ~:R occurrence of FOO~%" ,(incf *foo*))))
(eval-when (:compile-toplevel :execute)
(defmacro finalize-foo ()
(eval-when (:compile-toplevel :execute)
(defun foo-count ()
(eval-when (:load-toplevel :execute)
(format t "~&Done compiling foo. FOO has been used ~A times.~%" ,*foo*)))))
(format t "This file is going to expand macro FOO ~A times" (foo-count))
(loop :repeat 3 :do (foo))
(defvar *nofun* (constantly nil))
(when (funcall *nofun*)
(when (yes-or-no-p "Would you like to call FOO?")
(in-package :asdf)
(defsystem :molicle
:depends-on (:fare-utils)
((:file "pkgdcl")
(:file "evaluation-time" :depends-on ("pkgdcl"))
(:file "molicle" :depends-on ("evaluation-time"))
(:file "build" :depends-on ("molicle"))
(:file "syntax" :depends-on ("molicle"))))
(in-package :molicle)
(defvar *initial-readtable* (copy-readtable))
(defclass molicle ()
((name :initarg :name :accessor name)
(pathname :initarg :pathname :accessor molicle-pathname)
(truename :initarg :truename :accessor molicle-truename)
(fasl :initarg :fasl :accessor molicle-fasl)
(state :initform nil :accessor state)
(readtable :initform *readtable* :accessor molicle-readtable)
(package :initform :cl-user :accessor molicle-package)
(final-forms :initform nil :accessor final-forms)
(post-compile-hook :initform nil :accessor post-compile-hook)))
(defvar *molicle* nil
"current molicle")
(defun unnamed-molicle-p (molicle)
(let ((name (name molicle)))
(and (consp name) (eq :unnamed (first name)))))
(defmacro initialize-molicle (&rest keys &key name class package &allow-other-keys)
(unless (typep *molicle* 'molicle)
(error "INITIALIZE-MOLICLE used in improper context.
You must use #.[:BEGIN].# at the start of you molicle, and
compile or load your molicle with COMPILE-MOLICLE and LOAD-MOLICLE."))
(when (state *molicle*)
(error "molicle ~S already initialize" (name *molicle*)))
(when name
(if (unnamed-molicle-p *molicle*)
(setf (name *molicle*) name)
(assert (equal name (name *molicle*)) (name *molicle*))))
(when package
(setf (molicle-package *molicle*) (string package)))
(when class
(change-class *molicle* class :keys keys))
(setf (state *molicle*) :compiling)
`(in-package ,(molicle-package *molicle*)))
(defmacro finalize-molicle ()
(setf (state *molicle*) :finalizing)
,@(final-forms *molicle*)
(eval-when (:compile-toplevel)
(setf (state *molicle*) :compiled))))
(in-package :fare-utils)
(defpackage :molicle
(:use :cl :fare-utils)
#:evalation-time ;;#:*evaluation-time*
#:+read-time+ #:+compile-time+ #:+load-time+ #:+run-time+
#:register-final-form #:register-post-compile-hook
#:begin #:end].#))
(defpackage :[
(:use :molicle)
#:begin #:end].#))
(defpackage :molicle-user
(:use :[))
(pushnew :molicle *features*)
(in-package :molicle)
(defmacro begin (&rest keys &key &allow-other-keys)
(initialize-molicle ,@keys)))
(defun register-final-form (form)
"To be used in macros, but not in their expansion"
(assert *molicle*)
(assert (eq (state *molicle*) :compiling))
(push form (final-forms *molicle*)))
(defun register-post-compile-hook (hook)
"To be used in macros, but not in their expansion"
(assert *molicle*)
(assert (eq (state *molicle*) :compiling))
(push hook (post-compile-hook *molicle*)))
(defmacro end-molicle ()
(define-symbol-macro end].# (end-molicle))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Magic special variables: kind of like define-symbol-macro,
;;;;; but with cacheing (by default, read but not write)
#+xcvb (module (:depends-on ("package" "base/macros" "base/hash-tables")))
(in-package :fare-utils)
(eval-when (:compile-toplevel :load-toplevel :execute)
(hashmacro msv-named))
(defun make-msv-cache ()
(make-hash-table :test 'eq))
(defvar *msv-cache* (make-msv-cache))
(defstruct (magic-special-variable-cell
(:constructor make-msv)
(:conc-name :msv-))
(defstruct (magic-special-variable-cache
(:constructor make-msvc)
(:conc-name :msvc-)
(:type vector))
(value nil)
(writtenp nil))
(defun do-write-msv (msv value)
(funcall (msv-setter msv) value))
(defun do-read-msv (msv)
(funcall (msv-getter msv)))
(defun msv-cache (msv)
(gethash msv *msv-cache*))
(defun do-make-msv-cache (msv)
(setf (gethash msv *msv-cache*) (make-msvc)))
(defun ensure-msv-cache (msv)
(or (msv-cache msv) (do-make-msv-cache msv)))
(defun do-flush-msv-write-cache (msv)
(let ((msvc (msv-cache msv)))
(when (and msvc (msvc-writtenp msvc))
(do-write-msv msv (msvc-value msvc))
(setf (msvc-writtenp msvc) nil))))
(defun do-invalidate-msv-cache (msv)
(remhash msv *msv-cache*))
(defun do-flush-and-invalidate-msv-cache (msv)
(do-flush-msv-write-cache msv)
(do-invalidate-msv-cache msv))
(defun do-fill-msv-read-cache (msv)
(let* ((cache (ensure-msv-cache msv)))
(setf (msvc-writtenp cache) nil
(msvc-value cache) (do-read-msv msv))))
(defun msv-get (msv)
(let ((msvc (msv-cache msv)))
(if msvc
(msvc-value msvc)
(if (msv-read-cache msv)
(do-fill-msv-read-cache msv)
(do-read-msv msv)))))
(defun msv-set (msv value)
(if (msv-write-cache msv)
(let ((msvc (ensure-msv-cache msv)))
(setf (msvc-writtenp msvc) t
(msvc-value msvc) value))
(let ((msvc (msv-cache msv)))
(when msvc
(setf (msvc-writtenp msvc) nil
(msvc-value msvc) value))
(do-write-msv msv value))))
(defun (setf msv-get) (value msv)
(msv-set msv value))
(defmacro magic-special-variable (name)
`(msv-get (msv-named ',name)))
#| ;;; how can this be done properly?
(defmacro (setf magic-special-variable) (value name)
`(msv-set (msv-named ',name) ,value))
(defun flush-all-msv ()
(maphash #'(lambda (msv msvc)
(declare (ignore msvc))
(do-flush-msv-write-cache msv))
(defun flush-and-invalidate-all-msv ()
(maphash #'(lambda (msv msvc)
(declare (ignore msvc))
(do-flush-and-invalidate-msv-cache msv))
(defun register-msv (name &rest rest)
(msv-set name (apply 'make-msv :name name rest)))
(defmacro register-magic-special-variable
(name place &key (initform '_)
((:read msv-read) :cache)
((:write msv-write) t))
:place ',place
:initform ',initform
:read ',msv-read
:write ',msv-write
:getter ,(if msv-read
`(symbol-macrolet ((_ ,place))
#'(lambda () ,initform))
`#'(lambda ()
(error ,(format nil "magic variable ~A unbound" name))))
:setter ,(if msv-write
`#'(lambda (x) (setf ,place x))
`#'(lambda (x)
(declare (ignore x))
(error ,(format nil "magic variable ~A unbound" name))))
:read-cache ,(eq msv-read :cache)
:write-cache ,(eq msv-write :cache)))
(defmacro define-magic-special-variable
(name place &rest rest)
(register-magic-special-variable ,name ,place ,@rest)
(define-symbol-macro ,name (magic-special-variable ',name))))
(defmacro with-magic-special-variables (&body body)
`(let ((*msv-cache* (make-msv-cache)))
(progn ,@body)
(defmacro with-magic-special-variables-safely (&body body)
(with-magic-special-variables ,@body)))
(defmethod make-load-form ((msv magic-special-variable-cell) &optional environment)
(declare (ignore environment))
,(msv-name msv) ,(msv-place msv)
:read ,(msv-read msv)
:write ,(msv-write msv)))
defmsv define-magic-special-variable
with-msv with-magic-special-variable
with-msv* with-magic-special-variable-safely)
#| "
A better version would perhaps
(1) individuate magic variable cacheing:
A magic variable's cache would be just the symbol-value of the variable.
(said variable being special indeed)
(2) dependency tracking would help make fresh bindings out of all
variables listed and those they depend upon
(problem: unless we have a typing system for functions being called,
we can't deduce from the syntactic content of a function
the set of all magic special variables it depends upon)
Because of that problem, we're stuck with hash-table lookup for the cache,
though if we really want shallow binding, we could reimplement
dynamic rebinding based on unwind-protect or so (ouch).
Alternatively, it could define symbol-macros that optimize away checks,
lookups and indirections at macro-expansion time.
If such optimizations were often needed, it would nice
to have a partial evaluator generate them automatically - but I digress)
" |#
(in-package :pure)
(define-updatef-expander car (x)
(let ((subform-temp (gensym))
(bind-temp (gensym)))
(values (list subform-temp)
(list x)
(list bind-temp)
`(cons ,bind-temp (cdr ,subform-temp))
`(car ,subform-temp))))
(define-updatef-expander cdr (x)
(let ((subform-temp (gensym))
(bind-temp (gensym)))
(values (list subform-temp)
(list x)
(list bind-temp)
`(cons (car ,subform-temp) ,bind-temp)
`(cdr ,subform-temp))))
#+xcvb (module (:depends-on ("package")))
(in-package :fare-utils-test)
(declaim (optimize (speed 1) (debug 3) (space 3)))
(defsuite* (test-updatef
:in test-suite
:documentation "Testing pure update"))
(deftest test-updatef ()
(is (equal (updatef (car '(1 2)) 3) '(3 2)))
(is (equal (updatef (cdr '(1 2)) 3) '(1 . 3)))
(is (equal (updatef (car (cdr '(1 2))) 3) '(3))) ; and not (1 3) - Ahem. We need some way of composing updates...
;;; updatef: a pure alternative to setf.
;;; generic macro to update places in an extensible way
(in-package :pure)
An updatef expansion is an ordered collection of five objects:
a list of symbols naming temporary variables to be bound sequentially,
as if by let*, to values resulting from value forms.
a list of forms (typically, subforms of the place) which when evaluated
yield the values to which the corresponding temporary variables
should be bound.
a list of symbols naming temporary store variables which are to hold
the new values that will be assigned to the place in the updated state
a form which can reference both the temporary and the store variables, and
which returns an updated state in which the place has been assigned
the updated values, which is the correct value for updatef to return.
a form which can reference the temporary variables, and which returns
the former value of the place in the state before the update.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defgeneric updatef-expansion (expander &key op args place environment))
(defun get-updatef-expansion (place &optional environment)
(check-type place cons)
(destructuring-bind (op &rest args) place
(check-type op symbol)
(let ((expansion (get op 'updatef-expansion)))
(unless expansion
(error "No updatef expansion for ~S" op))
(updatef-expansion expansion :op op :args args :place place :environment environment))))
(defmacro %define-updatef-expansion (access-fn value)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',access-fn 'updatef-expansion) ,value)
(defclass updatef-expander ()
((expander :reader updatef-expander :initarg :expander)))
(defmethod updatef-expansion ((u updatef-expander) &key op args place environment)
(declare (ignore op))
(apply (updatef-expander u) environment place args))
(defmacro define-updatef-expander (access-fn lambda-list &body body)
(check-type access-fn symbol)
(with-gensyms (args)
(multiple-value-bind (destructuring-lambda-list wholevar wholep envvar envp)
(parse-macro-lambda-list lambda-list)
'updatef-expander :expander
#'(lambda (,envvar ,wholevar &rest ,args)
,@(unless wholep `((declare (ignore ,wholevar))))
,@(unless envp `((declare (ignore ,envvar))))
(destructuring-bind (,@destructuring-lambda-list) ,args
(defun get-updatef-expansion-tmpvars (environment args)
:for arg :in args :for tmpvar = (gensym "ARG")
:when (constantp arg environment)
:collect arg :into actual-args
:collect tmpvar :into actual-args :and
:collect tmpvar :into tmpvars :and
:collect arg :into inits
:finally (return (values tmpvars inits actual-args))))
(defun simple-updatef-expansion (environment op args updater updatef-fun-p)
(check-type updater symbol)
(multiple-value-bind (tmpvars inits actual-args)
(get-updatef-expansion-tmpvars environment args)
(let ((newvalvar (gensym "VAL")))
(values tmpvars inits newvalvar
(if updatef-fun-p
`(,updater ,newvalvar ,@actual-args)
`(,updater ,@actual-args ,newvalvar))
`(,op ,@actual-args)))))
(defclass defupdatef-short-expander (updatef-expander) ())
(defmethod updatef-expansion ((u defupdatef-short-expander) &key op args place environment)
(declare (ignore place))
(simple-updatef-expansion environment op args (updatef-expander u) nil))
(defclass defupdatef-function-expander (updatef-expander) ())
(defmethod updatef-expansion ((u defupdatef-function-expander) &key op args place environment)
(declare (ignore place))
(simple-updatef-expansion environment op args (updatef-expander u) t))
(defclass defupdatef-long-expander (updatef-expander)
((n-bind-vars :initarg :n-bind-vars :reader n-bind-vars)))
(defmethod updatef-expansion ((u defupdatef-long-expander) &key op args place environment)
(declare (ignore place))
(multiple-value-bind (tmpvars inits actual-args)
(get-updatef-expansion-tmpvars environment args)
(let* ((n (n-bind-vars u))
(bind-vars (loop :repeat n :collect (gensym "VAL"))))
(assert (= n (length args)))
(values tmpvars inits bind-vars
(funcall (updatef-expander u) environment (append bind-vars actual-args))
`(,op ,@actual-args)))))
(defmacro defupdatef (access-fn &rest more)
"pure analogue to defsetf"
(etypecase (car more)
(symbol ; short form
(destructuring-bind (update-fn &optional docstring) more
(declare (ignore docstring))
(make-instance 'defupdatef-short-expander :expander ',update-fn))))
(list ; long form
(destructuring-bind (defsetf-lambda-list bind-vars &body body) more
(assert (every 'identifierp bind-vars))
(multiple-value-bind (lambda-list environment envp)
(parse-defsetf-lambda-list defsetf-lambda-list)
'defupdatef-long-expander :n-bind-vars (length bind-vars) :expander
#'(lambda (,environment ,@bind-vars ,@lambda-list)
,@(unless envp `((declare (ignore ,environment))))
(defmacro define-updatef-function (access-fn lambda-list &body body)
"pure analogue to `(DEFUN (SETF ,FUNCTION) ,LAMBDA-LIST ,@BODY)"
(multiple-value-bind (body decls doc) (parse-body body :documentation t)
(declare (ignore doc))
'defupdatef-function-expander :expander
#'(lambda ,lambda-list
(block ,access-fn ,@body))))))
(defun updatef-function (sym)
(assert (symbolp sym))
(let ((u (get sym 'updatef-expansion)))
(typecase u
(updatef-expander u))
(error "No updatef function for symbol ~S" sym))
(let ((i (updatef-expander u)))
(if (and (fboundp i) (not (macro-function i)))
#'(lambda (v &rest args)
(apply i (append args (list v))))
(error "updatef inverse for ~S is not a function" sym))))
(error "Updater for symbol ~S is not a function" sym)))))
(defmacro updatef (&rest uargs &environment env)
"pure analogue to SETF"
(let ((nargs (length uargs)))
((= nargs 2)
(let ((place (first uargs))
(value-form (second uargs)))
(when (atom place)
(error "A variable is not a suitable place for UPDATEF"))
(let* ((op (first place))
(args (rest place))
(expansion (get op 'updatef-expansion)))
(typecase expansion
`(call-updatef-function ',op ,value-form ,args))
`(,(updatef-expander expansion) ,args ,value-form))
`(funcall (load-time-value (updatef-function ',op)) ,value-form ,args))
(multiple-value-bind (dummies vals newval binder getter)
(updatef-expansion expansion :op op :args args :place place :environment env)
(declare (ignore getter))
`(let* (,@(mapcar #'list dummies vals))
(multiple-value-bind ,newval ,value-form