Skip to content
Snippets Groups Projects
Commit 3dd9e8f0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Debug and add interface/box.

parent 39224dd0
No related branches found
No related tags found
No related merge requests found
...@@ -19,6 +19,7 @@ ...@@ -19,6 +19,7 @@
"filesystem/atomic" "filesystem/atomic"
"unbaked/msv" "unbaked/msv"
"interface/interface" "interface/interface"
"interface/box"
"interface/eq" "interface/eq"
"interface/order" "interface/order"
"pure/package" "pure/package"
......
...@@ -44,6 +44,7 @@ and Lisp extensions for memoization and reader interception." ...@@ -44,6 +44,7 @@ and Lisp extensions for memoization and reader interception."
:depends-on ("base") :depends-on ("base")
:components :components
((:file "interface") ((:file "interface")
(:file "box" :depends-on ("interface"))
(:file "eq" :depends-on ("interface")) (:file "eq" :depends-on ("interface"))
(:file "order" :depends-on ("eq")))) (:file "order" :depends-on ("eq"))))
......
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
#+xcvb (module (:depends-on ("interface/interface" "pure/package"))) #+xcvb (module (:depends-on ("interface/interface")))
(in-package :interface) (in-package :interface)
;;;; Interface ;;;; Interface
;;; A class for box objects themselves ;;; A class for box objects themselves
...@@ -18,7 +17,7 @@ ...@@ -18,7 +17,7 @@
;;; A box: you can make it, or get something out of it ;;; A box: you can make it, or get something out of it
(define-interface <box> (<interface>) ()) (define-interface <box> (<interface>) ())
(defgeneric make-box (<box> generator) (defgeneric make-box (<box> generator &key &allow-other-keys)
(:documentation "Make a box from a generator for the value inside the box")) (:documentation "Make a box from a generator for the value inside the box"))
(defgeneric unbox (<box> box) (defgeneric unbox (<box> box)
...@@ -31,9 +30,9 @@ ...@@ -31,9 +30,9 @@
(defmethod make-box ((i <classy-box>) generator &rest keys &key &allow-other-keys) (defmethod make-box ((i <classy-box>) generator &rest keys &key &allow-other-keys)
(apply 'instantiate i :generator generator keys)) (apply 'instantiate i :generator generator keys))
(defmethod unbox ((i <classy-box>) box &rest keys &key &allow-other-keys) (defmethod unbox ((i <classy-box>) box)
(declare (ignorable i)) (declare (ignorable i))
(apply 'box-ref box keys)) (box-ref box))
;;;; Boxes that hold a value ;;;; Boxes that hold a value
...@@ -122,24 +121,6 @@ ...@@ -122,24 +121,6 @@
`(make-one-use-function #'(lambda ,formals ,@body))) `(make-one-use-function #'(lambda ,formals ,@body)))
#|
;;;; Boxes that can only be opened with a key
(defclass lock-box ()
((lock :initarg :lock :reader %box-lock)))
(define-interface <lock-box> (<lock> <box>) ())
(defmethod unbox :before ((i <lock-box>) box &key key)
(unless (unlockedp (lock-interface i) (box-lock i box) key)
(error "Tried to access ~A with invalid key ~A" box key)))
(defmethod make-box :before ((i <lock-box>) generator &key key)
(declare (ignorable i generator))
(setf (slot-value box 'key) key))
|#
;;; Some boxes can be empty ;;; Some boxes can be empty
(define-interface <emptyable-box> (<box>) ()) (define-interface <emptyable-box> (<box>) ())
......
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Equality ;;;;; Equality
#+xcvb (module ()) #+xcvb (module (:depends-on ("interface/interface")))
(in-package :cl) (in-package :cl)
......
...@@ -47,13 +47,13 @@ ...@@ -47,13 +47,13 @@
(in-package :interface) (in-package :interface)
(defmacro define-interface (name super-interfaces slots &rest options) (defmacro define-interface (name super-interfaces slots &rest options)
(multiple-value-bind (interface-options class-options) (let ((class-options
(split-list options #'(lambda (x) (member x '(:singleton :parametric))) :key 'car) (remove-if #'(lambda (x) (member x '(:singleton :parametric))) options :key 'car)))
`(progn `(progn
(defclass ,name ,super-interfaces ,slots ,@class-options) (defclass ,name ,super-interfaces ,slots ,@class-options)
,@(let ((singleton (find :singleton interface-options :key 'car))) ,@(let ((singleton (find :singleton options :key 'car)))
(when singleton `((defvar ,name (fmemo:memoized-funcall 'make-instance ',name))))) (when singleton `((defvar ,name (fmemo:memoized-funcall 'make-instance ',name)))))
,@(let ((parametric (find :parametric interface-options :key 'car))) ,@(let ((parametric (find :parametric options :key 'car)))
(when parametric (when parametric
(destructuring-bind (formals &body body) (cdr parametric) (destructuring-bind (formals &body body) (cdr parametric)
`((defun ,name ,formals `((defun ,name ,formals
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment