Index: /branches/gz-working/examples/cocoa-inspector.lisp =================================================================== --- /branches/gz-working/examples/cocoa-inspector.lisp (revision 8507) +++ /branches/gz-working/examples/cocoa-inspector.lisp (revision 8507) @@ -0,0 +1,469 @@ +;;;-*-Mode: LISP; Package: GUI -*- + +(in-package "GUI") + +#| +(cinspect ) + +A cocoa-based lisp inspector, LGPL'ed by Hamilton Link + +This code is freely distributable, etc. but I would appreciate people +submitting changes back to me and making suggestions about how it +could be altered or improved to me rather than starting a totally +separate inspector. + +Major plans: + Shift all the browser columns over to allow the first column to just have the object + Make double-clicking an object bring any existing inspector for that object to the front unless shift key is held + +Minor tweaks: + test on all sorts of things for sanity of leaf-ness of nodes and fields + test on all sorts of things for santity in what's safely editable in table view + fix the leaf-ness fields with a macptr value + change the font to something smaller (or even better, be settable) + clean up this file, maybe make a dedicated cinspector package for such things + document lessons learned about NSBrowser and NSTableView for next time + +Bugs: + - when selecting a non-item in a lower column that was just being + displayed (in the NSBrowser), the tableview isn't cleared and it + probably should be. + + Possibly a reasonable next thing after that would be to make control- +or alt-double-clicking open new windows with other browsing metaphors +appropriate to the object (like a class heirarchy browser, maybe a +table view for matrices, etc.), we'll see. + Eventually I'd like to expand the whole inspector functionality to +deal with ObjC things (methods and objects) and C foreign data in +general, but that's further off unless someone wants to take a crack +at it. Once we know we've got a macptr into ObjC we can deal, but some +very carefully written functions need to exist to safely interrogate +a random pointer to make that determination. + +Note the variable name convention in this file: "cinspector" refers to +a cocoa-inspector object containing a set of objects being displayed, +while "inspector" refers to an inspector object from the :inspector +package, which are used for command-line inspecting. + +|# + + +#| +I'd rather set up this file to be +- in-package cl-user +- require of some things +- a package definition for this code that brings in inspector::this-and-that and ccl::objc-stuff +- a couple of load-file forms that populate the new package and have the bulk of the following code +|# + +;;; This is useful when @ won't work, dynamically creating a NSString +;;; pointer from a string. + +(defun nsstringptr (string) + (ccl::objc-constant-string-nsstringptr + (ccl::ns-constant-string string))) + +#+old +(defmacro handler-case-for-cocoa (id form) + (declare (ignorable id)) + `(handler-case + ,form + (condition (c) + (declare (ignorable c)) + #+ignore + (format t "~s: Trapping condition: ~a" ,id c) + nil))) + +; for now this will map windows to objects -- the windows are pretty big, +; though, so it would be nice to extend them so the list of inspected objects +; is switchable in a single window (shouldn't be too hard once basic functionality +; is slapped down) +(defparameter *cocoa-inspector-nswindows-table* (make-hash-table :test 'eql)) + +;;; this is what a window should map to - an object that manages all +;;; the data a window might be displaying +(defclass cocoa-inspector () + ((object-vector :initform (make-array 0 :adjustable t :fill-pointer 0) :accessor object-vector) + (inspector-vector :initform (make-array 0 :adjustable t :fill-pointer 0) :accessor inspector-vector) + (focal-point :initform 0 :accessor focal-point))) + +;;; note that ELT pays attention to the fill pointer, while AREF doesn't! +(defmethod object ((cinspector cocoa-inspector)) + (elt (object-vector cinspector) (focal-point cinspector))) +(defmethod nth-object ((cinspector cocoa-inspector) n) + (elt (object-vector cinspector) n)) +(defmethod inspector ((cinspector cocoa-inspector)) + ;; This can return nil. + (let* ((i (focal-point cinspector)) + (v (inspector-vector cinspector)) + (n (length v))) + (if (< i n) + (aref v i)))) +(defmethod nth-inspector ((cinspector cocoa-inspector) n) + (elt (inspector-vector cinspector) n)) +(defmethod push-object (object (cinspector cocoa-inspector)) + (let ((inspector (inspector::make-inspector object))) + (vector-push-extend object (object-vector cinspector)) + (vector-push-extend inspector (inspector-vector cinspector)) + (inspector::update-line-count inspector)) + #+ignore + (format t " after push-object, fill pointers = ~a ~a~%" + (fill-pointer (object-vector cinspector)) (fill-pointer (inspector-vector cinspector))) + object) +(defmethod (setf max-column) (value (cinspector cocoa-inspector)) + (when (and (numberp value) (<= 0 value (1- (fill-pointer (object-vector cinspector))))) + (setf ; new fill-pointers are just outside of the valid bounds + (fill-pointer (object-vector cinspector)) (1+ value) + (fill-pointer (inspector-vector cinspector)) (1+ value) + ; new focal point is either what it was before, or the new max column if that's smaller + (focal-point cinspector) (min value (focal-point cinspector))) + #+ignore + (format t " after (setf max-column), fill pointers = ~a ~a~%" + (fill-pointer (object-vector cinspector)) (fill-pointer (inspector-vector cinspector))) + value)) + +;; In the browser view, we'll find the element for some column +;; and consider whether any of its components merit further inspection +;; and, if so, which ones +(defmethod leaf-node-p ((thing t)) nil) +(defmethod leaf-node-p ((thing (eql t))) t) +(defmethod leaf-node-p ((thing null)) t) +(defmethod leaf-node-p ((thing number)) t) +(defmethod leaf-node-p ((thing string)) t) +(defmethod leaf-node-p ((thing inspector::unbound-marker)) t) +(defmethod leaf-field-p ((thing t) n) + (declare (ignore n)) + nil) ; for a non-leaf node, all fields are futher probable by default +(defmethod leaf-field-p ((thing symbol) n) + (when (and (keywordp thing) (= n 4)) t)) + +; whatever is currently the selected object in the inspector, get its +; properties and values for the tableView and print them to a string +(defun focus-nth-line (cinspector n) + (let* ((inspector (inspector cinspector)) + (*print-circle* t) + (output-stream (make-string-output-stream))) + (inspector::prin1-line-n inspector output-stream n) + (get-output-stream-string output-stream))) +(defun nth-object-nth-line (cinspector obj-n line-n) + (let* ((inspector (nth-inspector cinspector obj-n)) + (*print-circle* t) + (output-stream (make-string-output-stream))) + (inspector::prin1-line-n inspector output-stream line-n) + (get-output-stream-string output-stream))) +(defun focus-nth-property (cinspector n) + (let ((inspector (inspector cinspector))) + (multiple-value-bind (value label type) (inspector::line-n inspector n) + (declare (ignore value type)) + (if label + (format nil "~a" label) + "")))) +(defun focus-nth-value (cinspector n) + (let* ((inspector (inspector cinspector)) + (*print-circle* t) + (output-stream (make-string-output-stream)) + (*package* (find-package :cl-user))) + (multiple-value-bind (value label type) (inspector::line-n inspector n) + (declare (ignore label type)) + (format output-stream "~s" value)) + (get-output-stream-string output-stream))) +(defun nth-object-nth-value (cinspector obj-n line-n) + (let ((inspector (nth-inspector cinspector obj-n))) + (multiple-value-bind (value label type) (inspector::line-n inspector line-n) + (declare (ignore label type)) + value))) +(defun (setf focus-nth-value) (value cinspector n) + (let ((inspector (inspector cinspector))) + (setf (inspector::line-n inspector n) value))) +(defun focus-nth-value-editable (cinspector n) + (let ((inspector (inspector cinspector))) + (multiple-value-bind (value label type) (inspector::line-n inspector n) + (declare (ignore value)) + (and (or (null type) + (eq :normal type) + (eq :colon type)) + (editable-field-p (object cinspector) n label))))) +(defun nth-object-nth-value-editable (cinspector obj-n line-n) + (let ((inspector (nth-inspector cinspector obj-n))) + (multiple-value-bind (value label type) (inspector::line-n inspector line-n) + (declare (ignore value)) + (and (or (null type) + (eq :normal type) + (eq :colon type)) + (editable-field-p (nth-object cinspector obj-n) line-n label))))) +;; for now most of these will assume that field numbers are good enough, +;; certain things have inspector fields that move around (like symbols) +;; and can be dealt with on a case by case basis, but that's the reason +;; for passing in the label along with the field number +(defmethod editable-field-p ((thing t) n label) + (declare (ignore n label)) + t) +;; for lists field 4 is length, could cause a change but inspector doesn't just handle it +;; and at the moment I haven't started thinking of a framework for allowing such extensions +(defmethod editable-field-p ((thing list) n label) + (declare (ignore label)) + (/= n 4)) + +#| +I think most of the following should be pretty straightforward for +most utilities meant to run under openmcl: A NIB file, some delegates +and data sources, and some specialized callback functions for talking +with the ObjC world, and some standard code for keeping track of the +appropriate windows. -hel +|# + +; When loading a NIB file with an NSWindowController, DON'T omit the .nib extension +; if you're calling initWithWindowNibPath:owner: (even though the documentation says you should!) +#+ignore +(defparameter *default-inspector-nib-pathname* #p"CCL:OpenMCL.app;Contents;Resources;English.lproj;OpenmclInspector.nib") +; When loading it with a custom WindowController and initWithWindowNibName:, just the main file name +(defparameter *default-inspector-nib-pathname* #p"OpenmclInspector") + +;; Q: Is this subclass of NSBrowser enabling the doubleAction? I added it expecting to have to +;; specialize mouseDown (or whatever) to track double-clicking, but it just started working. +(defclass inspector-ns-browser (ns:ns-browser) ; just to specialize mousing, not add slots + () + (:metaclass ns:+ns-object)) + +(defclass inspector-window-controller (ns:ns-window-controller) + ((inspector-browser :foreign-type :id :reader inspector-browser)) + (:metaclass ns:+ns-object)) + +(defclass inspector-browser-delegate (ns:ns-object) + ((inspector-table-view :foreign-type :id :reader inspector-table-view) + (inspector-window :foreign-type :id :reader inspector-window)) + (:metaclass ns:+ns-object)) + +; why is the order of these two slots important? +; I get a segfault selecting the browser when they're in window/browser order after doing modifications in the table. +(defclass inspector-table-view-data-source (ns:ns-object) + ((inspector-browser :foreign-type :id :reader inspector-browser) + (inspector-window :foreign-type :id :reader inspector-window)) + (:metaclass ns:+ns-object)) + +(defclass inspector-table-view-delegate (ns:ns-object) + ((inspector-window :foreign-type :id :reader inspector-window)) + (:metaclass ns:+ns-object)) + + +;;; is there some reason this is called before the cell is actually +;;; selected? In any case, when a non-leaf cell is selected, this +;;; function is called first for the new column, so it has to push the +;;; new element into the cinspector -- what the browserAction will be +;;; left doing it remains to be seen. The only other time this is +;;; called AFAICT is when loadColumnZero or reloadColumn is called +(objc:defmethod (#/browser:numberOfRowsInColumn: :nteger) + ((self inspector-browser-delegate) + browser + (column :nteger)) + (or (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (selected-column (#/selectedColumn browser)) ; probably always (1- column), when a column is selected + (cinspector-column (1- selected-column)) ; 2nd column of nsbrowser <-> 1st column of cinspector + (row (#/selectedRowInColumn: browser selected-column))) + #+ignore + (format t "getting length of column ~d based on row ~d in column ~d~%" column row selected-column) + (cond ((not cinspector) 0) + ((= column 0) 1) ; just displaying the printed representaiton of the top inspected object + ((= selected-column 0) ; selected the printed rep of the inspected object (column should = 1) + (setf (max-column cinspector) 0) ; crop object-vector in cinspector + (let ((inspector (nth-inspector cinspector 0))) ; inspector for top object + (inspector::inspector-line-count inspector))) + ((>= selected-column 1) ; (-1 is the N/A column) + (setf (max-column cinspector) cinspector-column) ; crop object-vector in cinspector + (push-object (nth-object-nth-value cinspector cinspector-column row) cinspector) + (let ((inspector (nth-inspector cinspector (1+ cinspector-column)))) ; inspector for object just pushed + (inspector::inspector-line-count inspector))))) + 0)) + +#| +;; temporarily saved in case the above fails horribly + (if cinspector + (handler-case + (progn (when (<= 0 selected-column) ; -1 is sort of the N/A column + (setf (max-column cinspector) selected-column) + (push-object (nth-object-nth-value cinspector selected-column row) cinspector)) + (let ((inspector (nth-inspector cinspector column))) + (inspector::inspector-line-count inspector))) + (condition () 0)) + 0))) +|# + +;; In the following method defn this is unnecessary, the Browser can tell this for itself +;; [cell "setLoaded:" : #$YES] +(objc:defmethod (#/browser:willDisplayCell:atRow:column: :void) + ((self inspector-browser-delegate) + browser + cell + (row :nteger) + (column :nteger)) + (declare (ignorable browser column)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (cinspector-column (1- column))) ; 2nd column of nsbrowser <-> 1st column of cinspector + #+ignore + (format t "asking for value for column ~a, row ~a~%" column row) + (cond ((not cinspector) nil) + ((= column 0) + (#/setStringValue: cell (nsstringptr (format nil "~s" (nth-object cinspector 0)))) + (#/setLeaf: cell nil)) + (t + ;; when switching between widgets to the browser, we can + ;; have reloaded a column and need to drill down a row + ;; from where we are at the moment + (#/setStringValue: cell (nsstringptr (nth-object-nth-line cinspector cinspector-column row))) + ;; leaf-p should really consider the type of the object in + ;; question (eventually taking into account whether we're + ;; browsing the class heirarchy or into objc or whatever) + (#/setLeaf: cell (or (leaf-node-p (nth-object cinspector cinspector-column)) ; i.e. no fields drill down + (leaf-field-p (nth-object cinspector cinspector-column) row) + ;; for now... + (= row 0) + (not (nth-object-nth-value-editable cinspector cinspector-column row)))))))) + +;;; when all is said and done and once the cinspector is properly +;;; populated, the selected object in the browser's nth column is +;;; actually the object in the cinspector's nth column (i.e. because +;;; the selected object is displayed in the next browser column over, +;;; and the cinspector and nsbrowser have a 1-off discrepancy, they +;;; cancel out) -- just a note to make the difference between these +;;; next two functions and the previous two functions + +;;; change the focus of the the table view to be the selected object +(objc:defmethod (#/browserAction: :void) + ((self inspector-browser-delegate) + sender); don't know why I'd want to, but could use a separate IBTarget class + #+ignore (format t "browserAction~%") + (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (column (#/selectedColumn sender))) + (when (<= 0 column) + (setf (focal-point cinspector) column) + (#/reloadData (inspector-table-view self)) + #+ignore + (format t " responding to selection in column ~d~%" column)))) + +;; open a new inspector on the selected object +(objc:defmethod (#/browserDoubleAction: :void) + ((self inspector-browser-delegate) + sender) + #+ignore (format t "browserDoubleAction~%") + (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)) + (column (#/selectedColumn sender))) + (when (< -1 column (length (object-vector cinspector))) + ;; this seems to work, but I'm not really paying attention to + ;; thread stuff... + (cinspect (nth-object cinspector column))))) + +(objc:defmethod (#/numberOfRowsInTableView: :nteger) + ((self inspector-table-view-data-source) + table-view) + (declare (ignore table-view)) + + (or (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + (if cinspector + (let ((inspector (inspector cinspector))) + (if inspector + (inspector::inspector-line-count inspector) + 0)))) + 0)) + +(objc:defmethod #/tableView:objectValueForTableColumn:row: + ((self inspector-table-view-data-source) + table-view + table-column + (row :nteger)) + (declare (ignore table-view)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + (cond ((not cinspector) + #@"") + ((#/isEqual: (#/identifier table-column) #@"property") + (nsstringptr (focus-nth-property cinspector row))) + ((#/isEqual: (#/identifier table-column) #@"value") + (nsstringptr (focus-nth-value cinspector row)))))) + +;; I'm hoping that the delegate will prevent this from being called willy-nilly +(objc:defmethod (#/tableView:setObjectValue:forTableColumn:row: :void) + ((self inspector-table-view-data-source) + table-view object table-column (row :nteger)) + (declare (ignore table-column)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + ;; without any formatters, object appears to be an NSCFString + ;; also note we should probably save the original value (including unboundness etc) + ;; first so that we can return to it in the event of any error + ;; plus we should avoid doing anything if the original string and the new string are equal + (when cinspector + (setf (focus-nth-value cinspector row) + (let ((*package* (find-package :cl-user))) + ;; with-autorelease-pool could possibly be needed to + ;; autorelease the cString we're handling (I think) + (eval (read-from-string (lisp-string-from-nsstring object))))) + (#/reloadData table-view) ; really could just reload that one cell, but don't know how... + ;; changing the focused object may effect the browser's path, + ;; reload its column and keep the cinspector consistent Here we + ;; have to make sure that the column we're reloading and the + ;; column after both have values to display, for when + ;; reloadColumn: invokes browser:willDisplayCell:atRow:column: + (#/reloadColumn: (inspector-browser self) (focal-point cinspector)) + ;; [inspector-browser "scrollColumnToVisible:" :int (focal-point cinspector)] ; maybe need this, too + ))) + +;;; In the table view, the properties are not editable, but the +;;; values (if editable) allow lisp forms to be entered that are +;;; read and evaluated to determine the new property value. +(objc:defmethod (#/tableView:shouldEditTableColumn:row: :) + ((self inspector-table-view-delegate) + table-view table-column (row :nteger)) + (declare (ignore table-view)) + (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))) + (and cinspector + (#/isEqual: (#/identifier table-column) #@"value") + (/= row 0) ; in practice the reference to + ; the object isn't editable, and + ; the GUI semantics aren't clear anyway, + ; possibly there will come a + ; time when I put row 0 in the + ; table title, but I need to + ; maintain the 0-indexed + ; focus-nth-whatever API here + ; and elsewhere if I do that + (focus-nth-value-editable cinspector row)))) + +;; the inspectorwindowcontroller is set up as the delegate of the window... +;; we now eliminate the dangling pointer to the window from the hash table +(objc:defmethod (#/windowWillClose: :void) + ((self inspector-window-controller) notification) + (let ((nswindow (#/object notification))) + (remhash nswindow *cocoa-inspector-nswindows-table*))) + +;;; hopefully a generally useful function +(defun load-windowcontroller-from-nib (wc-classname nib-pathname) + "Takes a NIB name and returns a new window controller" + (with-autorelease-pool + (make-instance + wc-classname + :with-window-nib-name (nsstringptr (namestring nib-pathname))))) + +;;; make a new inspector window from the nib file, and hash the window's +;;; browser and tableview to the object +(defun cinspect (object) + (with-autorelease-pool + (let* ((windowcontroller (load-windowcontroller-from-nib 'inspector-window-controller *default-inspector-nib-pathname*)) + (window (#/window windowcontroller)) + (cinspector (make-instance 'cocoa-inspector))) + ;; set up the window's initial "focused" object -- this may change as + ;; different parts of the inspector are clicked on, and actually we + ;; probably want to track more information than that associated with the + ;; window, so probably this will eventually be hashed to something like + ;; an inspector for the object or an even bigger wrapper + (setf (gethash window *cocoa-inspector-nswindows-table*) cinspector) + (push-object object cinspector) + ;; is this working? it isn't breaking, but double-clicking is + ;; being handled as two single actions + (let* ((browser (inspector-browser windowcontroller))) + (#/setColumnResizingType: browser #$NSBrowserUserColumnResizing) + (#/setPrefersAllColumnUserResizing: browser nil) + (#/setDoubleAction: browser (@selector #/browserDoubleAction:)) + (#/setIgnoresMultiClick: browser t)) + (#/showWindow: windowcontroller window) + window))) + +;;; Make INSPECT call CINSPECT. +(setq inspector::*default-inspector-ui-creation-function* 'cinspect) Index: /branches/gz-working/examples/cocoa/nib-loading/HOWTO.html =================================================================== --- /branches/gz-working/examples/cocoa/nib-loading/HOWTO.html (revision 8506) +++ /branches/gz-working/examples/cocoa/nib-loading/HOWTO.html (revision 8507) @@ -38,5 +38,5 @@ elements.

-

InterfaceBuilder is an appliaction that ships with Apple's +

InterfaceBuilder is an application that ships with Apple's Developer Tools. The Developer Tools are an optional install that comes with Mac OS X. Before you can use this HOWTO, you'll @@ -114,9 +114,9 @@

The pathname is just a reference to the nibfile we want to - load. The dictionary holds references to objects—the - object that owns the nibfile (in this case, the running - NSApplication object), and an array used to hold any toplevel - objects in the nibfile. The zone is areference to the area of - memory where the nibfile objects will be allocated.

+ load. The dictionary holds references to objects. In this + first simple example, we'll use it only to identify the + nibfile's owner, which in this case is the application + itself. The zone is a reference to the area of memory where + the nibfile objects will be allocated.

Don't worry if none of this makes sense to you; the code to @@ -128,8 +128,8 @@ -

First, we'll get the zone from the running application. We'll - tell Cocoa to allocate the nibfile objects in the same zone that - the application uses, so getting a zone is a simple matter of - asking the application for the one it's using.

+

First, we'll get a memory zone. We'll tell Cocoa to allocate + the nibfile objects in the same zone that the application + uses, so getting a zone is a simple matter of asking the + application for the one it's using.

Before we can ask the application anything, we need a @@ -148,106 +148,113 @@ 

-        ? (setf *my-app-class* (#_NSClassFromString (%make-nsstring "NSApplication")))
-        #<OBJC:OBJC-CLASS NS:NS-APPLICATION (#x7FFF704C5C00)>
-
- -

Notice, by the way, that this form allocates an NSString - object. We do it this way for the sake of simplicity, but it's - not an example of good programming practice. NSStrings are - foreign objects, allocated by the Objective-C runtime. They - are not garbage-collected by Lisp, and so when you create them - they hang around in memory until you manually deallocate them, - or until you quit from Clozure CL.

- -

This simple example goes on to create several foreign objects - by evaluating forms in the Listener, storing some of them in - global variables. In this example, these objects are never - deallocated. It's not a problem in such a small example; we - just create a handful of objects at the Listener, and they are - disposed of when we quit Clozure CL. But when writing real - applications using the Objective-C bridge, you will need to - learn to use Cocoa's memory-management discipline so that you - can ensure that foreign objects are allocated and deallocated - properly.

- -

Now that we have the application class, we can ask it for a - reference to the running application:

- - 
-        ? (setf *my-app* (#/sharedApplication *my-app-class*))
-        #<LISP-APPLICATION  (#x1B8E20)>
-
- -

Voilà! We have a reference to the running Clozure CL - application object! Now we can ask it for its zone, where it - allocates objects in memory:

- - 
-          ? (setf *my-zone* (#/zone *my-app*))
-          #<A Foreign Pointer #x8B000>
-
- -

Now we have a reference to the application's zone. We can - pass it - to loadNibFile:externalNameTable:withZone: to - tell it to allocate the nibfile's objects in the - application's zone.

- -
-

2. Make a Dictionary

-
- -

The dictionary argument - to loadNibFile:externalNameTable:withZone: is used - for two purposes. First, we use it to pass an owner object to - the method. Some Cocoa objects need to have references to owner - objects. For example, a window might need to check with an owner - object to determine whether its fields and buttons should be - enabled. You supply an owner object in the dictionary, under the - key "NSNibOwner".

- -

The second purpose of the dictionary object is to collect - references to any toplevel objects (such as buttons, text - fields, and so on) that the runtime creates when loading the - nibfile. To collect these, you pass an NSMutableArray object - under the key "NSNibTopLevelObjects".

- -

For this first example, we'll pass an owner object (the - application object), but we don't need to collect toplevel - objects, so we'll omit - the "NSNibTopLevelObjects" key.

- - 
-          ? (setf *my-dict* (#/dictionaryWithObject:forKey: (@class ns-mutable-dictionary) *my-app* #@"NSNibOwner"))
-          #<NS-MUTABLE-DICTIONARY {
-                                  NSNibOwner = <LispApplication: 0x1b8e10>;
-                                  } (#x137F3DD0)>
-            
-
- -
-

3. Load the Nibfile

-
- -

Now that we have the zone and the dictionary we need, we + ? (setf *my-app* + (let* ((class-name (%make-nsstring "NSApplication")) + (appclass (#_NSClassFromString class-name))) + (#/release class-name) + (#/sharedApplication appclass))) + #<LISP-APPLICATION <LispApplication: 0x1b8de0> (#x1B8DE0)> + + +

Let's review this form step-by-step.

+ +

First of all, it's going to store the returned application + object in the variable *my-app*, so that we have it + convenient for later use.

+ +

We need an NSString object that contains the + name of the application class, so the code allocates one by + calling %make-nsstring. The NSString + object is a dynamically-allocated foreign object, not managed by + Lisp's garbage-collector, so we'll have to be sure to release it + later.

+ +

The code next uses the class-name to get the + actual NSApplication class object, by + calling #_NSClassFromString.

+ +

Finally, after first releasing the NSString + object, it calls #/sharedApplication to get the + running application object, which turns out to be an instance + of LispApplication.

+ +

Voilà! We have a reference to the running Clozure CL + application object! Now we can ask it for its zone, where it + allocates objects in memory:

+ + 
+        ? (setf *my-zone* (#/zone *my-app*))
+        #<A Foreign Pointer #x8B000>
+
+ +

Now we have a reference to the application's zone, which is + one of the parameters we need to pass + to loadNibFile:externalNameTable:withZone:.

+ +
+

2. Make a Dictionary

+
+ +

The dictionary argument + to loadNibFile:externalNameTable:withZone: is + used for two purposes: to identify the nibfile's owner, and + to collect toplevel objects.

+ +

The nibfile's owner becomes the owner of all the toplevel + objects created when the nibfile is loaded, objects such as + windows, buttons, and so on. A nibfile's owner manages the + objects created when the nibfile is loaded, and provides a + way for your code to get references to those objects. You + supply an owner object in the dictionary, under the + key "NSNibOwner".

+ +

The toplevel objects are objects, such as windows, that are + created when the nibfile is loaded. To collect these, you + can pass an NSMutableArray object under the + key NSNibTopLevelObjects.

+ +

For this first example, we'll pass an owner object (the + application object), but we don't need to collect toplevel + objects, so we'll omit + the NSNibTopLevelObjects key.

+ + 
+        ? (setf *my-dict* 
+        (#/dictionaryWithObject:forKey: (@class ns-mutable-dictionary) 
+        *my-app* 
+        #@"NSNibOwner"))
+        #<NS-MUTABLE-DICTIONARY {
+        NSNibOwner = <LispApplication: 0x1b8e10>;
+        } (#x137F3DD0)>
+        
+
+ +
+

3. Load the Nibfile

+
+ +

Now that we have the zone and the dictionary we need, we can load the nibfile. We just need to create an NSString with the proper pathname first:

- 
-          ? (setf *nib-path* (%make-nsstring (namestring "/usr/local/openmcl/trunk/source/examples/cocoa/nib-loading/hello.nib")))
-          #<NS-MUTABLE-STRING "/usr/local/openmcl/trunk/source/examples/cocoa/nib-loading/hello.nib" (#x13902C10)>
-
- -

Now we can actually load the nibfile, passing the method + 

+        ? (setf *nib-path* 
+        (%make-nsstring 
+        (namestring "/usr/local/openmcl/ccl/examples/cocoa/nib-loading/hello.nib")))
+        #<NS-MUTABLE-STRING "/usr/local/openmcl/ccl/examples/cocoa/nib-loading/hello.nib" (#x13902C10)>
+
+ +

Now we can actually load the nibfile, passing the method the objects we've created:

- 
-          ? (setf *nib-path* (%make-nsstring (namestring "/usr/local/openmcl/trunk/source/examples/cocoa/nib-loading/hello.nib")))
-          #<NS-MUTABLE-STRING "/usr/local/openmcl/trunk/source/examples/cocoa/nib-loading/hello.nib" (#x13902C10)>
-          ? (#/loadNibFile:externalNameTable:withZone: (@class ns-bundle) *nib-path* *my-dict* *my-zone*)
-          T
-
- -

The window defined in the "hello.nib" file should appear + 

+        ? (#/loadNibFile:externalNameTable:withZone: 
+        (@class ns-bundle)
+        *nib-path*
+        *my-dict*
+        *my-zone*)
+        T
+
+ +

The window defined in the "hello.nib" file should appear on the screen. The loadNibFile:externalNameTable:withZone: @@ -256,7 +263,218 @@ returned NIL.

- - - - - +

At this point we no longer need the pathname and + dictionary objects, and we can release them:

+ + 
+        ? (setf *nib-path* (#/release *nib-path*))
+        NIL
+        ? (setf *my-dict* (#/release *my-dict*))
+        NIL
+
+ +
+

Making a Nib-loading Function

+
+ +

Loading a nibfile seems like something we might want to do + repeatedly, and so it makes sense to make it as easy as possible + to do. Let's make a single function we can call to load a nib as + needed.

+ +

The nib-loading function can take the file to be loaded as a + parameter, and then perform the sequence of steps covered in the + previous section. If we just literally do that, the result will + look something like this:

+ + 
+(defun load-nibfile (nib-path)
+  (let* ((app-class-name (%make-nsstring "NSApplication"))
+         (app-class (#_NSClassFromString class-name))
+         (app (#/sharedApplication appclass))
+         (app-zone (#/zone app))
+         (nib-name (%make-nsstring (namestring nib-path)))
+         (dict (#/dictionaryWithObject:forKey: 
+                (@class ns-mutable-dictionary) app #@"NSNibOwner")))
+    (#/loadNibFile:externalNameTable:withZone: (@class ns-bundle)
+                                               nib-name
+                                               dict
+                                               app-zone)))
+
+ +

The trouble with this function is that it leaks two strings + and a dictionary every time we call it. We need to release the + variables app-class-name, nib-name, + and dict before returning. So how about this + version instead?

+ + 
+(defun load-nibfile (nib-path)
+  (let* ((app-class-name (%make-nsstring "NSApplication"))
+         (app-class (#_NSClassFromString class-name))
+         (app (#/sharedApplication appclass))
+         (app-zone (#/zone app))
+         (nib-name (%make-nsstring (namestring nib-path)))
+         (dict (#/dictionaryWithObject:forKey: 
+                (@class ns-mutable-dictionary) app #@"NSNibOwner"))
+         (result (#/loadNibFile:externalNameTable:withZone: (@class ns-bundle)
+                                                            nib-name
+                                                            dict
+                                                            app-zone)))
+    (#/release app-class-name)
+    (#/release nib-name)
+    (#/release dict)
+    result))
+
+ +

This version solves the leaking problem by binding the result + of the load call to result, then releasing the + variables in question before returning the result of the + load.

+ +

There's just one more problem: what if we want to use the + dictionary to collect the nibfile's toplevel objects, so that we + can get access to them from our code? We'll need another version + of our function.

+ +

In order to collect toplevel objects, we'll want to pass an + NSMutableArray object in the dictionary, stored under the key + NSNibTopLevelObjects. So we first need to create such an + array object in the let form:

+ + 
+(let* (...
+       (objects-array (#/arrayWithCapacity: (@class ns-mutable-array) 16))
+       ...)
+  ...)
+
+ +

Now that we have the array in which to store the nibfile's + toplevel objects, we need to change the code that creates the + dictionary, so that it contains not only the owner object, but + also the array we just created:

+ + 
+  (let* (...
+         (dict (#/dictionaryWithObjectsAndKeys: (@class ns-mutable-dictionary)
+                    app #@"NSNibOwner"
+                    objects-array #&NSToplevelObjects))
+         ...)
+    ...)
+  
+
+ +

We'll want to release the NSMutableArray + object before returning, but first we need to collect the + objects in it. We'll do that by making a local variable to + store them, then iterating over the array object to get them all.

+ + 
+  (let* (...
+         (toplevel-objects (list))
+         ...)
+    (dotimes (i (#/count objects-array))
+      (setf toplevel-objects 
+            (cons (#/objectAtIndex: objects-array i)
+                  toplevel-objects)))
+    ...)
+
+ +

After collecting the objects, we can release the array, then + return the list of objects. It's still possible we might want + to know whether the load succeeded, so we + use values to return both the toplevel objects and + the success or failure of the load.

+ +

The final version of the nib-loading code looks like + this:

+ + 
+(defun load-nibfile (nib-path)
+  (let* ((app-class-name (%make-nsstring "NSApplication"))
+         (app-class (#_NSClassFromString app-class-name))
+         (app (#/sharedApplication app-class))
+         (app-zone (#/zone app))
+         (nib-name (%make-nsstring (namestring nib-path)))
+         (objects-array (#/arrayWithCapacity: (@class ns-mutable-array) 16))
+         (dict (#/dictionaryWithObjectsAndKeys: (@class ns-mutable-dictionary)
+                    app #@"NSNibOwner"
+                    objects-array #&NSNibToplevelObjects))
+         (toplevel-objects (list))
+         (result (#/loadNibFile:externalNameTable:withZone: (@class ns-bundle)
+                                                            nib-name
+                                                            dict
+                                                            app-zone)))
+    (dotimes (i (#/count objects-array))
+      (setf toplevel-objects 
+            (cons (#/objectAtIndex: objects-array i)
+                  toplevel-objects)))
+    (#/release app-class-name)
+    (#/release nib-name)
+    (#/release dict)
+    (#/release objects-array)
+    (values toplevel-objects result)))
+
+ +

Now we can call this function with some suitable nibfile, + such as simple "hello.nib" that comes with this HOWTO:

+ + 
+? (ccl::load-nibfile "hello.nib")
+(#<LISP-APPLICATION <LispApplication: 0x1b8da0> (#x1B8DA0)>
+ #<NS-WINDOW <NSWindow: 0x171344d0> (#x171344D0)>)
+T
+
+
+ +

The "Hello!" window appears on the screen, and two values are + returned. The first value is the list of toplevel objects that + were loaded. The second value, T indicates that the + nibfile was loaded successfully.

+ +
+

What About Unloading Nibfiles?

+
+ +

Cocoa provides no general nibfile-unloading API. Instead, if + you want to unload a nib, the accepted approach is to close all + the windows associated with a nibfile and release all the + toplevel objects. This is one reason that you might want to use + the "NSNibTopLevelObjects" key with the dictionary + object that you pass + to loadNibFile:externalNameTable:withZone:—to + obtain a collection of toplevel objects that you release when + the nibfile is no longer needed.

+ +

In document-based Cocoa applications, the main nibfile is + usually owned by the application object, and is never unloaded + while the application runs. Auxliliary nibfiles are normally + owned by controller objects, usually instances of + NSWindowController subclasses. When you + use NSWindowController objects to load nibfiles, + they take responsibility for loading and unloading nibfile + objects.

+ +

When you're experimenting interactively with nibfile loading, + you may not start out by + creating NSWindowController objects to load + nibfiles, and so you may need to do more of the object + management yourself. On the one hand, loading nibfiles by hand + is not likely to be the source of major application problems. On + the other hand, if you experiment with nib-loading for a long + time in an interactive session, it's possible that you'll end up + with numerous discarded objects cluttering memory, along with + various references to live and possibly released objects. Keep + this in mind when using the Listener to explore Cocoa. You can + always restore your Lisp system to a clean state by restarting + it, but of course you then lose whatever state you have built up + in your explorations. It's often a good idea to work from a text + file rather than directly in the Listener, so that you have a + record of the experimenting you've done. That way, if you need + to start fresh (or if you accidentally cause the application to + crash), you don't lose all the information you gained.

+ + + + + + Index: /branches/gz-working/examples/cocoa/nib-loading/nib-loading.lisp =================================================================== --- /branches/gz-working/examples/cocoa/nib-loading/nib-loading.lisp (revision 8506) +++ /branches/gz-working/examples/cocoa/nib-loading/nib-loading.lisp (revision 8507) @@ -13,18 +13,30 @@ (defun load-nibfile (nib-path) - (let* ((appclass (#_NSClassFromString (%make-nsstring "NSApplication"))) - (app (#/sharedApplication appclass)) + (let* ((app-class-name (%make-nsstring "NSApplication")) + (app-class (#_NSClassFromString app-class-name)) + (app (#/sharedApplication app-class)) (app-zone (#/zone app)) (nib-name (%make-nsstring (namestring nib-path))) - (toplevel-objects-array (#/arrayWithCapacity: (@class ns-mutable-array) 8)) - (context (#/dictionaryWithObjectsAndKeys: (@class ns-mutable-dictionary) - app #@"NSNibOwner" - toplevel-objects-array #@"NSNibTopLevelObjects")) - (load-succeeded-p (#/loadNibFile:externalNameTable:withZone: (@class ns-bundle) - nib-name context app-zone))) - (values load-succeeded-p context))) - + (objects-array (#/arrayWithCapacity: (@class ns-mutable-array) 16)) + (dict (#/dictionaryWithObjectsAndKeys: (@class ns-mutable-dictionary) + app #@"NSNibOwner" + objects-array #&NSNibTopLevelObjects)) + (toplevel-objects (list)) + (result (#/loadNibFile:externalNameTable:withZone: (@class ns-bundle) + nib-name + dict + app-zone))) + (dotimes (i (#/count objects-array)) + (setf toplevel-objects + (cons (#/objectAtIndex: objects-array i) + toplevel-objects))) + (#/release app-class-name) + (#/release nib-name) + (#/release dict) + (#/release objects-array) + (values toplevel-objects result))) #| (ccl::load-nibfile "/usr/local/openmcl/trunk/source/examples/cocoa/nib-loading/hello.nib") |# + Index: /branches/gz-working/level-0/X86/x86-array.lisp =================================================================== --- /branches/gz-working/level-0/X86/x86-array.lisp (revision 8506) +++ /branches/gz-working/level-0/X86/x86-array.lisp (revision 8507) @@ -164,13 +164,12 @@ uvector))) (#.x8664::subtag-bit-vector - (if (eql 0 val) - uvector (let* ((v0 (case val (1 -1) + (0 0) (t (report-bad-arg val 'bit)))) (l0 (ash (the fixnum (+ len 63)) -6))) (declare (type (unsigned-byte 8) v0) (type index l0)) - (%%init-ivector64 l0 v0 uvector)))) + (%%init-ivector64 l0 v0 uvector))) (t (report-bad-arg uvector '(or simple-bit-vector Index: /branches/gz-working/level-1/l1-error-system.lisp =================================================================== --- /branches/gz-working/level-1/l1-error-system.lisp (revision 8506) +++ /branches/gz-working/level-1/l1-error-system.lisp (revision 8507) @@ -369,4 +369,18 @@ (:report (lambda (c s) (format s "Unexpected end of file ~a" (stream-error-context c))))) + +(define-condition io-timeout (stream-error) + ()) + +(define-condition input-timeout (io-timeout) + () + (:report (lambda (c s) + (format s "Input timeout on ~s" (stream-error-stream c))))) +(define-condition output-timeout (io-timeout) + () + (:report (lambda (c s) + (format s "Output timeout on ~s" (stream-error-stream c))))) + + (define-condition impossible-number (reader-error) ((token :initarg :token :reader impossible-number-token) Index: /branches/gz-working/level-1/l1-sockets.lisp =================================================================== --- /branches/gz-working/level-1/l1-sockets.lisp (revision 8506) +++ /branches/gz-working/level-1/l1-sockets.lisp (revision 8507) @@ -533,6 +533,4 @@ connect out-of-band-inline - receive-timeout - send-timeout &allow-other-keys) ;; see man socket(7) tcp(7) ip(7) @@ -562,14 +560,4 @@ #+(or freebsd-target darwin-target) #$IPPROTO_TCP #$TCP_NODELAY 1)) - (when (and receive-timeout (> receive-timeout 0)) - (timeval-setsockopt fd - #$SOL_SOCKET - #$SO_RCVTIMEO - receive-timeout)) - (when (and send-timeout (> send-timeout 0)) - (timeval-setsockopt fd - #$SOL_SOCKET - #$SO_SNDTIMEO - send-timeout)) (when (or local-port local-host) (let* ((proto (if (eq type :stream) "tcp" "udp")) @@ -617,5 +605,5 @@ local-filename remote-filename sharing basic external-format (auto-close t) - receive-timeout send-timeout connect-timeout) + connect-timeout) "Create and return a new socket." (declare (dynamic-extent keys)) @@ -624,5 +612,5 @@ local-port local-host backlog class out-of-band-inline local-filename remote-filename sharing basic external-format - auto-close receive-timeout send-timeout connect-timeout)) + auto-close connect-timeout)) (ecase address-family ((:file) (apply #'make-file-socket keys)) @@ -710,5 +698,5 @@ -(defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) (receive-timeout 0) &allow-other-keys) +(defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) &allow-other-keys) (let* ((external-format (normalize-external-format :socket external-format))) (let ((element-type (ecase format @@ -726,6 +714,5 @@ :line-termination (external-format-line-termination external-format) :basic basic - :auto-close auto-close - :interactive (zerop receive-timeout))))) + :auto-close auto-close)))) (defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream) sharing basic (auto-close t) &allow-other-keys) Index: /branches/gz-working/level-1/l1-streams.lisp =================================================================== --- /branches/gz-working/level-1/l1-streams.lisp (revision 8506) +++ /branches/gz-working/level-1/l1-streams.lisp (revision 8507) @@ -58,4 +58,20 @@ :io :output)) + +(defun check-io-timeout (timeout) + (when timeout + (require-type timeout '(real 0 1000000)))) + +(defmethod stream-input-timeout ((s input-stream)) + nil) + +(defmethod (setf input-stream-timeout) (new (s input-stream)) + (check-io-timeout new)) + +(defmethod stream-output-timeout ((s output-stream)) + nil) + +(defmethod (setf stream-output-timeout) (new (s output-stream)) + (check-io-timeout new)) ;;; Try to return a string containing characters that're near the @@ -420,5 +436,6 @@ (unread-char-function 'ioblock-no-char-input) (encode-literal-char-code-limit 256) - (reserved3 nil)) + (input-timeout nil) + (output-timeout nil)) @@ -3776,5 +3793,13 @@ (synonym-method stream-direction) (synonym-method stream-device direction) - (synonym-method stream-surrounding-characters)) + (synonym-method stream-surrounding-characters) + (synonym-method stream-input-timeout) + (synonym-method stream-output-timeout)) + +(defmethod (setf input-stream-timeout) (new (s synonym-stream)) + (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new)) + +(defmethod (setf output-stream-timeout) (new (s synonym-stream)) + (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new)) @@ -3836,4 +3861,5 @@ (two-way-input-method stream-read-vector v start end) (two-way-input-method stream-surrounding-characters) + (two-way-input-method stream-input-timeout) (two-way-output-method stream-write-char c) (two-way-output-method stream-write-byte b) @@ -3848,5 +3874,12 @@ (two-way-output-method stream-finish-output) (two-way-output-method stream-write-list l c) - (two-way-output-method stream-write-vector v start end)) + (two-way-output-method stream-write-vector v start end) + (two-way-output-method stream-output-timeout)) + +(defmethod (setf stream-input-timeout) (new (s two-way-stream)) + (setf (stream-input-timeout (two-way-stream-input-stream s)) new)) + +(defmethod (setf stream-output-timeout) (new (s two-way-stream)) + (setf (stream-output-timeout (two-way-stream-output-stream s)) new)) (defmethod stream-device ((s two-way-stream) direction) @@ -5210,24 +5243,25 @@ (rlet ((now :timeval)) (let* ((wait-end - (if timeout - (multiple-value-bind (seconds millis) (milliseconds timeout) - (#_gettimeofday now (%null-ptr)) - (setq timeout (+ (* seconds 1000) millis)) - (+ (timeval->milliseconds now) timeout))))) + (when timeout + (#_gettimeofday now (%null-ptr)) + (+ (timeval->milliseconds now) timeout)))) (loop - ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the - ;; thread receives an interrupt) before a timeout is - ;; reached. - (when (fd-input-available-p fd (or timeout -1)) - (return t)) - ;; If it returned and a timeout was specified, check - ;; to see if it's been exceeded. If so, return NIL; - ;; otherwise, adjust the remaining timeout. - ;; If there was no timeout, continue to wait forever. - (when timeout - (#_gettimeofday now (%null-ptr)) - (setq timeout (- wait-end (timeval->milliseconds now))) - (if (<= timeout 0) - (return))))))) + (multiple-value-bind (win error) + (fd-input-available-p fd (or timeout -1)) + (when win + (return (values t nil nil))) + (when (eql error 0) ;timed out + (return (values nil t nil))) + ;; If it returned and a timeout was specified, check + ;; to see if it's been exceeded. If so, return NIL; + ;; otherwise, adjust the remaining timeout. + ;; If there was no timeout, continue to wait forever. + (unless (eql error (- #$EINTR)) + (return (values nil nil error))) + (when timeout + (#_gettimeofday now (%null-ptr)) + (setq timeout (- wait-end (timeval->milliseconds now))) + (if (<= timeout 0) + (return (values nil t nil))))))))) @@ -5241,27 +5275,25 @@ (rlet ((now :timeval)) (let* ((wait-end - (if timeout - (multiple-value-bind (seconds millis) (milliseconds timeout) - (#_gettimeofday now (%null-ptr)) - (setq timeout (+ (* seconds 1000) millis)) - (+ (timeval->milliseconds now) timeout))))) + (when timeout + (#_gettimeofday now (%null-ptr)) + (+ (timeval->milliseconds now) timeout)))) (loop - ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the - ;; thread receives an interrupt) before a timeout is - ;; reached. - (when (fd-ready-for-output-p fd (or timeout -1)) - (return t)) - ;; If it returned and a timeout was specified, check - ;; to see if it's been exceeded. If so, return NIL; - ;; otherwise, adjust the remaining timeout. - ;; If there was no timeout, continue to wait forever. - (when timeout - (#_gettimeofday now (%null-ptr)) - (setq timeout (- wait-end (timeval->milliseconds now))) - (if (<= timeout 0) - (return))))))) - - - + (multiple-value-bind (win error) + (fd-ready-for-output-p fd (or timeout -1)) + (when win + (return (values t nil nil))) + (when (eql error 0) + (return (values nil t nil))) + (unless (eql error (- #$EINTR)) + (return (values nil nil error))) + ;; If it returned and a timeout was specified, check + ;; to see if it's been exceeded. If so, return NIL; + ;; otherwise, adjust the remaining timeout. + ;; If there was no timeout, continue to wait forever. + (when timeout + (#_gettimeofday now (%null-ptr)) + (setq timeout (- wait-end (timeval->milliseconds now))) + (if (<= timeout 0) + (return (values nil t nil))))))))) @@ -5278,6 +5310,7 @@ (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN) - (let* ((res (ignoring-eintr (syscall syscalls::poll pollfds 1 (or milliseconds -1))))) - (> res 0)))) + (let* ((res (syscall syscalls::poll pollfds 1 (or milliseconds -1)))) + (declare (fixnum res)) + (values (> res 0) res)))) @@ -5286,16 +5319,9 @@ (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT) - (let* ((res (ignoring-eintr (syscall syscalls::poll pollfds 1 (or milliseconds -1))))) - (> res 0)))) - -(defun fd-urgent-data-available-p (fd &optional ticks) - (rletZ ((tv :timeval)) - (ticks-to-timeval ticks tv) - (%stack-block ((errfds *fd-set-size*)) - (fd-zero errfds) - (fd-set fd errfds) - (let* ((res (#_select (1+ fd) (%null-ptr) (%null-ptr) errfds - (if ticks tv (%null-ptr))))) - (> res 0))))) + (let* ((res (syscall syscalls::poll pollfds 1 (or milliseconds -1)))) + (declare (fixnum res)) + (values (> res 0) res)))) + + ;;; FD-streams, built on top of the ioblock mechanism. @@ -5373,9 +5399,19 @@ (buf (ioblock-inbuf ioblock)) (bufptr (io-buffer-bufptr buf)) - (size (io-buffer-size buf))) + (size (io-buffer-size buf)) + (avail nil)) (setf (io-buffer-idx buf) 0 (io-buffer-count buf) 0 (ioblock-eof ioblock) nil) - (when (or read-p (stream-listen s)) + (when (or read-p (setq avail (stream-listen s))) + (unless avail + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (multiple-value-bind (win timedout error) + (process-input-wait fd timeout) + (unless win + (if timedout + (error 'input-timeout :stream s) + (stream-io-error s (- error) "read"))))))) (let* ((n (with-eagain fd :input (fd-read fd bufptr size)))) @@ -5425,4 +5461,12 @@ (:file (fd-fsync fd)))) octets-to-write) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (multiple-value-bind (win timedout error) + (process-output-wait fd timeout) + (unless win + (if timedout + (error 'output-timeout :stream s) + (stream-io-error s (- error) "write")))))) (let* ((written (with-eagain fd :output (fd-write fd buf octets)))) @@ -5769,4 +5813,65 @@ (normalize-external-format (stream-domain s) new))) +(defmethod stream-input-timeout ((s basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-input-timeout) (new (s basic-input-stream)) + (setq new (check-io-timeout new)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (setf (ioblock-input-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-output-timeout ((s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-output-timeout) (new (s basic-output-stream)) + (setq new (check-io-timeout new)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-output-timeout ioblock) + (if new (round (* new 1000)))) + new))) + + +(defmethod stream-input-timeout ((s buffered-input-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-input-locked (ioblock) + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-input-timeout) (new (s buffered-input-stream-mixin)) + (setq new (check-io-timeout new)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-input-locked (ioblock) + (setf (ioblock-input-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-output-timeout ((s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-output-timeout) (new (s buffered-output-stream-mixin)) + (setq new (check-io-timeout new)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-output-timeout ioblock) + (if new (round (* new 1000)))) + new))) + ; end of L1-streams.lisp Index: /branches/gz-working/level-1/linux-files.lisp =================================================================== --- /branches/gz-working/level-1/linux-files.lisp (revision 8506) +++ /branches/gz-working/level-1/linux-files.lisp (revision 8507) @@ -890,5 +890,5 @@ (return)) (when in-fd - (when (fd-input-available-p in-fd 0) + (when (fd-input-available-p in-fd 1000) (%stack-block ((buf 1024)) (let* ((n (fd-read in-fd buf 1024))) Index: /branches/gz-working/lib/ccl-export-syms.lisp =================================================================== --- /branches/gz-working/lib/ccl-export-syms.lisp (revision 8506) +++ /branches/gz-working/lib/ccl-export-syms.lisp (revision 8507) @@ -560,4 +560,9 @@ stream-read-vector stream-write-vector + + stream-input-timeout + stream-output-timeout + with-input-timeout + with-output-timeout make-heap-ivector Index: /branches/gz-working/lib/macros.lisp =================================================================== --- /branches/gz-working/lib/macros.lisp (revision 8506) +++ /branches/gz-working/lib/macros.lisp (revision 8507) @@ -3568,2 +3568,32 @@ consing when N is a trivial constant integer." `(car (nthcdr ,n (multiple-value-list ,form)))) + + + +(defmacro with-input-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body) + "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's +stream-input-timeout set to TIMEOUT." + (let* ((old-input-timeout (gensym)) + (stream (gensym))) + `(let* ((,stream ,stream-form) + (,stream-var ,stream) + (,old-input-timeout (stream-input-timeout ,stream))) + (unwind-protect + (progn + (setf (stream-input-timeout ,stream) ,timeout) + ,@body) + (setf (stream-input-timeout ,stream) ,old-input-timeout))))) + +(defmacro with-output-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body) + "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's +stream-output-timeout set to TIMEOUT." + (let* ((old-output-timeout (gensym)) + (stream (gensym))) + `(let* ((,stream ,stream-form) + (,stream-var ,stream) + (,old-output-timeout (stream-output-timeout ,stream))) + (unwind-protect + (progn + (setf (stream-output-timeout ,stream) ,timeout) + ,@body) + (setf (stream-output-timeout ,stream) ,old-output-timeout))))) Index: /branches/gz-working/lib/sequences.lisp =================================================================== --- /branches/gz-working/lib/sequences.lisp (revision 8506) +++ /branches/gz-working/lib/sequences.lisp (revision 8507) @@ -291,7 +291,11 @@ ((or (atom current) (= index end)) sequence) (rplaca (the cons current) item)) - (do ((index start (1+ index))) - ((= index end) sequence) - (aset sequence index item)))) + (if (and (typep sequence 'ivector) + (eql start 0) + (eql end (uvsize sequence))) + (%init-misc item sequence) + (do ((index start (1+ index))) + ((= index end) sequence) + (aset sequence index item))))) ;;; Replace: Index: /branches/gz-working/lib/systems.lisp =================================================================== --- /branches/gz-working/lib/systems.lisp (revision 8506) +++ /branches/gz-working/lib/systems.lisp (revision 8507) @@ -195,5 +195,5 @@ (linux-files "ccl:l1f;linux-files" ("ccl:level-1;linux-files.lisp")) (source-files "ccl:bin;source-files" ("ccl:lib;source-files.lisp")) - + (cover "ccl:bin;cover" ("ccl:library;cover.lisp")) (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp")) (defsystem "ccl:tools;defsystem" ("ccl:tools;defsystem.lisp")) Index: /branches/gz-working/lisp-kernel/image.c =================================================================== --- /branches/gz-working/lisp-kernel/image.c (revision 8506) +++ /branches/gz-working/lisp-kernel/image.c (revision 8507) @@ -471,4 +471,5 @@ case GC_NUM: case STATIC_CONSES: + case WEAK_GC_METHOD: break; default: Index: /branches/gz-working/lisp-kernel/ppc-exceptions.c =================================================================== --- /branches/gz-working/lisp-kernel/ppc-exceptions.c (revision 8506) +++ /branches/gz-working/lisp-kernel/ppc-exceptions.c (revision 8507) @@ -442,4 +442,5 @@ /* nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */ gc_from_xp(xp, 0L); + release_readonly_area(); } if (selector & GC_TRAP_FUNCTION_PURIFY) { @@ -905,4 +906,11 @@ handler = protection_handlers[area->why]; return handler(xp, area, addr); + } else { + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return 0; + } } } Index: /branches/gz-working/lisp-kernel/ppc-gc.c =================================================================== --- /branches/gz-working/lisp-kernel/ppc-gc.c (revision 8506) +++ /branches/gz-working/lisp-kernel/ppc-gc.c (revision 8507) @@ -1729,157 +1729,134 @@ /* - This assumes that it's getting called with a simple-{base,general}-string - or code vector as an argument and that there's room for the object in the + This assumes that it's getting called with an ivector + argument and that there's room for the object in the destination area. */ +LispObj +purify_displaced_object(LispObj obj, area *dest, natural disp) +{ + BytePtr + free = dest->active, + *old = (BytePtr *) ptr_from_lispobj(untag(obj)); + LispObj + header = header_of(obj), + new; + natural + start = (natural)old, + physbytes; + + physbytes = ((natural)(skip_over_ivector(start,header))) - start; + dest->active += physbytes; + + new = ptr_to_lispobj(free)+disp; + + memcpy(free, (BytePtr)old, physbytes); + /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ + /* Actually, it's best to always leave a trail, for two reasons. + a) We may be walking the same heap that we're leaving forwaring + pointers in, so we don't want garbage that we leave behind to + look like a header. + b) We'd like to be able to forward code-vector locatives, and + it's easiest to do so if we leave a {forward_marker, dnode_locative} + pair at every doubleword in the old vector. + */ + while(physbytes) { + *old++ = (BytePtr) forward_marker; + *old++ = (BytePtr) free; + free += dnode_size; + physbytes -= dnode_size; + } + return new; +} + +LispObj +purify_object(LispObj obj, area *dest) +{ + return purify_displaced_object(obj, dest, fulltag_of(obj)); +} + + + +void +copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest) +{ + LispObj obj = *ref, header; + natural tag = fulltag_of(obj), header_tag, header_subtag; + + if ((tag == fulltag_misc) && + (((BytePtr)ptr_from_lispobj(obj)) > low) && + (((BytePtr)ptr_from_lispobj(obj)) < high)) { + header = deref(obj, 0); + if (header == forward_marker) { /* already copied */ + *ref = (untag(deref(obj,1)) + tag); + } else { + header_tag = fulltag_of(header); + if (immheader_tag_p(header_tag)) { + *ref = purify_object(obj, dest); + } + } + } +} + +void +purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to) +{ +#ifdef PPC LispObj - purify_displaced_object(LispObj obj, area *dest, natural disp) - { - BytePtr - free = dest->active, - *old = (BytePtr *) ptr_from_lispobj(untag(obj)); - LispObj - header = header_of(obj), - new; - natural - subtag = header_subtag(header), - element_count = header_element_count(header), - physbytes; - - switch(subtag) { - case subtag_simple_base_string: - physbytes = node_size + (element_count << 2); - break; - - case subtag_code_vector: - physbytes = node_size + (element_count << 2); - break; - - default: - Bug(NULL, "Can't purify object at 0x%08x", obj); - return obj; - } - physbytes = (physbytes+(dnode_size-1))&~(dnode_size-1); - dest->active += physbytes; - - new = ptr_to_lispobj(free)+disp; - - memcpy(free, (BytePtr)old, physbytes); - /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ - /* Actually, it's best to always leave a trail, for two reasons. - a) We may be walking the same heap that we're leaving forwaring - pointers in, so we don't want garbage that we leave behind to - look like a header. - b) We'd like to be able to forward code-vector locatives, and - it's easiest to do so if we leave a {forward_marker, dnode_locative} - pair at every doubleword in the old vector. - */ - while(physbytes) { - *old++ = (BytePtr) forward_marker; - *old++ = (BytePtr) free; - free += dnode_size; - physbytes -= dnode_size; - } - return new; - } - - LispObj - purify_object(LispObj obj, area *dest) - { - return purify_displaced_object(obj, dest, fulltag_of(obj)); - } - - -#define FORWARD_ONLY 0 -#define COPY_CODE (1<<0) -#define COPY_STRINGS (1<<1) - - void - copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what_to_copy) - { - LispObj obj = *ref, header; - natural tag = fulltag_of(obj), header_tag, header_subtag; - - if ((tag == fulltag_misc) && - (((BytePtr)ptr_from_lispobj(obj)) > low) && - (((BytePtr)ptr_from_lispobj(obj)) < high)) { - header = deref(obj, 0); - if (header == forward_marker) { /* already copied */ - *ref = (untag(deref(obj,1)) + tag); + loc = *locaddr, + *headerP; + opcode + *p, + insn; + natural + tag = fulltag_of(loc); + + if (((BytePtr)ptr_from_lispobj(loc) > low) && + ((BytePtr)ptr_from_lispobj(loc) < high)) { + + headerP = (LispObj *)ptr_from_lispobj(untag(loc)); + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: +#ifdef PPC64 + case fulltag_cons: + case fulltag_misc: +#endif + if (*headerP == forward_marker) { + *locaddr = (headerP[1]+tag); } else { - header_tag = fulltag_of(header); - if (immheader_tag_p(header_tag)) { - header_subtag = header_subtag(header); - if (((header_subtag == subtag_code_vector) && (what_to_copy & COPY_CODE)) || - ((what_to_copy & COPY_STRINGS) && - ((header_subtag == subtag_simple_base_string)))) { - *ref = purify_object(obj, dest); - } - } - } - } - } - - void - purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to, int what) - { -#ifdef PPC - LispObj - loc = *locaddr, - *headerP; - opcode - *p, - insn; - natural - tag = fulltag_of(loc); - - if (((BytePtr)ptr_from_lispobj(loc) > low) && - - ((BytePtr)ptr_from_lispobj(loc) < high)) { - - headerP = (LispObj *)ptr_from_lispobj(untag(loc)); - switch (tag) { - case fulltag_even_fixnum: - case fulltag_odd_fixnum: + /* Grovel backwards until the header's found; copy + the code vector to to space, then treat it as if it + hasn't already been copied. */ + p = (opcode *)headerP; + do { + p -= 2; + tag += 8; + insn = *p; #ifdef PPC64 - case fulltag_cons: - case fulltag_misc: -#endif - if (*headerP == forward_marker) { - *locaddr = (headerP[1]+tag); - } else { - /* Grovel backwards until the header's found; copy - the code vector to to space, then treat it as if it - hasn't already been copied. */ - p = (opcode *)headerP; - do { - p -= 2; - tag += 8; - insn = *p; -#ifdef PPC64 - } while (insn != PPC64_CODE_VECTOR_PREFIX); - headerP = ((LispObj*)p)-1; - *locaddr = purify_displaced_object(((LispObj)headerP), to, tag); + } while (insn != PPC64_CODE_VECTOR_PREFIX); + headerP = ((LispObj*)p)-1; + *locaddr = purify_displaced_object(((LispObj)headerP), to, tag); #else - } while ((insn & code_header_mask) != subtag_code_vector); - *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag); -#endif - } - break; + } while ((insn & code_header_mask) != subtag_code_vector); + *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag); +#endif + } + break; #ifndef PPC64 - case fulltag_misc: - copy_ivector_reference(locaddr, low, high, to, what); - break; -#endif - } - } -#endif -} - -void -purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) + case fulltag_misc: + copy_ivector_reference(locaddr, low, high, to); + break; +#endif + } +} +#endif +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) { LispObj header; @@ -1896,8 +1873,8 @@ } else { if (!nodeheader_tag_p(tag)) { - copy_ivector_reference(start, low, high, to, what); + copy_ivector_reference(start, low, high, to); } start++; - copy_ivector_reference(start, low, high, to, what); + copy_ivector_reference(start, low, high, to); start++; } @@ -1908,5 +1885,5 @@ /* Purify references from tstack areas */ void -purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to) { LispObj @@ -1923,5 +1900,5 @@ end = ((next >= start) && (next < limit)) ? next : limit; if (current[1] == 0) { - purify_range(current+2, end, low, high, to, what); + purify_range(current+2, end, low, high, to); } } @@ -1930,5 +1907,5 @@ /* Purify a vstack area */ void -purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to) { LispObj @@ -1937,13 +1914,13 @@ if (((natural)p) & sizeof(natural)) { - copy_ivector_reference(p, low, high, to, what); + copy_ivector_reference(p, low, high, to); p++; } - purify_range(p, q, low, high, to, what); -} - -#ifdef PPC -void -purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) + purify_range(p, q, low, high, to); +} + + +void +purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to) { BytePtr @@ -1958,5 +1935,5 @@ (((((lisp_frame *)current)->savefn) == 0) || (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { - purify_locref(&((lisp_frame *) current)->savelr, low, high, to, what); + purify_locref(&((lisp_frame *) current)->savelr, low, high, to); } else { /* Clear low bits of "next", just in case */ @@ -1965,12 +1942,10 @@ } } -#endif - -void -purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what) + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to) { unsigned long *regs = (unsigned long *) xpGPRvector(xp); -#ifdef PPC int r; @@ -1980,27 +1955,25 @@ for (r = fn; r < 32; r++) { - copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to, what); + copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to); }; - purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to, what); - - purify_locref((LispObj*) (&(xpPC(xp))), low, high, to, what); - purify_locref((LispObj*) (&(xpLR(xp))), low, high, to, what); - purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to, what); -#endif - -} - -void -purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) + purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to); + + purify_locref((LispObj*) (&(xpPC(xp))), low, high, to); + purify_locref((LispObj*) (&(xpLR(xp))), low, high, to); + purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to); +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to) { natural n = tcr->tlb_limit; LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); - purify_range(start, end, low, high, to, what); -} - -void -purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) + purify_range(start, end, low, high, to); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to) { xframe_list *xframes; @@ -2009,15 +1982,27 @@ xp = tcr->gc_context; if (xp) { - purify_xp(xp, low, high, to, what); + purify_xp(xp, low, high, to); } for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { - purify_xp(xframes->curr, low, high, to, what); - } -} - - -void -purify_areas(BytePtr low, BytePtr high, area *target, int what) + purify_xp(xframes->curr, low, high, to); + } +} + +void +purify_gcable_ptrs(BytePtr low, BytePtr high, area *to) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + copy_ivector_reference(prev, low, high, to); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target) { area *next_area; @@ -2027,20 +2012,18 @@ switch (code) { case AREA_TSTACK: - purify_tstack_area(next_area, low, high, target, what); + purify_tstack_area(next_area, low, high, target); break; case AREA_VSTACK: - purify_vstack_area(next_area, low, high, target, what); + purify_vstack_area(next_area, low, high, target); break; case AREA_CSTACK: -#ifdef PPC - purify_cstack_area(next_area, low, high, target, what); -#endif + purify_cstack_area(next_area, low, high, target); break; case AREA_STATIC: case AREA_DYNAMIC: - purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what); + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target); break; @@ -2080,60 +2063,15 @@ lisp_global(IN_GC) = (1<vcell, htab, obj; - package *p; - cons *c; - natural elements, i; - - while (fulltag_of(pkg_list) == fulltag_cons) { - c = (cons *) ptr_from_lispobj(untag(pkg_list)); - p = (package *) ptr_from_lispobj(untag(c->car)); - pkg_list = c->cdr; - c = (cons *) ptr_from_lispobj(untag(p->itab)); - htab = c->car; - elements = header_element_count(header_of(htab)); - for (i = 1; i<= elements; i++) { - obj = deref(htab,i); - if (fulltag_of(obj) == fulltag_misc) { - rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); - copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); - } - } - c = (cons *) ptr_from_lispobj(untag(p->etab)); - htab = c->car; - elements = header_element_count(header_of(htab)); - for (i = 1; i<= elements; i++) { - obj = deref(htab,i); - if (fulltag_of(obj) == fulltag_misc) { - rawsym = (lispsymbol *) ptr_from_lispobj(untag(obj)); - copy_ivector_reference(&(rawsym->pname), a->low, a->active, new_pure_area, COPY_STRINGS); - } - } - } - } - purify_areas(a->low, a->active, new_pure_area, COPY_CODE); + purify_areas(a->low, a->active, new_pure_area); other_tcr = tcr; do { - purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area, COPY_CODE); - purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area, COPY_CODE); + purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area); + purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area); other_tcr = other_tcr->next; } while (other_tcr != tcr); + purify_gcable_ptrs(a->low, a->active, new_pure_area); { @@ -2353,8 +2291,20 @@ } +void +impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + impurify_noderef(prev, low, high, delta); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + int impurify(TCR *tcr, signed_natural param) { - area *r = find_readonly_area(); + area *r = readonly_area; if (r) { @@ -2388,4 +2338,6 @@ other_tcr = other_tcr->next; } while (other_tcr != tcr); + + impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); lisp_global(IN_GC) = 0; } Index: /branches/gz-working/lisp-kernel/win32-ldt.c =================================================================== --- /branches/gz-working/lisp-kernel/win32-ldt.c (revision 8507) +++ /branches/gz-working/lisp-kernel/win32-ldt.c (revision 8507) @@ -0,0 +1,121 @@ +/* + Copyright (C) 2008 Clozure Associates + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* experimental code to get and set LDT entries on Win32. */ + +#include +#include +#include + +int (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*); +int (*NtSetLdtEntries)(DWORD, DWORD, DWORD, DWORD, DWORD, DWORD); +int (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD); +HMODULE hNtdll; + +int GetLDTSelectorEntry1(HANDLE hProcess, + DWORD dwSelector, + LPLDT_ENTRY lpSelectorEntry) +{ + DWORD buf[4]; + DWORD len; + int res; + + buf[0] = dwSelector & 0xFFFFFFF8; // selector --> offset + buf[1] = 8; // size (multiple selectors may be added) + res = NtQueryInformationProcess(hProcess,10,buf,16,&len); + memcpy(lpSelectorEntry, &buf[2], 8); + return res; +} + +int GetLDTSelectorEntry2(HANDLE hProcess, + DWORD dwSelector, + LPLDT_ENTRY lpSelectorEntry) +{ + return GetThreadSelectorEntry(hProcess, dwSelector, lpSelectorEntry); +} + +int SetLDTSelectorEntry1(HANDLE hProcess, + DWORD dwSelector, + LPLDT_ENTRY lpSelectorEntry) +{ + DWORD buf[4]; + DWORD len; + int res; + + buf[0] = dwSelector & 0xFFFFFFF8; // selector --> offset + buf[1] = 8; // size (multiple selectors may be added) + memcpy(&buf[2], lpSelectorEntry, 8); + res = NtSetInformationProcess(hProcess,10,buf,16); + return res; +} + +int SetLDTSelectorEntry2(DWORD dwSelector, + LPLDT_ENTRY lpSelectorEntry) +{ + return NtSetLdtEntries(dwSelector, + *(DWORD*)lpSelectorEntry, + *(((DWORD*)lpSelectorEntry)+1), + 0,0,0); +} + +DWORD GetLdtBase (LDT_ENTRY ldtEntry) { + return ldtEntry.BaseLow + + (ldtEntry.HighWord.Bytes.BaseMid << 16) + + (ldtEntry.HighWord.Bytes.BaseHi << 24); +} + +void SetLdtBase (LDT_ENTRY *ldtEntry, DWORD base) { + ldtEntry->BaseLow = base & 0xffff; + ldtEntry->HighWord.Bytes.BaseMid = base >> 16; + ldtEntry->HighWord.Bytes.BaseHi = base >> 24; +} + +extern int get_gs(void); +extern void set_gs(int); + +char some_buffer[1024]; + +int main (int argc, char** argv) { + HANDLE hProcess = GetCurrentProcess(); + LDT_ENTRY ldt_entry; + int res; + + hNtdll = LoadLibrary("ntdll.dll"); + + (void*)NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess"); + (void*)NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess"); + (void*)NtSetLdtEntries = (void*)GetProcAddress(hNtdll, "NtSetLdtEntries"); + + + if (!GetLDTSelectorEntry2(hProcess, get_gs(), &ldt_entry)) { + printf("Error getting LDT entry for 0x%x: 0x%x\n", get_gs(), GetLastError()); + exit(1); + } + + printf("0x%x is based at 0x%x\n", get_gs(), GetLdtBase(ldt_entry)); + + + /* + memset(&ldt_entry, 0, sizeof(LDT_ENTRY)); + SetLdtBase(&ldt_entry, &some_buffer); + if (res = SetLDTSelectorEntry2(0x100, &ldt_entry)) { + printf("Error setting LDT entry for 0x%x: 0x%x\n", 0x100, res); + exit(1); + } + set_gs(0x100); + */ + return 0; +}