Changeset 36627 in project

Timestamp:

09/16/18 16:35:16 (5 months ago)

Author:

kon

Message:

move describe stuff to own module

Location:

release/5/coops-utils/trunk

Files:

• coops-describe.scm (added)
• coops-extras.scm (modified) (4 diffs)
• coops-utils.egg (modified) (2 diffs)
• coops-utils.scm (modified) (1 diff)

release/5/coops-utils/trunk/coops-extras.scm

@@ -4 +4 @@
 ;;;; Kon Lovett, Aug '10
 
-(declare
-  (bound-to-procedure
-    ##sys#peek-unsigned-integer
-    ##sys#check-closure))
-
 (module coops-extras
 
 (;export
   slot@
-  make-copy
-  describe-object describe-object-slot
-  ;
-  print-closure)
+  make-copy)
 
 (import scheme
   (chicken base)
-  (chicken fixnum)
   (chicken type)
-  (only (chicken format) format)
   (only (srfi 1) cons* remove)
-  (only (srfi 13)  string-pad)
-  coops-introspection
+  (only coops-introspection check-instance)
   coops)
-
-;;;
-
-(define (symbol-printname-length s)
-  (string-length (symbol->string s)) )
 
 ;;;
@@ -37 +21 @@
 (define-type coops-class *)
 (define-type coops-instance *)
-(define-type coops-generic *)
-(define-type coops-method *)
+
+(define-type plist list)
+
+;;;coops-introspection
+
+(: *class-slots (coops-class --> list))
+;
+(define (*class-slots class)
+  (slot-value class 'slots) )
 
 ;;; Helpers
 
-(define-constant MAXIMUM-SLOTNAME-LENGTH 32)
+;;
 
-(: closure-C-address (procedure --> number))
+;memq is not specific enough
+(: plist-key? (symbol plist --> boolean))
 ;
-(define (closure-C-address proc)
-  (##sys#peek-unsigned-integer proc 0) )
+(define (plist-key? key ls)
+  ;search plist for key name
+  (let loop ((ls ls))
+    (and
+      (not (null? ls))
+      (or
+        (eq? key (car ls))
+        (loop (cddr ls)) ) ) ) )
 
-(: check-closure (symbol * --> procedure))
+(: plist-cons (symbol * plist --> plist))
 ;
-(define (check-closure loc obj)
-  (##sys#check-closure obj loc)
-  obj )
+(define (plist-cons key val ls) (cons* key val ls))
+
+;;
 
 ;memq is not specific enough
 (: initslot? (symbol list --> boolean))
 ;
-(define (initslot? slot initforms)
-  ;search plist for slot name
-  (let loop ((initforms initforms))
-    (and
-      (not (null? initforms))
-      (or
-        (eq? slot (car initforms))
-        (loop (cddr initforms)) ) ) ) )
+(define (initslot? slot initforms) (plist-key? slot initforms))
 
 (: slot-values (coops-instance (list-of symbol) #!optional list --> list))
@@ -73 +64 @@
     (lambda (ls slot)
       (if (slot-initialized? x slot)  ;per Jun 19, '17 email from Sandra Snan
-        (cons* slot (slot-value x slot) ls)
+        (plist-cons slot (slot-value x slot) ls)
         ls ) )
     base
     slots) )
-
-(: *class-slots (coops-class --> list))
-;
-(define (*class-slots class)
-  (slot-value class 'slots) )
 
 (: shadowed-initforms (coops-instance list #!optional coops-class --> list))
@@ -117 +103 @@
     (apply make class (shadowed-initforms obj initforms class)) ) )
 
-;;
-
-(define-generic (describe-object obj))
-
-(define-method (describe-object (obj #t)
-                  #!optional (out (current-output-port)))
-  (let ((class (class-of obj)))
-    (if (eq? class #t)
-      ;then obj used thru a coops interface
-      (format out "coops instance of class `#t': ~S~%" obj)
-      ;else an instance
-      (let* (
-        (slots (*class-slots class))
-        (name-maxlen (apply max (map symbol-printname-length slots))) )
-        ;
-        (define (slot-per-line slot)
-          (describe-object-slot obj slot name-maxlen out)
-          (newline out) )
-        ;
-        (format out "coops instance of class `~A':~%" (class-name class))
-        (for-each (cut slot-per-line <>) slots) ) ) ) )
-
-(define-method (describe-object (prim <primitive-object>)
-                  #!optional (out (current-output-port)))
-  (format out "coops instance of primitive class `~A': ~S~%"
-    (class-name (class-of prim)) prim) )
-
-(define-method (describe-object (proc <procedure>)
-                  #!optional (out (current-output-port)))
-  (format out "~A~%"
-    (if (generic-procedure? proc)
-      "coops instance of `<generic-procedure>'"
-      "coops instance of primitive class `<procedure>'")) )
-
-(define-method (describe-object (class <standard-class>)
-                  #!optional (out (current-output-port)))
-  (format out "coops standard-class `~A'~%" (class-name class)) )
-
-;;
-
-(: describe-object-slot (* symbol #!optional fixnum (or boolean output-port) -> *))
-;
-(define (describe-object-slot obj slot
-          #!optional
-          (name-maxlen MAXIMUM-SLOTNAME-LENGTH)
-          (out (current-output-port)))
-  (let* (
-    (intd? (slot-initialized? obj slot))
-    (nam (string-pad (symbol->string slot) name-maxlen))
-    (fmt (if intd? "~S" "#<uninitialized>"))
-    (args (if intd? `(,(slot-value obj slot)) '())) )
-    (format out "~A: ~?" nam fmt args) ) )
-
-;;
-
-;(call-with-output-string (lambda (port) (print-closure proc port)))
-
-(: print-closure (procedure #!optional (or boolean output-port) -> *))
-;
-(define (print-closure proc #!optional (out (current-output-port)))
-  (let ((idx 0))
-    (format out "~A: #x~X~%"
-      idx (closure-C-address (check-closure 'print-closure proc)))
-    (let ((size (##sys#size proc)))
-      (do ((i (fx+ idx 1) (fx+ i 1)))
-          ((fx= i size))
-        (format out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )
-
 ) ;coops-extras

release/5/coops-utils/trunk/coops-utils.egg

@@ -18 +18 @@
     (types-file)
     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-inline-limit" "240") )
+  (extension coops-describe
+    #;(inline-file)
+    (types-file)
+    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-inline-limit" "240") )
   (extension coops-extras
     #;(inline-file)
@@ -25 +29 @@
     #;(inline-file)
     (types-file)
-    (component-dependencies coops-introspection coops-extras)
+    (component-dependencies coops-describe coops-introspection coops-extras)
     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") ) ) )

release/5/coops-utils/trunk/coops-utils.scm

@@ -7 +7 @@
 
 (import scheme (chicken module))
-(import coops-introspection coops-extras)
+(import coops-introspection coops-extras coops-describe)
 
-(reexport coops-introspection coops-extras)
+(reexport coops-introspection coops-extras coops-describe)
 
 ) ;coops-utils