diff options
Diffstat (limited to 'third_party/lisp/sclf/lazy.lisp')
-rw-r--r-- | third_party/lisp/sclf/lazy.lisp | 134 |
1 files changed, 0 insertions, 134 deletions
diff --git a/third_party/lisp/sclf/lazy.lisp b/third_party/lisp/sclf/lazy.lisp deleted file mode 100644 index 34bae82ebb64..000000000000 --- a/third_party/lisp/sclf/lazy.lisp +++ /dev/null @@ -1,134 +0,0 @@ -;;; lazy.lisp --- lazy primitives - -;;; Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero - -;;; Author: Walter C. Pelissero <walter@pelissero.de> -;;; Project: sclf - -#+cmu (ext:file-comment "$Module: lazy.lisp $") - -;;; This library is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public License -;;; as published by the Free Software Foundation; either version 2.1 -;;; of the License, or (at your option) any later version. -;;; This library is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this library; if not, write to the Free -;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;; 02111-1307 USA - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Lazy primitives -;;; - -(in-package :sclf) - -(defstruct promise - procedure - value) - -(defmacro lazy (form) - `(make-promise :procedure #'(lambda () ,form))) - -(defun forced-p (promise) - (null (promise-procedure promise))) - -(defun force (promise) - (if (forced-p promise) - (promise-value promise) - (prog1 (setf (promise-value promise) - (funcall (promise-procedure promise))) - (setf (promise-procedure promise) nil)))) - -(defmacro deflazy (name value &optional documentation) - `(defparameter ,name (lazy ,value) - ,@(when documentation - (list documentation)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass lazy-metaclass (standard-class) - () - (:documentation "Metaclass for object having lazy slots. Lazy slots -should be specified with the :LAZY keyword which must be a function of -one argument. If required this function will be called once to get -the value to memoize in the slot. Lazy slots can also be set/read as -any other.")) - -(defmethod validate-superclass ((class lazy-metaclass) (super standard-class)) - "Lazy classes may inherit from ordinary classes." - (declare (ignore class super)) - t) - -(defmethod validate-superclass ((class standard-class) (super lazy-metaclass)) - "Ordinary classes may inherit from lazy classes." - (declare (ignore class super)) - t) - -(defclass lazy-slot-mixin () - ((lazy-function :initarg :lazy - :reader lazy-slot-function - :initform nil)) - (:documentation - "Slot for LAZY-METACLASS classes. Lazy slots must be declared with -the argument :LAZY which must be a function accepting the object -instance as argument.")) - -(defclass lazy-direct-slot-definition (lazy-slot-mixin standard-direct-slot-definition) - ()) - -(defclass lazy-effective-slot-definition (lazy-slot-mixin standard-effective-slot-definition) - ()) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod direct-slot-definition-class ((class lazy-metaclass) &rest initargs) - (if (getf initargs :lazy nil) - (find-class 'lazy-direct-slot-definition) - (call-next-method))) - -(defmethod effective-slot-definition-class ((class lazy-metaclass) &rest initargs) - (if (getf initargs :lazy nil) - (find-class 'lazy-effective-slot-definition) - (call-next-method))) - -(defmethod compute-effective-slot-definition-initargs ((class lazy-metaclass) direct-slots) - (let ((ds (car direct-slots))) - (if (typep ds 'lazy-direct-slot-definition) - (let ((form (lazy-slot-function ds)) - (args (call-next-method))) - (when (or (getf args :initarg) - (getf args :initform)) - (error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds)) - (list* :lazy - (cond ((and (listp form) - (eq 'lambda (car form))) - (compile nil form)) - ((symbolp form) - form) - (t (compile nil `(lambda (self) - (declare (ignorable self)) - ,form)))) - args)) - (call-next-method)))) - -(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin)) - (declare (ignore class)) - ;; If the slot is unbound, call the lazy function passing the - ;; instance and memoize the value in the slot. - (unless (slot-boundp-using-class class instance slot) - (setf (slot-value-using-class class instance slot) - (funcall (lazy-slot-function slot) instance))) - (call-next-method)) - -(defun reset-lazy-slots (object) - "Unbind all the lazy slots in OBJECT so that they will be -re-evaluated next time their value is requested again." - (be* class (class-of object) - (dolist (slot (class-slots class)) - (when (typep slot 'lazy-effective-slot-definition) - (slot-makunbound object (slot-definition-name slot)))))) \ No newline at end of file |