Changeset 34404 in project


Ignore:
Timestamp:
08/27/17 04:31:25 (3 months ago)
Author:
kon
Message:

re-flow, better formatting

Location:
release/4/coops-utils/trunk
Files:
3 edited

Legend:

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

    r34227 r34404  
    6565(define-syntax slot@
    6666  (syntax-rules (=)
     67    ;
    6768    ((_ ?obj)
    6869      ?obj )
    69     ((_ ?obj ?slot = ?v)
    70       (set! (slot-value ?obj '?slot) ?v) )
     70    ;
     71    ((_ ?obj ?slot = ?val)
     72      (set! (slot-value ?obj '?slot) ?val) )
     73    ;
     74    ((_ ?obj ?slot ?slots ...)
     75      (slot@ (slot-value ?obj '?slot) ?slots ...) )
     76    #; ;matter of style
    7177    ((_ ?obj ?slot . ?slots)
    72       (slot@ (slot-value ?obj '?slot) . ?slots)) ) )
     78      (slot@ (slot-value ?obj '?slot) . ?slots) ) ) )
    7379
    7480;;
    7581
    7682;use w/ <primitive-object> is very suspect
    77 (define (make/copy x . initforms)
    78   (check-instance 'make/copy x)
    79   (let ((class (class-of x)))
    80     (apply make class (shadowed-initforms x initforms class)) ) )
     83(define (make/copy obj . initforms)
     84  (check-instance 'make/copy obj)
     85  (let ((class (class-of obj)))
     86    (apply make class (shadowed-initforms obj initforms class)) ) )
    8187
    8288;;
     
    8591
    8692(define-method (describe-object (obj #t) #!optional (out (current-output-port)))
     93  ;
     94  (define (format-slot out obj slot #!optional (maxlen 32))
     95    (let* ((intd? (slot-initialized? obj slot) )
     96           (nam (string-pad (symbol->string slot) maxlen) )
     97           (fmt (if intd? "~S" "#<uninitialized>") )
     98           (args (if intd? `(,(slot-value obj slot)) '()) ) )
     99      (format out "~A: ~?~%" nam fmt args) ) )
     100  ;
    87101  (let ((class (class-of obj)))
    88102    (cond
     
    95109        (let* ((slots (*class-slots class))
    96110               (maxlen (apply max (map (o string-length symbol->string) slots))) )
    97           (for-each
    98             (lambda (slot)
    99               (let ((intd? (slot-initialized? obj slot)))
    100                 (format out "~A: ~?~%"
    101                   (string-pad (symbol->string slot) maxlen)
    102                   (if intd? "~S" "#<uninitialized>")
    103                   (if intd? `(,(slot-value obj slot)) '())) ) )
    104             slots) ) ) ) ) )
     111          (for-each (cut format-slot out obj <> maxlen) slots) ) ) ) ) )
    105112
    106113(define-method (describe-object (prim <primitive-object>)
    107                                 #!optional (out (current-output-port)))
     114                  #!optional (out (current-output-port)))
    108115  (format out
    109116    "coops instance of primitive class `~A': ~S~%"
     
    111118
    112119(define-method (describe-object (proc <procedure>)
    113                                 #!optional (out (current-output-port)))
    114   (if (generic? proc)
     120                  #!optional (out (current-output-port)))
     121  (if (generic-procedure? proc)
    115122    (format out "coops instance of `<generic-procedure>'~%")
    116123    (format out "coops instance of primitive class `<procedure>'~%") ) )
    117124
    118125(define-method (describe-object (class <standard-class>)
    119                                 #!optional (out (current-output-port)))
     126                  #!optional (out (current-output-port)))
    120127  (format out "coops standard-class `~A'~%" (class-name class)) )
    121128
    122129;;
    123130
    124 (define (print-closure p #!optional (out (current-output-port)))
    125   (##sys#check-closure p 'print-closure)
    126   (format out "0: #x~X~%" (##sys#peek-unsigned-integer p 0))
    127   (let ((size (##sys#size p)))
     131(define (print-closure proc #!optional (out (current-output-port)))
     132  (##sys#check-closure proc 'print-closure)
     133  (format out "0: #x~X~%" (closure-C-address proc))
     134  (let ((size (##sys#size proc)))
    128135    (do ((i 1 (add1 i)))
    129136        ((= i size))
    130       (format out "~A: ~S~%" i (##sys#slot p i)) ) ) )
     137      (format out "~A: ~S~%" i (##sys#slot proc i)) ) ) )
     138
     139(define (closure-C-address proc)
     140  (##sys#peek-unsigned-integer proc 0) )
    131141
    132142) ;coops-extras
  • release/4/coops-utils/trunk/coops-introspection.scm

    r34227 r34404  
    55;; Issues
    66;;
     7;; - should use more "schemey" names for operations?
     8;;
    79;; - all slot options are "lost" after definition.
    810;;
    911;; - generic-procedure introspection is dicey since the generic
    1012;; has no "entity" representation & methods are not 1st-class.
     13;;
     14;; - should use more "schemey" names for operations?
    1115
    1216(module coops-introspection
     
    143147    (pair? obj)
    144148    (procedure? (*method-procedure obj))
    145     (let ((specializers (*method-specializers obj)))
    146       (and
    147         (list? specializers)
    148         (every class? specializers) ) ) ) )
     149    (and-let*
     150        ((specializers (*method-specializers obj)) ((list? specializers)))
     151      (every class? specializers) ) ) )
    149152
    150153;;; Errors & Checks
     154
     155(define generic? generic-procedure?)
    151156
    152157(define-check+error-type class class? "coops-class")
    153158(define-check+error-type instance instance? "coops-instance")
    154 (define-check+error-type generic generic-procedure? "coops-generic")
     159(define-check+error-type generic generic? "coops-generic")
    155160(define-check+error-type method method? "coops-method")
    156161
     
    181186(define (generic-anonymous? generic)
    182187  (and
    183     (generic-procedure? generic)
     188    (generic? generic)
    184189    (not (##sys#slot generic 1)) ) )
    185190
     
    205210
    206211(define (method-specializers method)
    207   (check-method 'method-specializers method)
    208   (*method-specializers method) )
     212  (*method-specializers (check-method 'method-specializers method)) )
    209213
    210214(define (method-procedure method)
    211   (check-method 'method-procedure method)
    212   (*method-procedure method) )
     215  (*method-procedure (check-method 'method-procedure method)) )
    213216
    214217;;; Synonyms
     
    219222(define primitive? primitive-instance?)
    220223
    221 (define generic? generic-procedure?)
    222 
    223224(define generic-methods generic-primary-methods)
    224225
  • release/4/coops-utils/trunk/coops-utils.scm

    r34193 r34404  
    11;;;; coops-utils.scm   -*- Hen -*-
     2;;;; Kon Lovett, Jun '17
    23;;;; Kon Lovett, Dec '12
    34
    45(module coops-utils ()
    56
    6 (import scheme chicken)
     7(import scheme)
     8
     9(import chicken)
     10
    711(reexport coops-introspection coops-extras)
    812(require-library coops-introspection coops-extras)
Note: See TracChangeset for help on using the changeset viewer.