"filesystem/pathnames"
"filesystem/files"
"filesystem/atomic"
- "unbaked/msv"
"stateful/package"
"stateful/container"
;;"stateful/binary-heap"
(:file "files")
(:file "atomic")))
- ;;; Half-baked stuff
- (:module "unbaked"
- :depends-on ("base")
- :components
- ((:file "msv"))) ; Magic Special Variables
-
;;; Stateful containers
(:module "stateful"
:depends-on ("base")
+++ /dev/null
-(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*)
- (make-instance
- 'molicle
- :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)
- fasl))
-
-(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)))
+++ /dev/null
-#+xcvb (module (:depends-on "pkgdcl"))
-
-(in-package :molicle)
-
-(eval-now
-(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)
-);eval-now
-
-(defun equal-time (time1 time2)
- (check-type time1 evaluation-time)
- (check-type time2 evaluation-time)
- (cond
- ((not (equal (name time1) (name time2)))
- nil)
- ((not (eq time1 time2))
- (warn "interestingly there or two different same-named time ~S and ~S" time1 time2)
- t)
- (t t)))
-
-(defmacro check-evaluation-time (&optional time)
- `(progn
- (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))
- (check-evaluation-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+)
- `(progn
-#| (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 ()
- (check-evaluation-time)
- (setf *evaluation-time* +coffee-time+)
- '())
-
-(defmethod print-object ((time evaluation-time) stream)
- (format stream "~S" (name time)))
+++ /dev/null
-;; -*- Lisp -*-
-#.(begin :name "foo")
-
-(eval-when (:compile-toplevel :execute)
- (defmacro initialize-foo ()
- (defparameter *foo* 0)
- (molicle:register-final-form '(finalize-foo))
- '())
- (initialize-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 ()
- `(progn
- (eval-when (:compile-toplevel :execute)
- (defun foo-count ()
- ,*foo*))
- (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))
-
-(foo)
-
-(loop :repeat 3 :do (foo))
-
-(defvar *nofun* (constantly nil))
-
-(when (funcall *nofun*)
- (foo))
-
-(when (yes-or-no-p "Would you like to call FOO?")
- (foo))
-
-#.[:end].#
+++ /dev/null
-(in-package :asdf)
-
-(defsystem :molicle
- :depends-on (:fare-utils)
- :components
- ((:file "pkgdcl")
- (:file "evaluation-time" :depends-on ("pkgdcl"))
- (:file "molicle" :depends-on ("evaluation-time"))
- (:file "build" :depends-on ("molicle"))
- (:file "syntax" :depends-on ("molicle"))))
+++ /dev/null
-(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)
- `(progn
- ,@(final-forms *molicle*)
- (eval-when (:compile-toplevel)
- (setf (state *molicle*) :compiled))))
+++ /dev/null
-(in-package :fare-utils)
-
-(defpackage :molicle
- (:use :cl :fare-utils)
- (:export
- #:evalation-time ;;#:*evaluation-time*
- #:+read-time+ #:+compile-time+ #:+load-time+ #:+run-time+
- #:register-final-form #:register-post-compile-hook
- #:begin #:end].#))
-
-(defpackage :[
- (:use :molicle)
- (:export
- #:begin #:end].#))
-
-(defpackage :molicle-user
- (:use :[))
-
-(pushnew :molicle *features*)
+++ /dev/null
-(in-package :molicle)
-
-(defmacro begin (&rest keys &key &allow-other-keys)
- `(progn
- (initialize-evaluation-time)
- (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 ()
- `(progn
- (finalize-evaluation-time)
- (finalize-molicle)))
-
-(define-symbol-macro end].# (end-molicle))
+++ /dev/null
-;;; -*- 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-))
- name
- place
- initform
- read
- write
- getter
- setter
- read-cache
- write-cache)
-(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))
- *msv-cache*))
-(defun flush-and-invalidate-all-msv ()
- (maphash #'(lambda (msv msvc)
- (declare (ignore msvc))
- (do-flush-and-invalidate-msv-cache msv))
- *msv-cache*))
-(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))
- `(register-msv
- ',name
- :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)
- `(progn
- (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)))
- (unwind-protect
- (progn ,@body)
- (flush-all-msv))))
-(defmacro with-magic-special-variables-safely (&body body)
- `(progn
- (flush-all-msv)
- (with-magic-special-variables ,@body)))
-#-genera
-(defmethod make-load-form ((msv magic-special-variable-cell) &optional environment)
- (declare (ignore environment))
- `(register-magic-special-variable
- ,(msv-name msv) ,(msv-place msv)
- :read ,(msv-read msv)
- :write ,(msv-write msv)))
-(define-abbrevs
- 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)
-
-" |#
+++ /dev/null
-(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))))
+++ /dev/null
-#+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...
- (values))
-
+++ /dev/null
-;;; 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:
- TEMP-VARS
- a list of symbols naming temporary variables to be bound sequentially,
- as if by let*, to values resulting from value forms.
- TEMP-VALS
- a list of forms (typically, subforms of the place) which when evaluated
- yield the values to which the corresponding temporary variables
- should be bound.
- BIND-VARS
- 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
- BINDER-FORM
- 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.
- READER-FORM
- 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)
- "pure analogue to (GET-SETF-EXPANSION PLACE 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)
- ',access-fn))
-
-(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)
- "pure analogue to (DEFINE-SETF-EXPANDER ACCESS-FN LAMBDA-LIST . 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)
- `(%define-updatef-expansion
- ,access-fn
- (make-instance
- 'updatef-expander :expander
- #'(lambda (,envvar ,wholevar &rest ,args)
- ,@(unless wholep `((declare (ignore ,wholevar))))
- ,@(unless envp `((declare (ignore ,envvar))))
- (destructuring-bind (,@destructuring-lambda-list) ,args
- ,@body)))))))
-
-(defun get-updatef-expansion-tmpvars (environment args)
- (loop
- :for arg :in args :for tmpvar = (gensym "ARG")
- :when (constantp arg environment)
- :collect arg :into actual-args
- :else
- :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))
- `(%define-updatef-expansion
- ,access-fn
- (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)
- `(%define-updatef-expansion
- ,access-fn
- (make-instance
- 'defupdatef-long-expander :n-bind-vars (length bind-vars) :expander
- #'(lambda (,environment ,@bind-vars ,@lambda-list)
- ,@(unless envp `((declare (ignore ,environment))))
- ,@body))))))))
-
-(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))
- `(%define-updatef-expansion
- ,access-fn
- (make-instance
- 'defupdatef-function-expander :expander
- #'(lambda ,lambda-list
- ,decls
- (block ,access-fn ,@body))))))
-
-(defun updatef-function (sym)
- (assert (symbolp sym))
- (let ((u (get sym 'updatef-expansion)))
- (typecase u
- (defupdatef-function-expander
- (updatef-expander u))
- (null
- (error "No updatef function for symbol ~S" sym))
- (defupdatef-short-expander
- (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))))
- (t
- (error "Updater for symbol ~S is not a function" sym)))))
-
-(defmacro updatef (&rest uargs &environment env)
- "pure analogue to SETF"
- (let ((nargs (length uargs)))
- (cond
- ((= 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
- (null
- `(call-updatef-function ',op ,value-form ,args))
- (defupdatef-short-expander
- `(,(updatef-expander expansion) ,args ,value-form))
- (defupdatef-function-expander
- `(funcall (load-time-value (updatef-function ',op)) ,value-form ,args))
- (updatef-expander
- (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
- ,binder))))))))
- ((oddp nargs)
- (error "odd number of args to UPDATEF"))
- (t
- `(values (loop :for (place value) :on uargs :by #'cddr :collect
- `(updatef ,place ,value)))))))
-);eval-when
common-lisp.net / users/frideau/fare-utils.git / commitdiff
