Changeset 35207 in project


Ignore:
Timestamp:
02/25/18 07:01:32 (4 months ago)
Author:
kon
Message:

add types , use foldl , re-flow , bump ver

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

Legend:

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

    r35146 r35207  
    22;;;; Kon Lovett, Aug '10
    33;;;; Kon Lovett, Jun '17
     4
     5;; Issues
     6;;
    47
    58(module coops-extras
     
    1922  (only data-structures o)
    2023  (only extras format)
    21   (only srfi-1 cons* fold remove)
     24  (only srfi-1 cons* remove)
    2225  (only srfi-13 string-pad)
    2326  coops-introspection coops)
     
    2831    ##sys#check-closure ) )
    2932
     33;;;
     34
     35(define-type coops-class *)
     36(define-type coops-instance *)
     37(define-type coops-generic *)
     38(define-type coops-method *)
     39
    3040;;; Helpers
    3141
    32 ;
    3342(define-constant *MAXIMUM-SLOTNAME-LENGTH* 32)
    3443
     44;
     45(: closure-C-address (procedure --> number))
    3546;
    3647(define (closure-C-address proc)
    3748  (##sys#peek-unsigned-integer proc 0) )
    3849
     50(: check-closure (symbol * --> *))
    3951;
    4052(define (check-closure loc obj)
     
    4254  obj )
    4355
     56(: initslot? (symbol list --> boolean))
     57;
    4458;memq is not specific enough
    4559(define (initslot? slot initforms)
     
    5266        (loop (cddr initforms)) ) ) ) )
    5367
     68(: slot-values (coops-instance (list-of symbol) #!optional list --> list))
     69;
    5470(define (slot-values x slots #!optional (base '()))
    55   (fold
    56     (lambda (slot ls)
     71  (foldl
     72    (lambda (ls slot)
    5773      (if (slot-initialized? x slot)  ;per Jun 19, '17 email from Sandra Snan
    5874        (cons* slot (slot-value x slot) ls)
     
    6177    slots) )
    6278
     79(: *class-slots (coops-class --> list))
     80;
    6381(define (*class-slots class)
    6482  (slot-value class 'slots) )
    6583
     84(: shadowed-initforms (coops-instance list #!optional coops-class --> list))
     85;
    6686(define (shadowed-initforms obj initforms #!optional (class (class-of obj)))
    6787  (slot-values
     
    90110
    91111;use w/ <primitive-object> is very suspect
     112(: make-with-copy (coops-instance #!rest --> *))
     113;
    92114(define (make-with-copy obj . initforms)
    93115  (let ((class (class-of (check-instance 'make-with-copy obj))))
     
    98120(define-generic (describe-object obj))
    99121
    100 (define-method (describe-object (obj #t) #!optional (out (current-output-port)))
     122(define-method (describe-object (obj #t)
     123                  #!optional (out (current-output-port)))
    101124  (let ((class (class-of obj)))
    102125    (if (eq? class #t)
     
    116139        (format out "coops instance of class `~A':~%" (class-name class))
    117140        (for-each (cut slot-per-line <>) slots) ) ) ) )
    118 
    119 ;
    120 (define (describe-object-slot obj slot
    121           #!optional
    122           (name-maxlen *MAXIMUM-SLOTNAME-LENGTH*)
    123           (out (current-output-port)))
    124   (let* (
    125     (intd? (slot-initialized? obj slot) )
    126     (nam (string-pad (symbol->string slot) name-maxlen) )
    127     (fmt (if intd? "~S" "#<uninitialized>") )
    128     (args (if intd? `(,(slot-value obj slot)) '()) ) )
    129     ;
    130     (format out "~A: ~?" nam fmt args) ) )
    131141
    132142(define-method (describe-object (prim <primitive-object>)
     
    148158;;
    149159
     160(: describe-object-slot (* symbol #!optional fixnum (or boolean output-port) -> *))
     161;
     162(define (describe-object-slot obj slot
     163          #!optional
     164          (name-maxlen *MAXIMUM-SLOTNAME-LENGTH*)
     165          (out (current-output-port)))
     166  (let* (
     167    (intd? (slot-initialized? obj slot) )
     168    (nam (string-pad (symbol->string slot) name-maxlen) )
     169    (fmt (if intd? "~S" "#<uninitialized>") )
     170    (args (if intd? `(,(slot-value obj slot)) '()) ) )
     171    ;
     172    (format out "~A: ~?" nam fmt args) ) )
     173
     174;;
     175
     176;(call-with-output-string (lambda (port) (print-closure proc port)))
     177
     178(: print-closure (procedure #!optional (or boolean output-port) -> *))
     179;
    150180(define (print-closure proc #!optional (out (current-output-port)))
    151181  (let ((idx 0))
  • release/4/coops-utils/trunk/coops-introspection-tinyclos.scm

    r34762 r35207  
    77  class-supers )
    88
    9 (import scheme)
     9(import scheme chicken)
    1010
    11 (import chicken)
    12 
    13 (import
     11(use
    1412  (only coops-introspection
    15     class-precedence-list primitive-instance? generic-primary-methods ) )
    16 (require-library coops-introspection)
     13    class-precedence-list primitive-instance? generic-primary-methods))
    1714
    1815(reexport
  • release/4/coops-utils/trunk/coops-introspection.scm

    r34763 r35207  
    3939  method-procedure )
    4040
    41 (import scheme)
    42 
    43 (import chicken)
    44 
    45 (import (only srfi-1 every fold-right lset-difference lset-union))
    46 (require-library srfi-1)
    47 
    48 (import (only type-checks define-check+error-type))
    49 (require-library type-checks)
    50 
    51 (require-extension coops)
     41(import scheme chicken)
     42
     43(use
     44  (only srfi-1 every lset-difference lset-union)
     45  (only type-checks define-check+error-type)
     46  coops)
     47
     48;;;
     49
     50(define-type coops-class *)
     51(define-type coops-instance *)
     52(define-type coops-generic *)
     53(define-type coops-method *)
    5254
    5355;;; Helpers
    5456
     57(: union-class-property-values (procedure (list-of coops-class) --> list))
     58;
    5559(define (union-class-property-values getter classes)
    56   (fold-right
    57     (lambda (class ls)
    58       (lset-union eq? ls (getter class)) )
     60  (foldr
     61    (lambda (class ls) (lset-union eq? ls (getter class)))
    5962    '()
    6063    classes) )
    6164
     65(: *class-slots (coops-class --> list))
     66;
    6267(define (*class-slots class)
    6368  (slot-value class 'slots) )
    6469
     70(: *class-supers (coops-class --> list))
     71;
    6572(define (*class-supers class)
    6673  (slot-value class 'class-precedence-list) )
    6774
     75(: union-class-slots ((list-of coops-class) --> list))
     76;
    6877(define (union-class-slots classes)
    6978  (union-class-property-values *class-slots classes) )
    7079
     80(: union-class-supers ((list-of coops-class) --> list))
     81;
    7182(define (union-class-supers classes)
    7283  (union-class-property-values *class-supers classes) )
    7384
     85(: class-supers-slots (coops-class --> list))
     86;
    7487(define (class-supers-slots class)
    7588  (union-class-slots (*class-supers class)) )
    7689
     90(: class-supers-supers (coops-class --> list))
     91;
    7792(define (class-supers-supers class)
    7893  (union-class-supers (*class-supers class)) )
    7994
     95(: strict-subclass? (coops-class coops-class --> boolean))
     96;
    8097;c1 < c2
    8198(define (strict-subclass? c1 c2)
    8299  (subclass? c1 c2) )
    83100
     101(: loose-subclass? (coops-class coops-class --> boolean))
     102;
    84103;c1 <= c2
    85104(define (loose-subclass? c1 c2)
     
    88107    (strict-subclass? c1 c2)) )
    89108
     109(: *method-specializers (pair --> *))
     110;
    90111(define *method-specializers car)
    91112
     113(: *method-procedure (pair --> *))
     114;
    92115(define *method-procedure cdr)
    93116
     117(: error-generic-form (symbol * fixnum -> void))
     118;
    94119(define (error-generic-form loc obj idx)
    95120  (error loc "generic closure form violation" obj idx) )
    96121
     122(: check-generic-form (symbol * fixnum procedure --> *))
     123;
    97124(define (check-generic-form loc obj0 idx type-pred?)
    98125  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
     
    101128    obj ) )
    102129
     130(: check-generic-methods (symbol * fixnum --> *))
     131;
    103132(define (check-generic-methods loc obj idx)
    104133  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
    105134
     135(: top-instance-of? (* coops-class --> *))
     136;
    106137(define (top-instance-of? x class)
    107138  (let ((class-x (class-of x)))
     
    112143;; call-by-ref
    113144
     145(: generic-name? (* --> *))
     146;
    114147(define (generic-name? obj)
    115148  (or
     
    117150    (symbol? obj)) )
    118151
     152(: vector-boxed-list? (* --> *))
     153;
    119154(define (vector-boxed-list? obj)
    120155  (and
    121156    (vector? obj)
    122     (= 1 (vector-length obj))
     157    (fx= 1 (vector-length obj))
    123158    (list? (vector-ref obj 0))) )
    124159
    125160;;; Predicates
    126161
     162(: instance-of? (* coops-class --> boolean))
     163;
    127164(define (instance-of? x class)
    128165  (loose-subclass? (class-of x) class) )
    129166
     167(: class? (* -> boolean : coops-class))
     168;
    130169(define (class? x)
    131170  (instance-of? x <standard-class>) )
    132171
     172(: instance? (* -> boolean : coops-instance))
     173;
    133174(define (instance? x)
    134175  (not (top-instance-of? x <standard-class>)) )
    135176
     177(: primitive-instance? (* -> boolean : coops-instance))
     178;
    136179(define (primitive-instance? x)
    137180  (top-instance-of? x <primitive-object>) )
    138181
     182(: method? (* -> boolean : coops-method))
     183;
    139184(define (method? obj)
    140185  (and
     
    143188    (and-let* (
    144189      (specializers (*method-specializers obj) )
    145       ((list? specializers) ) )
    146       ;
     190      ((list? specializers)) )
    147191      (every class? specializers) ) ) )
    148192
     
    160204;; Class Properties
    161205
     206(: class-precedence-list (coops-class --> list))
     207;
    162208(define (class-precedence-list class)
    163209  (*class-supers (check-class 'class-precedence-list class)) )
    164210
     211(: class-slots (coops-class --> list))
     212;
    165213(define (class-slots class)
    166214  (*class-slots (check-class 'class-slots class)) )
     
    169217
    170218;those supers declared in the direct class & not inherited
     219(: class-direct-supers (coops-class --> list))
     220;
    171221(define (class-direct-supers class)
    172222  (check-class 'class-direct-supers class)
     
    174224
    175225;those slots declared in the direct class & not inherited
     226(: class-direct-slots (coops-class --> list))
     227;
    176228(define (class-direct-slots class)
    177229  (check-class 'class-direct-slots class)
     
    180232;; Generic Properties
    181233
     234(: generic-anonymous? (* -> boolean : coops-generic))
     235;
    182236(define (generic-anonymous? generic)
    183237  (and
     
    185239    (not (##sys#slot generic 1)) ) )
    186240
     241(: generic-name (coops-generic --> symbol))
     242;
    187243(define (generic-name generic)
    188244  (check-generic-form 'generic-name generic 1 generic-name?) )
    189245
     246(: generic-specialized-arguments (coops-generic --> list))
     247;
    190248(define (generic-specialized-arguments generic)
    191249  (check-generic-form 'generic-specialized-args generic 7 pair?) )
    192250
     251(: generic-primary-methods (coops-generic --> list))
     252;
    193253(define (generic-primary-methods generic)
    194254  (check-generic-methods 'generic-primary-methods generic 2) )
    195255
     256(: generic-before-methods (coops-generic --> list))
     257;
    196258(define (generic-before-methods generic)
    197259  (check-generic-methods 'generic-before-methods generic 3) )
    198260
     261(: generic-after-methods (coops-generic --> list))
     262;
    199263(define (generic-after-methods generic)
    200264  (check-generic-methods 'generic-after-methods generic 4) )
    201265
     266(: generic-around-methods (coops-generic --> list))
     267;
    202268(define (generic-around-methods generic)
    203269  (check-generic-methods 'generic-around-methods generic 5) )
     
    205271;; Method Properties
    206272
     273(: method-specializers (coops-method --> list))
     274;
    207275(define (method-specializers method)
    208276  (*method-specializers (check-method 'method-specializers method)) )
    209277
     278(: method-procedure (coops-method --> list))
     279;
    210280(define (method-procedure method)
    211281  (*method-procedure (check-method 'method-procedure method)) )
  • release/4/coops-utils/trunk/coops-utils.scm

    r34762 r35207  
    55(module coops-utils ()
    66
    7 (import scheme)
    8 
    9 (import chicken)
     7(import scheme chicken)
    108
    119(reexport coops-introspection coops-extras)
  • release/4/coops-utils/trunk/coops-utils.setup

    r35146 r35207  
    1313  -no-procedure-checks) )
    1414
    15 ;; Module
    16 
    17 (setup-shared-extension-module 'coops-introspection (extension-version "1.2.0")
     15#;
     16(setup-shared-extension-module 'closure-introspection (extension-version "1.1.0")
    1817  #:types? #t
    1918  #:inline? #t
    2019  #:compile-options `(,@*EGG-CSC-OPTIONS* -inline-limit 240) )
    2120
    22 (setup-shared-extension-module 'coops-extras (extension-version "1.2.0")
     21;; Module
     22
     23(setup-shared-extension-module 'coops-introspection (extension-version "1.1.0")
     24  #:types? #t
     25  #:inline? #t
     26  #:compile-options `(,@*EGG-CSC-OPTIONS* -inline-limit 240) )
     27
     28(setup-shared-extension-module 'coops-extras (extension-version "1.1.0")
    2329  #:types? #t
    2430  #:inline? #t
    2531  #:compile-options *EGG-CSC-OPTIONS* )
    2632
    27 (setup-shared-extension-module 'coops-introspection-tinyclos (extension-version "1.2.0")
     33(setup-shared-extension-module 'coops-introspection-tinyclos (extension-version "1.1.0")
    2834  #:types? #t
    2935  #:inline? #t
     
    3238;; Egg Module
    3339
    34 (setup-shared-extension-module *EGG-NAME* (extension-version "1.2.0")
     40(setup-shared-extension-module *EGG-NAME* (extension-version "1.1.0")
    3541  #:types? #t
    3642  #:inline? #t
Note: See TracChangeset for help on using the changeset viewer.