Commit 5e40bf5f authored by Dave Cooper's avatar Dave Cooper
Browse files

Reverted from hash-tables to lists for dependency tracking, pending

the adoption of a proper adaptive Abstract Associative Map.
parent ef4b9ea3
......@@ -93,9 +93,6 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
;;
))))
(defun app (&rest args)
(let ((self (apply #'make-object 'app args)))
(the make!)))
(defun gdl ()
(let ((destination-directory
......
......@@ -27,6 +27,7 @@
(:export #:copy-directory
#:copy-file
#:delete-directory-and-files
#:dump-memory
#:implementation-identifier
#:make-gdl-app
#:next-datestamp
......@@ -55,6 +56,22 @@
target :force force :quiet quiet :if-does-not-exist if-does-not-exist))
#+(and mswindows allegro)
(ff:def-foreign-call (memory-status-dump "memory_status_dump") ())
(defun dump-memory (&key (output-name "mem")
(output-type "txt")
(output-path (merge-pathnames (make-pathname :name output-name
:type output-type)
(glisp:temporary-folder))))
#+(and mswindows allegro)
(let ((status (memory-status-dump (namestring (translate-logical-pathname output-path)))))
(unless (zerop status) (error "~&memory-status-dump failed with non-zero return code: ~a~%~%" status))
output-path)
#-(and mswindows allegro)
(error "Need implementation of dump-memory for currently running lisp."))
(defun implementation-identifier ()
(asdf-utilities:implementation-identifier))
......
cd %~dp0\program\
%windir%\system32\cmd.exe "/C start ..\gpl\gnu-emacs-23.3\bin\runemacs.exe --no-splash --no-init-file -l ..\emacs\gdl.el" -f gdl
%windir%\system32\cmd.exe "/C start ..\gpl\gnu-emacs-23.3\bin\runemacs.exe --no-splash --no-init-file -l ..\emacs\gdl.el -f gdl"
......@@ -146,9 +146,9 @@ a list, returns it unchanged.
(defun find-messages-used-by (instance message-key)
"List of pairs of instance/keyword. This returns the list of direct dependants of a given message in a given instance.
Note that this is not recursive; if you want to generate a tree, then you have to call this recursively yourself.
"List of pairs of instance/keyword. This returns the list of direct dependants of a given
message in a given instance. Note that this is not recursive; if you want to generate a tree,
then you have to call this recursively yourself.
If you want an easy way to remember the meaning of dependant and dependency:
......@@ -159,23 +159,12 @@ You have a dependency on caffeine. Your children are your dependants.
(when message-hash (reverse (gethash message-key message-hash)))))
(defun find-dependants (instance message-key)
"List of pairs of instance/keyword. This returns the list of direct dependants of a given message in a given instance.
Note that this is not recursive; if you want to generate a tree, then you have to call this recursively yourself.
If you want an easy way to remember the meaning of dependant and dependency:
You have a dependency on caffeine. Your children are your dependants.
"
(find-messages-which-use instance message-key))
(defun find-messages-which-use (instance message-key)
"List of pairs of instance/keyword. This returns the list of direct dependants of a given message in a given instance.
Note that this is not recursive; if you want to generate a tree, then you have to call this recursively yourself.
"List of pairs of instance/keyword. This returns the list of direct dependants of a given
message in a given instance. Note that this is not recursive; if you want to generate a tree,
then you have to call this recursively yourself.
If you want an easy way to remember the meaning of dependant and dependency:
......@@ -194,18 +183,57 @@ You have a dependency on caffeine. Your children are your dependants.
(push (list instance (make-keyword (string message))) result)))))))
(defun find-dependencies (instance message-key)
"List of pairs of instance/keyword. This returns the list of direct dependants of a given message in a given instance.
Note that this is not recursive; if you want to generate a tree, then you have to call this recursively yourself.
(find-messages-used-by instance message-key))
If you want an easy way to remember the meaning of dependant and dependency:
You have a dependency on caffeine. Your children are your dependants.
(let ((value (gensym)) (need? (gensym)))
(defmacro with-dependency-tracking ((message-symbol &optional (self-sym 'self)) &rest body)
`(let ((,value (,message-symbol ,self-sym))
(,need? (and *run-with-dependency-tracking?* *notify-cons* *root-checking-enabled?*
;;
;; FLAG -- check that remotes are effectively from same tree as well
;;
(or (typep (first *notify-cons*) 'gdl-remote)
(same-tree? ,self-sym (first *notify-cons*))))))
,(when *compile-circular-reference-detection?*
`(when (and *run-with-circular-reference-detection?*
(member (list ,self-sym ',message-symbol) *till-now* :test #'equalp))
(error "Circular reference detected")))
(if (eq (first (ensure-list ,value)) 'gdl-rule::%unbound%)
(progn (setq ,value (list (let* ,(remove nil
(list (when *compile-dependency-tracking?*
`(*notify-cons* (when *run-with-dependency-tracking?*
(list ,self-sym ',message-symbol))))
(when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list ,self-sym ',message-symbol)
*till-now*))))))
,@body)
(when ,need? (list (copy-list *notify-cons*)))))
(if (not (eql (first ,value) 'gdl-rule:%not-handled%))
(setf (,message-symbol ,self-sym) ,value)
;;(without-interrupts (setf (,message-symbol ,self-sym) ,value))
(progn (setq ,need? nil)
(not-handled ,self-sym ',message-symbol))))
(when ,need? (add-notify-cons *notify-cons* ,value)))
(first ,value))))
"
(find-messages-used-by instance message-key))
(defun add-notify-cons (notify-cons value)
(let ((matching-sublist (assoc (first notify-cons) (second value))))
(if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
(push (copy-list notify-cons) (second value)))))
;;
;; FLAG -- merge the following two back in when we have adaptive Abstract Associative Map.
;;
#+nil
(let ((value (gensym)) (need? (gensym)))
(defmacro with-dependency-tracking ((message-symbol &optional (self-sym 'self)) &rest body)
`(let ((,value (,message-symbol ,self-sym))
......@@ -224,7 +252,7 @@ You have a dependency on caffeine. Your children are your dependants.
(setf (gethash (first *notify-cons*) *dependency-hash*)
(make-hash-table)))
(pushnew (list ,self-sym ,(make-keyword message-symbol))
(gethash (make-keyword (second *notify-cons*) )
(gethash (make-keyword (second *notify-cons*))
(gethash (first *notify-cons*) *dependency-hash*))
:test #'equalp))))
......@@ -249,7 +277,7 @@ You have a dependency on caffeine. Your children are your dependants.
(first ,value))))
#+nil
(defun add-notify-key (notify-cons value)
(if (second value)
(pushnew (second notify-cons) (gethash (first notify-cons) (second value)))
......
......@@ -82,6 +82,9 @@ the `#.' reader macro. Throws an error if evaluation would have occured.
"String. Replaces all substring occurrences of <b>old</b> with <b>new</b>
in <b>string</b>.
Note: In a full GDL system, you will have glisp:replace-regexp, which
is more powerful and probably more efficient than this.
:arguments (string \"String. The source string.\"
old \"String. The substring to be replaced.\"
new \"String. The substring to replace it with.\")
......
......@@ -778,6 +778,34 @@ a separate object hierarchy." object self)))
(%unbind-dependent-slots% object slot :updating? updating?)))
(defun %unbind-dependent-slots% (object slot &key updating?)
(let ((current (gethash (list object slot) *unbound-slots*)))
(unless current
(setf (gethash (list object slot) *unbound-slots*) t)
(if (slot-exists-p object slot)
(let ((slot-value (slot-value object slot)))
(when (not (eq (first (ensure-list slot-value)) 'gdl-rule::%unbound%))
(when (and *eager-setting-enabled?* (null (second slot-value)))
(push (list object slot) *leaf-resets*))
(mapc #'(lambda(notify-cons)
(destructuring-bind (node . messages) notify-cons
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message :updating? updating?)) messages)))
(second (slot-value object slot)))
(setf (second (slot-value object slot)) nil)
(when (not (third slot-value))
(setf (slot-value object slot)
(if (or updating? (not *remember-previous-slot-values?*))
'gdl-rule::%unbound%
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (typep object 'gdl-remote)
(the-object object (unbind-remote-slot slot)))))))
;;
;; FLAG -- merge this version back in when we have adaptive Abstract Associative Map
;;
#+nil
(defun %unbind-dependent-slots% (object slot &key updating?)
(let ((current (gethash (list object slot) *unbound-slots*)))
......
......@@ -243,11 +243,13 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
:test #'string-equal)
:defaults binary)))
(list :file
(namestring
(make-pathname :name (pathname-name binary)
:type nil
:defaults
(enough-namestring binary (the ppathname)))))))
(replace-substring
(namestring
(make-pathname :name (pathname-name binary)
:type nil
:defaults
(enough-namestring binary (the ppathname))))
"\\" "/"))))
binaries))))
:uncached))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment