Changeset 36627 in project
- Timestamp:
- 09/16/18 16:35:16 (2 years ago)
- 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 4 4 ;;;; Kon Lovett, Aug '10 5 5 6 (declare7 (bound-to-procedure8 ##sys#peek-unsigned-integer9 ##sys#check-closure))10 11 6 (module coops-extras 12 7 13 8 (;export 14 9 slot@ 15 make-copy 16 describe-object describe-object-slot 17 ; 18 print-closure) 10 make-copy) 19 11 20 12 (import scheme 21 13 (chicken base) 22 (chicken fixnum)23 14 (chicken type) 24 (only (chicken format) format)25 15 (only (srfi 1) cons* remove) 26 (only (srfi 13) string-pad) 27 coops-introspection 16 (only coops-introspection check-instance) 28 17 coops) 29 30 ;;;31 32 (define (symbol-printname-length s)33 (string-length (symbol->string s)) )34 18 35 19 ;;; … … 37 21 (define-type coops-class *) 38 22 (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) ) 41 32 42 33 ;;; Helpers 43 34 44 (define-constant MAXIMUM-SLOTNAME-LENGTH 32) 35 ;; 45 36 46 (: closure-C-address (procedure --> number)) 37 ;memq is not specific enough 38 (: plist-key? (symbol plist --> boolean)) 47 39 ; 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)) ) ) ) ) 50 48 51 (: check-closure (symbol * --> procedure))49 (: plist-cons (symbol * plist --> plist)) 52 50 ; 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 ;; 56 54 57 55 ;memq is not specific enough 58 56 (: initslot? (symbol list --> boolean)) 59 57 ; 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)) 68 59 69 60 (: slot-values (coops-instance (list-of symbol) #!optional list --> list)) … … 73 64 (lambda (ls slot) 74 65 (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) 76 67 ls ) ) 77 68 base 78 69 slots) ) 79 80 (: *class-slots (coops-class --> list))81 ;82 (define (*class-slots class)83 (slot-value class 'slots) )84 70 85 71 (: shadowed-initforms (coops-instance list #!optional coops-class --> list)) … … 117 103 (apply make class (shadowed-initforms obj initforms class)) ) ) 118 104 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 interface128 (format out "coops instance of class `#t': ~S~%" obj)129 ;else an instance130 (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 slot162 #!optional163 (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 187 105 ) ;coops-extras -
release/5/coops-utils/trunk/coops-utils.egg
r35947 r36627 18 18 (types-file) 19 19 (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") ) 20 24 (extension coops-extras 21 25 #;(inline-file) … … 25 29 #;(inline-file) 26 30 (types-file) 27 (component-dependencies coops- introspection coops-extras)31 (component-dependencies coops-describe coops-introspection coops-extras) 28 32 (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") ) ) ) -
release/5/coops-utils/trunk/coops-utils.scm
r35790 r36627 7 7 8 8 (import scheme (chicken module)) 9 (import coops-introspection coops-extras )9 (import coops-introspection coops-extras coops-describe) 10 10 11 (reexport coops-introspection coops-extras )11 (reexport coops-introspection coops-extras coops-describe) 12 12 13 13 ) ;coops-utils
Note: See TracChangeset
for help on using the changeset viewer.