[cells-cvs] CVS Cells-js
ktilton
ktilton at common-lisp.net
Sun Apr 6 19:16:17 UTC 2008
Update of /project/cells/cvsroot/Cells-js
In directory clnet:/tmp/cvs-serv32532
Added Files:
cell-types.js cells.js constructors.js defmodel.js
defpackage.js family-values.js family.js fm-utilities.js
initialize.js integrity.js link.js md-slot-value.js
md-utilities.js model-object.js propagate.js slot-utilities.js
synapse-types.js synapse.js test-cycle.js test-ephemeral.js
test-propagation.js test-synapse.js test.js trc-eko.js
variables.js
Log Message:
Initial load of Lisp Cells source prior to revision into JS
--- /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/cell-types.js 2008/04/06 19:16:17 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Cells -- Automatic Dataflow Managememnt
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cells)
(defstruct (cell (:conc-name c-))
model
slot-name
value
inputp ;; t for old c-variable class
synaptic
(caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO
(state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
(value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid}
; uncurrent (aka dirty) new for 06-10-15. we need this so
; c-quiesce can force a caller to update when asked
; in case the owner of the quiesced cell goes out of existence
; in a way the caller will not see via any kids dependency. Saw
; this one coming a long time ago: depending on cell X implies
; a dependency on the existence of instance owning X
(pulse 0 :type fixnum)
(pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP
(pulse-observed 0 :type fixnum)
lazy
(optimize t)
debug
md-info)
;_____________________ print __________________________________
#+sigh
(defmethod print-object :before ((c cell) stream)
(declare (ignorable stream))
#+shhh (unless (or *stop* *print-readably*)
(format stream "[~a~a:" (if (c-inputp c) "i" "?")
(cond
((null (c-model c)) #\0)
((eq :eternal-rest (md-state (c-model c))) #\_)
((not (c-currentp c)) #\#)
(t #\space)))))
(defmethod print-object ((c cell) stream)
(declare (ignorable stream))
(unless *stop*
(let ((*print-circle* t))
#+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c))
(if *print-readably*
(call-next-method)
(progn
(c-print-value c stream)
(format stream "=~d/~a/~a/~a]"
(c-pulse c)
(c-state c)
(symbol-name (or (c-slot-name c) :anoncell))
(print-cell-model (c-model c))))))))
(export! print-cell-model)
(defgeneric print-cell-model (md)
(:method (other) (print-object other nil)))
(defmethod trcp :around ((c cell))
(or (c-debug c)
(call-next-method)))
(defun c-callers (c)
"Make it easier to change implementation"
(fifo-data (c-caller-store c)))
(defun caller-ensure (used new-caller)
(unless (find new-caller (c-callers used))
(trc nil "caller-ensure fifo-adding new-caller" new-caller :used used)
(fifo-add (c-caller-store used) new-caller)))
(defun caller-drop (used caller)
(fifo-delete (c-caller-store used) caller))
; --- ephemerality --------------------------------------------------
;
; Not a type, but an option to the :cell parameter of defmodel
;
(defun ephemeral-p (c)
(eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c))))
(defun ephemeral-reset (c)
(when (ephemeral-p c) ;; so caller does not need to worry about this
;
; as of Cells3 we defer resetting ephemerals because everything
; else gets deferred and we cannot /really/ reset it until
; within finish-business we are sure all callers have been recalculated
; and all outputs completed.
;
; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
;
;;(trcx bingo-ephem c)
(with-integrity (:ephemeral-reset c)
(trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c)
(md-slot-value-store (c-model c) (c-slot-name c) nil)
(setf (c-value c) nil))))
; -----------------------------------------------------
(defun c-validate (self c)
(when (not (and (c-slot-name c) (c-model c)))
(format t "~&unadopted cell: ~s md:~s" c self)
(c-break "unadopted cell ~a ~a" self c)
(error 'c-unadopted :cell c)))
(defstruct (c-ruled
(:include cell)
(:conc-name cr-))
(code nil :type list) ;; /// feature this out on production build
rule)
(defun c-optimized-away-p (c)
(eq :optimized-away (c-state c)))
;----------------------------
(defmethod trcp-slot (self slot-name)
(declare (ignore self slot-name)))
(defstruct (c-dependent
(:include c-ruled)
(:conc-name cd-))
;; chop (synapses nil :type list)
(useds nil :type list)
(usage (blank-usage-mask)))
(defun blank-usage-mask ()
(make-array 16 :element-type 'bit
:initial-element 0))
(defstruct (c-drifter
(:include c-dependent)))
(defstruct (c-drifter-absolute
(:include c-drifter)))
;_____________________ accessors __________________________________
(defmethod c-useds (other) (declare (ignore other)))
(defmethod c-useds ((c c-dependent)) (cd-useds c))
(defun c-validp (c)
(eql (c-value-state c) :valid))
(defun c-unboundp (c)
(eql :unbound (c-value-state c)))
;__________________
(defmethod c-print-value ((c c-ruled) stream)
(format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>"))
((c-unboundp c) "<unb>")
((not (c-currentp c)) "dirty")
(t "<err>"))))
(defmethod c-print-value (c stream)
(declare (ignore c stream)))
--- /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/cells.js 2008/04/06 19:16:17 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Cells -- Automatic Dataflow Managememnt
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
#| Notes
I don't like the way with-cc defers twice, first the whole thing and then when the
body finally runs we are still within the original integrity and each setf gets queued
to UFB separately before md-slot-value-assume finally runs. I think all that is going on here
is that we want the programmer to use with-cc to show they know the setf will not be returning
a useful value. But since they have coded the with-cc we should be able to figure out a way to
let those SETFs thru as if they were outside integrity, and then we get a little less UFBing
but even better SETF behaves as it should.
It would be nice to do referential integrity and notice any time a model object gets stored in
a cellular slot (or in a list in such) and then mop those up on not-to-be.
|#
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
(in-package :cells)
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
(defparameter *data-pulse-id* 0)
(defparameter *c-debug* nil)
(defparameter *defer-changes* nil)
(defparameter *within-integrity* nil)
(defparameter *client-queue-handler* nil)
(defparameter *unfinished-business* nil)
#+test
(cells-reset)
(defun cells-reset (&optional client-queue-handler &key debug)
(utils-kt-reset)
(setf
*c-debug* debug
*c-prop-depth* 0
*data-pulse-id* 0
*defer-changes* nil ;; should not be necessary, but cannot be wrong
*client-queue-handler* client-queue-handler
*within-integrity* nil
*unfinished-business* nil
*trcdepth* 0)
(trc nil "------ cell reset ----------------------------"))
(defun c-stop (&optional why)
(setf *stop* t)
(print `(c-stop-entry ,why))
(format t "~&C-STOP> stopping because ~a" why) )
(define-symbol-macro .stop
(c-stop :user))
(defun c-stopped ()
*stop*)
(export! .stopped)
(define-symbol-macro .stopped
(c-stopped))
(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
(declare (ignorable assertion places fmt$ fmt-args))
#+(or)`(progn)
`(unless *stop*
(unless ,assertion
,(if fmt$
`(c-break ,fmt$ , at fmt-args)
`(c-break "failed assertion: ~a" ',assertion)))))
(defvar *call-stack* nil)
(defvar *depender* nil)
;; 2008-03-15: *depender* let's us differentiate between the call stack and
;; and dependency. The problem with overloading *call-stack* with both roles
;; is that we miss cyclic reentrance when we use without-c-dependency in a
;; rule to get "once" behavior or just when fm-traversing to find someone
(defmacro def-c-trace (model-type &optional slot cell-type)
`(defmethod trcp ((self ,(case cell-type
(:c? 'c-dependent)
(otherwise 'cell))))
(and (typep (c-model self) ',model-type)
,(if slot
`(eq (c-slot-name self) ',slot)
`t))))
(defmacro without-c-dependency (&body body)
` (let (*depender*)
, at body))
(export! .cause)
(define-symbol-macro .cause
(car *causation*))
(define-condition unbound-cell (unbound-slot)
((cell :initarg :cell :reader cell :initform nil)))
(defgeneric slot-value-observe (slotname self new old old-boundp cell)
#-(or cormanlisp)
(:method-combination progn))
#-cells-testing
(defmethod slot-value-observe #-(or cormanlisp) progn
(slot-name self new old old-boundp cell)
(declare (ignorable slot-name self new old old-boundp cell)))
; -------- cell conditions (not much used) ---------------------------------------------
(define-condition xcell () ;; new 2k0227
((cell :initarg :cell :reader cell :initform nil)
(app-func :initarg :app-func :reader app-func :initform 'bad-cell)
(error-text :initarg :error-text :reader error-text :initform "<???>")
(other-data :initarg :other-data :reader other-data :initform "<nootherdata>"))
(:report (lambda (c s)
(format s "~& trouble with cell ~a in function ~s,~s: ~s"
(cell c) (app-func c) (error-text c) (other-data c)))))
(define-condition c-enabling ()
((name :initarg :name :reader name)
(model :initarg :model :reader model)
(cell :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&unhandled <c-enabling>: ~s" condition)
(break "~&i say, unhandled <c-enabling>: ~s" condition))))
(define-condition c-fatal (xcell)
((name :initarg :name :reader name)
(model :initarg :model :reader model)
(cell :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&fatal cell programming error: ~s" condition)
(format stream "~& : ~s" (name condition))
(format stream "~& : ~s" (model condition))
(format stream "~& : ~s" (cell condition)))))
(define-condition c-unadopted (c-fatal)
()
(:report
(lambda (condition stream)
(format stream "~&unadopted cell >: ~s" (cell condition))
(format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
(defun c-break (&rest args)
(unless *stop*
(let ((*print-level* 5)
(*print-circle* t)
(args2 (mapcar 'princ-to-string args)))
(c-stop args)
(format t "~&c-break > stopping > ~{~a ~}" args2)
(print `(c-break-args , at args2))
(apply 'error args2))))--- /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/constructors.js 2008/04/06 19:16:17 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Cells -- Automatic Dataflow Managememnt
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cells)
(eval-now!
(export '(.cache-bound-p
;; Cells Constructors
c?n
c?once
c?n-until
c?1
c_1
c?+n
;; Debug Macros and Functions
c?dbg
c_?dbg
c-input-dbg
)))
;___________________ constructors _______________________________
(defmacro c-lambda (&body body)
`(c-lambda-var (slot-c) , at body))
[158 lines skipped]
--- /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/defmodel.js 2008/04/06 19:16:17 1.1
[359 lines skipped]
--- /project/cells/cvsroot/Cells-js/defpackage.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/defpackage.js 2008/04/06 19:16:17 1.1
[422 lines skipped]
--- /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/family-values.js 2008/04/06 19:16:17 1.1
[518 lines skipped]
--- /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/family.js 2008/04/06 19:16:17 1.1
[729 lines skipped]
--- /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/fm-utilities.js 2008/04/06 19:16:17 1.1
[1374 lines skipped]
--- /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/initialize.js 2008/04/06 19:16:17 1.1
[1437 lines skipped]
--- /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/integrity.js 2008/04/06 19:16:17 1.1
[1636 lines skipped]
--- /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/link.js 2008/04/06 19:16:17 1.1
[1775 lines skipped]
--- /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/md-slot-value.js 2008/04/06 19:16:17 1.1
[2134 lines skipped]
--- /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/md-utilities.js 2008/04/06 19:16:17 1.1
[2222 lines skipped]
--- /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/model-object.js 2008/04/06 19:16:17 1.1
[2504 lines skipped]
--- /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/propagate.js 2008/04/06 19:16:17 1.1
[2786 lines skipped]
--- /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/slot-utilities.js 2008/04/06 19:16:17 1.1
[2883 lines skipped]
--- /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/synapse-types.js 2008/04/06 19:16:17 1.1
[3035 lines skipped]
--- /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/synapse.js 2008/04/06 19:16:17 1.1
[3124 lines skipped]
--- /project/cells/cvsroot/Cells-js/test-cycle.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/test-cycle.js 2008/04/06 19:16:17 1.1
[3201 lines skipped]
--- /project/cells/cvsroot/Cells-js/test-ephemeral.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/test-ephemeral.js 2008/04/06 19:16:17 1.1
[3258 lines skipped]
--- /project/cells/cvsroot/Cells-js/test-propagation.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/test-propagation.js 2008/04/06 19:16:17 1.1
[3303 lines skipped]
--- /project/cells/cvsroot/Cells-js/test-synapse.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/test-synapse.js 2008/04/06 19:16:17 1.1
[3405 lines skipped]
--- /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/test.js 2008/04/06 19:16:17 1.1
[3633 lines skipped]
--- /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/trc-eko.js 2008/04/06 19:16:17 1.1
[3792 lines skipped]
--- /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 NONE
+++ /project/cells/cvsroot/Cells-js/variables.js 2008/04/06 19:16:17 1.1
[3910 lines skipped]
More information about the Cells-cvs
mailing list