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]