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$ ,@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*) ,@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 ,@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) ,@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]