Changeset 35765 in project


Ignore:
Timestamp:
07/05/18 10:35:06 (5 months ago)
Author:
kon
Message:

finally - pick a name, idiom

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

Legend:

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

    r35753 r35765  
    22;;;; Kon Lovett, Aug '10
    33;;;; Kon Lovett, Jun '17
    4 
    5 ;; Issues
    6 ;;
    7 
    8 (module coops-extras
    9 
    10 (;export
    11   slot@
    12   make-with-copy
    13   describe-object describe-object-slot
    14   ;
    15   print-closure
    16   ;DEPRECATED
    17   make/copy)
    18 
    19 (import scheme chicken)
    20 
    21 (use
    22   (only data-structures o)
    23   (only extras format)
    24   (only srfi-1 cons* remove)
    25   (only srfi-13 string-pad)
    26   coops-introspection coops)
    274
    285(declare
     
    318    ##sys#check-closure ) )
    329
     10(module coops-extras
     11
     12(;export
     13  slot@
     14  make-copy
     15  describe-object describe-object-slot
     16  ;
     17  print-closure
     18  ;DEPRECATED
     19  make/copy
     20  make-with-copy)
     21
     22(import scheme chicken)
     23(use
     24  (only extras format)
     25  (only srfi-1 cons* remove)
     26  (only srfi-13 string-pad)
     27  coops-introspection coops)
     28
    3329;;;
    3430
    35 (define symbol-printname-length (o string-length symbol->string))
     31(define (symbol-printname-length s)
     32  (string-length (symbol->string s)) )
    3633
    3734;;;
     
    4441;;; Helpers
    4542
    46 ;
    47 (define-constant *MAXIMUM-SLOTNAME-LENGTH* 32)
     43(define-constant MAXIMUM-SLOTNAME-LENGTH 32)
    4844
    49 ;
    5045(: closure-C-address (procedure --> number))
    5146;
     
    5954  obj )
    6055
     56;memq is not specific enough
    6157(: initslot? (symbol list --> boolean))
    6258;
    63 ;memq is not specific enough
    6459(define (initslot? slot initforms)
    6560  ;search plist for slot name
     
    115110
    116111;use w/ <primitive-object> is very suspect
    117 (: make-with-copy (coops-instance #!rest --> *))
     112(: make-copy (coops-instance #!rest --> *))
    118113;
    119 (define (make-with-copy obj . initforms)
    120   (let ((class (class-of (check-instance 'make-with-copy obj))))
     114(define (make-copy obj . initforms)
     115  (let ((class (class-of (check-instance 'make-copy obj))))
    121116    (apply make class (shadowed-initforms obj initforms class)) ) )
    122117
     
    165160(define (describe-object-slot obj slot
    166161          #!optional
    167           (name-maxlen *MAXIMUM-SLOTNAME-LENGTH*)
     162          (name-maxlen MAXIMUM-SLOTNAME-LENGTH)
    168163          (out (current-output-port)))
    169164  (let* (
    170     (intd? (slot-initialized? obj slot) )
    171     (nam (string-pad (symbol->string slot) name-maxlen) )
    172     (fmt (if intd? "~S" "#<uninitialized>") )
    173     (args (if intd? `(,(slot-value obj slot)) '()) ) )
    174     ;
     165    (intd? (slot-initialized? obj slot))
     166    (nam (string-pad (symbol->string slot) name-maxlen))
     167    (fmt (if intd? "~S" "#<uninitialized>"))
     168    (args (if intd? `(,(slot-value obj slot)) '())) )
    175169    (format out "~A: ~?" nam fmt args) ) )
    176170
     
    184178  (let ((idx 0))
    185179    (format out "~A: #x~X~%"
    186       idx
    187       (closure-C-address (check-closure 'print-closure proc)))
     180      idx (closure-C-address (check-closure 'print-closure proc)))
    188181    (let ((size (##sys#size proc)))
    189       (do ((i (add1 idx) (add1 i)))
    190           ((= i size))
     182      (do ((i (fx+ idx 1) (fx+ i 1)))
     183          ((fx= i size))
    191184        (format out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )
    192185
    193186;;;DEPRECATED
    194187
    195 (define make/copy make-with-copy)
     188(: make-with-copy (deprecated make-copy))
     189(define make-with-copy make-copy)
     190
     191(: make/copy (deprecated make-copy))
     192(define make/copy make-copy)
    196193
    197194) ;coops-extras
  • release/4/coops-utils/trunk/coops-introspection.scm

    r35207 r35765  
    11;;;; coops-introspection.scm
     2;;;; Kon Lovett, Jul '17
    23;;;; Kon Lovett, Aug '10
    3 ;;;; Kon Lovett, Jul '17
    44
    55;; Issues
     
    187187    (procedure? (*method-procedure obj))
    188188    (and-let* (
    189       (specializers (*method-specializers obj) )
     189      (specializers (*method-specializers obj))
    190190      ((list? specializers)) )
    191191      (every class? specializers) ) ) )
  • release/4/coops-utils/trunk/coops-utils.scm

    r35207 r35765  
    77(import scheme chicken)
    88
     9(use coops-introspection coops-extras)
    910(reexport coops-introspection coops-extras)
    10 (require-library coops-introspection coops-extras)
    1111
    1212;DEPRECATED
     13(use coops-introspection-tinyclos)
    1314(reexport coops-introspection-tinyclos)
    14 (require-library coops-introspection-tinyclos)
    1515
    1616) ;coops-utils
  • release/4/coops-utils/trunk/tests/coops-utils-test.scm

    r35146 r35765  
    9797(test "still the end" (slot@ 1st next next next))
    9898
    99 ;make-with-copy
    100 (let ((inst (make-with-copy s1xy-inst 'y 23)))
    101   (test "make-with-copy" 23 (slot@ inst y)) )
     99;make-copy
     100(let ((inst (make-copy s1xy-inst 'y 23)))
     101  (test "make-copy" 23 (slot@ inst y)) )
    102102
    103103(let ()
    104104  (define-class city () (name (market-class reader: city-market-class) sellers buyers (goods accessor: city-goods)))
    105105  (define temphawa (make city 'name "Hawa" 'market-class 2))
    106   (test-assert "make-with-copy temphawa" (make-with-copy temphawa)) )
     106  (test-assert "make-copy temphawa" (make-copy temphawa)) )
    107107
    108108;primitive-instance?
Note: See TracChangeset for help on using the changeset viewer.