Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 98 lines (75 sloc) 2.871 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
;; -*- 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)

(defun c-setting-debug (self slot-name c new-value)
  (declare (ignorable new-value))
  (cond
   ((null c)
    (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (c-in nil)"
      slot-name self)
        
    (c-break "setting-const-cell")
    (error "setting-const-cell"))
   ((c-inputp c))
   (t
    (let ((self (c-model c))
          (slot-name (c-slot-name c)))
      ;(trc "c-setting-debug sees" c newvalue self slot-name)
      (when (and c (not (and slot-name self)))
        ;; cv-test handles errors, so don't set *stop* (c-stop)
        (c-break "unadopted ~a for self ~a spec ~a" c self slot-name)
        (error 'c-unadopted :cell c))
      #+whocares (typecase c
        (c-dependent
         ;(trc "setting c-dependent" c newvalue)
         (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
           (c-slot-name c) self)
         
         (c-break "setting-ruled-cell")
         (error "setting-ruled-cell"))
        )))))

(defun c-absorb-value (c value)
  (typecase c
    (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true
    (c-drifter (c-value-incf c (c-value c) value))
    (t value)))

(eval-when (:compile-toplevel :load-toplevel :execute)
    (export '(c-value-incf)))

(defmethod c-value-incf (c (envaluer c-envaluer) delta)
  (c-assert (c-model c))
  (c-value-incf c (funcall (envalue-rule envaluer) c)
                 delta))

(defmethod c-value-incf (c (base number) delta)
  (declare (ignore c))
  (if delta
    (+ base delta)
    base))


;----------------------------------------------------------------------

(defun bd-slot-value (self slot-name)
  (slot-value self slot-name))

(defun (setf bd-slot-value) (new-value self slot-name)
  (setf (slot-value self slot-name) new-value))

(defun bd-bound-slot-value (self slot-name caller-id)
  (declare (ignorable caller-id))
  (when (bd-slot-boundp self slot-name)
    (bd-slot-value self slot-name)))

(defun bd-slot-boundp (self slot-name)
  (slot-boundp self slot-name))

(defun bd-slot-makunbound (self slot-name)
  (if slot-name ;; not in def-c-variable
    (slot-makunbound self slot-name)
    (makunbound self)))

#| sample incf
(defmethod c-value-incf ((base fpoint) delta)
(declare (ignore model))
(if delta
(fp-add base delta)
base))
|#
Something went wrong with that request. Please try again.