Changeset 36627 in project


Ignore:
Timestamp:
09/16/18 16:35:16 (2 months ago)
Author:
kon
Message:

move describe stuff to own module

Location:
release/5/coops-utils/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/coops-utils/trunk/coops-extras.scm

    r36240 r36627  
    44;;;; Kon Lovett, Aug '10
    55
    6 (declare
    7   (bound-to-procedure
    8     ##sys#peek-unsigned-integer
    9     ##sys#check-closure))
    10 
    116(module coops-extras
    127
    138(;export
    149  slot@
    15   make-copy
    16   describe-object describe-object-slot
    17   ;
    18   print-closure)
     10  make-copy)
    1911
    2012(import scheme
    2113  (chicken base)
    22   (chicken fixnum)
    2314  (chicken type)
    24   (only (chicken format) format)
    2515  (only (srfi 1) cons* remove)
    26   (only (srfi 13)  string-pad)
    27   coops-introspection
     16  (only coops-introspection check-instance)
    2817  coops)
    29 
    30 ;;;
    31 
    32 (define (symbol-printname-length s)
    33   (string-length (symbol->string s)) )
    3418
    3519;;;
     
    3721(define-type coops-class *)
    3822(define-type coops-instance *)
    39 (define-type coops-generic *)
    40 (define-type coops-method *)
     23
     24(define-type plist list)
     25
     26;;;coops-introspection
     27
     28(: *class-slots (coops-class --> list))
     29;
     30(define (*class-slots class)
     31  (slot-value class 'slots) )
    4132
    4233;;; Helpers
    4334
    44 (define-constant MAXIMUM-SLOTNAME-LENGTH 32)
     35;;
    4536
    46 (: closure-C-address (procedure --> number))
     37;memq is not specific enough
     38(: plist-key? (symbol plist --> boolean))
    4739;
    48 (define (closure-C-address proc)
    49   (##sys#peek-unsigned-integer proc 0) )
     40(define (plist-key? key ls)
     41  ;search plist for key name
     42  (let loop ((ls ls))
     43    (and
     44      (not (null? ls))
     45      (or
     46        (eq? key (car ls))
     47        (loop (cddr ls)) ) ) ) )
    5048
    51 (: check-closure (symbol * --> procedure))
     49(: plist-cons (symbol * plist --> plist))
    5250;
    53 (define (check-closure loc obj)
    54   (##sys#check-closure obj loc)
    55   obj )
     51(define (plist-cons key val ls) (cons* key val ls))
     52
     53;;
    5654
    5755;memq is not specific enough
    5856(: initslot? (symbol list --> boolean))
    5957;
    60 (define (initslot? slot initforms)
    61   ;search plist for slot name
    62   (let loop ((initforms initforms))
    63     (and
    64       (not (null? initforms))
    65       (or
    66         (eq? slot (car initforms))
    67         (loop (cddr initforms)) ) ) ) )
     58(define (initslot? slot initforms) (plist-key? slot initforms))
    6859
    6960(: slot-values (coops-instance (list-of symbol) #!optional list --> list))
     
    7364    (lambda (ls slot)
    7465      (if (slot-initialized? x slot)  ;per Jun 19, '17 email from Sandra Snan
    75         (cons* slot (slot-value x slot) ls)
     66        (plist-cons slot (slot-value x slot) ls)
    7667        ls ) )
    7768    base
    7869    slots) )
    79 
    80 (: *class-slots (coops-class --> list))
    81 ;
    82 (define (*class-slots class)
    83   (slot-value class 'slots) )
    8470
    8571(: shadowed-initforms (coops-instance list #!optional coops-class --> list))
     
    117103    (apply make class (shadowed-initforms obj initforms class)) ) )
    118104
    119 ;;
    120 
    121 (define-generic (describe-object obj))
    122 
    123 (define-method (describe-object (obj #t)
    124                   #!optional (out (current-output-port)))
    125   (let ((class (class-of obj)))
    126     (if (eq? class #t)
    127       ;then obj used thru a coops interface
    128       (format out "coops instance of class `#t': ~S~%" obj)
    129       ;else an instance
    130       (let* (
    131         (slots (*class-slots class))
    132         (name-maxlen (apply max (map symbol-printname-length slots))) )
    133         ;
    134         (define (slot-per-line slot)
    135           (describe-object-slot obj slot name-maxlen out)
    136           (newline out) )
    137         ;
    138         (format out "coops instance of class `~A':~%" (class-name class))
    139         (for-each (cut slot-per-line <>) slots) ) ) ) )
    140 
    141 (define-method (describe-object (prim <primitive-object>)
    142                   #!optional (out (current-output-port)))
    143   (format out "coops instance of primitive class `~A': ~S~%"
    144     (class-name (class-of prim)) prim) )
    145 
    146 (define-method (describe-object (proc <procedure>)
    147                   #!optional (out (current-output-port)))
    148   (format out "~A~%"
    149     (if (generic-procedure? proc)
    150       "coops instance of `<generic-procedure>'"
    151       "coops instance of primitive class `<procedure>'")) )
    152 
    153 (define-method (describe-object (class <standard-class>)
    154                   #!optional (out (current-output-port)))
    155   (format out "coops standard-class `~A'~%" (class-name class)) )
    156 
    157 ;;
    158 
    159 (: describe-object-slot (* symbol #!optional fixnum (or boolean output-port) -> *))
    160 ;
    161 (define (describe-object-slot obj slot
    162           #!optional
    163           (name-maxlen MAXIMUM-SLOTNAME-LENGTH)
    164           (out (current-output-port)))
    165   (let* (
    166     (intd? (slot-initialized? obj slot))
    167     (nam (string-pad (symbol->string slot) name-maxlen))
    168     (fmt (if intd? "~S" "#<uninitialized>"))
    169     (args (if intd? `(,(slot-value obj slot)) '())) )
    170     (format out "~A: ~?" nam fmt args) ) )
    171 
    172 ;;
    173 
    174 ;(call-with-output-string (lambda (port) (print-closure proc port)))
    175 
    176 (: print-closure (procedure #!optional (or boolean output-port) -> *))
    177 ;
    178 (define (print-closure proc #!optional (out (current-output-port)))
    179   (let ((idx 0))
    180     (format out "~A: #x~X~%"
    181       idx (closure-C-address (check-closure 'print-closure proc)))
    182     (let ((size (##sys#size proc)))
    183       (do ((i (fx+ idx 1) (fx+ i 1)))
    184           ((fx= i size))
    185         (format out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )
    186 
    187105) ;coops-extras
  • release/5/coops-utils/trunk/coops-utils.egg

    r35947 r36627  
    1818    (types-file)
    1919    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-inline-limit" "240") )
     20  (extension coops-describe
     21    #;(inline-file)
     22    (types-file)
     23    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-inline-limit" "240") )
    2024  (extension coops-extras
    2125    #;(inline-file)
     
    2529    #;(inline-file)
    2630    (types-file)
    27     (component-dependencies coops-introspection coops-extras)
     31    (component-dependencies coops-describe coops-introspection coops-extras)
    2832    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") ) ) )
  • release/5/coops-utils/trunk/coops-utils.scm

    r35790 r36627  
    77
    88(import scheme (chicken module))
    9 (import coops-introspection coops-extras)
     9(import coops-introspection coops-extras coops-describe)
    1010
    11 (reexport coops-introspection coops-extras)
     11(reexport coops-introspection coops-extras coops-describe)
    1212
    1313) ;coops-utils
Note: See TracChangeset for help on using the changeset viewer.