Changeset 38897 in project


Ignore:
Timestamp:
08/29/20 02:13:57 (4 weeks ago)
Author:
Kon Lovett
Message:

fix types & predicates

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

Legend:

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

    r38762 r38897  
    4343;;;
    4444
    45 (define-type coops-class *)
    46 (define-type coops-instance *)
    47 (define-type coops-generic *)
    48 (define-type coops-method *)
     45;;
     46
     47(define-type coops-instance (struct coops-instance))
     48
     49(define-type coops-class coops-instance) ;(or true coops-instance)
     50
     51(define-type coops-generic procedure)
     52
     53;class list-of methods elm
     54(define-type coops-method (pair coops-instance procedure))
     55
     56;;
     57
     58(: union-class-property-values (procedure (list-of coops-class) --> list))
     59(: *class-slots (coops-class --> list))
     60(: *class-supers (coops-class --> list))
     61(: union-class-slots ((list-of coops-class) --> list))
     62(: union-class-supers ((list-of coops-class) --> list))
     63(: class-supers-slots (coops-class --> list))
     64(: class-supers-supers (coops-class --> list))
     65(: *method-specializers (pair --> *))
     66(: *method-procedure (pair --> *))
     67(: error-generic-form (symbol * fixnum --> void))
     68(: check-generic-form (symbol * fixnum procedure --> *))
     69(: checked-generic-methods (symbol * fixnum --> *))
     70(: coops-instance? (* --> boolean))
     71(: parent-instance? (* coops-class --> boolean))
     72(: generic-name? (* --> boolean))
     73(: vector-boxed-list? (* --> boolean))
     74
     75;;
     76
     77(: instance-of? (* coops-class --> boolean))
     78(: class? (* -> boolean : coops-class))
     79(: instance? (* -> boolean : coops-instance))
     80(: primitive-instance? (* --> boolean))
     81(: method? (* --> boolean))
     82(: class-precedence-list (coops-class --> list))
     83(: class-slots (coops-class --> list))
     84(: class-direct-supers (coops-class --> list))
     85(: class-direct-slots (coops-class --> list))
     86(: generic-anonymous? (* -> boolean : coops-generic))
     87(: generic-name (coops-generic -> symbol))
     88(: generic-specialized-arguments (coops-generic --> list))
     89(: generic-primary-methods (coops-generic --> list))
     90(: generic-before-methods (coops-generic --> list))
     91(: generic-after-methods (coops-generic --> list))
     92(: generic-around-methods (coops-generic --> list))
     93(: method-specializers (coops-method --> list))
     94(: method-procedure (coops-method --> procedure))
    4995
    5096;;; Helpers
    5197
    52 (define +class-primitive+ #t)
    53 
    54 (: union-class-property-values (procedure (list-of coops-class) --> list))
    55 ;
     98; Class << ROOT-CLASS
     99(define-constant ROOT-CLASS #t)
     100
    56101(define (union-class-property-values getter classes)
    57102  (foldr
     
    60105    classes) )
    61106
    62 (: *class-slots (coops-class --> list))
    63 ;
    64107(define (*class-slots class)
    65108  (slot-value class 'slots) )
    66109
    67 (: *class-supers (coops-class --> list))
    68 ;
    69110(define (*class-supers class)
    70111  (slot-value class 'class-precedence-list) )
    71112
    72 (: union-class-slots ((list-of coops-class) --> list))
    73 ;
    74113(define (union-class-slots classes)
    75114  (union-class-property-values *class-slots classes) )
    76115
    77 (: union-class-supers ((list-of coops-class) --> list))
    78 ;
    79116(define (union-class-supers classes)
    80117  (union-class-property-values *class-supers classes) )
    81118
    82 (: class-supers-slots (coops-class --> list))
    83 ;
    84119(define (class-supers-slots class)
    85120  (union-class-slots (*class-supers class)) )
    86121
    87 (: class-supers-supers (coops-class --> list))
    88 ;
    89122(define (class-supers-supers class)
    90123  (union-class-supers (*class-supers class)) )
    91124
    92 (: class< (coops-class coops-class --> boolean))
    93 ;
    94 ;c1 < c2
    95 (define (class< c1 c2)
    96   (subclass? c1 c2) )
    97 
    98 (: class<= (coops-class coops-class --> boolean))
    99 ;
    100 (define (class<= c1 c2)
    101   (or
    102     (eq? c1 c2)
    103     (class< c1 c2)) )
    104 
    105 (: *method-specializers (pair --> *))
    106 ;
    107125(define *method-specializers car)
    108 
    109 (: *method-procedure (pair --> *))
    110 ;
    111126(define *method-procedure cdr)
    112127
    113 (: error-generic-form (symbol * fixnum --> void))
    114 ;
    115128(define (error-generic-form loc obj idx)
    116129  (error loc "generic closure form violation" obj idx) )
    117130
    118 (: check-generic-form (symbol * fixnum procedure --> *))
    119 ;
    120131(define (check-generic-form loc obj0 idx type-pred?)
    121132  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
     
    124135    obj ) )
    125136
    126 (: checked-generic-methods (symbol * fixnum --> *))
    127 ;
    128137(define (checked-generic-methods loc obj idx)
    129138  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
    130139
    131 (: top-instance-of? (* coops-class --> boolean))
    132 ;
    133 (define (top-instance-of? x class)
     140(define (coops-instance? x)
     141  (import (chicken memory representation))
     142  (record-instance? x coops-instance) )
     143
     144; class << class(x)
     145(define (parent-instance? x class)
    134146  (let ((class-x (class-of x)))
    135     (or
    136       (eq? +class-primitive+ class-x)
    137       (class<= class class-x) ) ) )
     147    (and
     148      (not (eq? class-x class))
     149      (subclass? class class-x)) ) )
    138150
    139151;; call-by-ref
    140152
    141 (: generic-name? (* --> boolean))
    142 ;
    143153(define (generic-name? obj)
    144154  (or
     
    146156    (symbol? obj)) )
    147157
    148 (: vector-boxed-list? (* --> boolean))
    149 ;
    150158(define (vector-boxed-list? obj)
    151159  (and
     
    156164;;; Predicates
    157165
    158 (: instance-of? (* coops-class --> boolean))
    159 ;
    160166(define (instance-of? x class)
    161   (class<= (class-of x) class) )
    162 
    163 (: class? (* -> boolean : coops-class))
    164 ;
     167  (subclass? (class-of x) class) )
     168
    165169(define (class? x)
    166170  (instance-of? x <standard-class>) )
    167171
    168 (: instance? (* -> boolean : coops-instance))
    169 ;
    170172(define (instance? x)
    171   (not (top-instance-of? x <standard-class>)) )
    172 
    173 (: primitive-instance? (* -> boolean : coops-instance))
    174 ;
     173  (and
     174    (coops-instance? x)
     175    (not (class? x))) )
     176
    175177(define (primitive-instance? x)
    176   (top-instance-of? x <primitive-object>) )
    177 
    178 (: method? (* -> boolean : coops-method))
    179 ;
     178  (let ((class-x (class-of x)))
     179    (or
     180      (eq? ROOT-CLASS class-x)
     181      (subclass? class-x <primitive-object>)) ) )
     182
     183(: method? (* --> boolean))
     184;FIXME for results of `generic-*-methods' ONLY!
    180185(define (method? obj)
    181186  (and
     
    200205;; Class Properties
    201206
    202 (: class-precedence-list (coops-class --> list))
    203 ;
    204207(define (class-precedence-list class)
    205208  (*class-supers (check-class 'class-precedence-list class)) )
    206209
    207 (: class-slots (coops-class --> list))
    208 ;
    209210(define (class-slots class)
    210211  (*class-slots (check-class 'class-slots class)) )
     
    213214
    214215;those supers declared in the direct class & not inherited
    215 (: class-direct-supers (coops-class --> list))
    216 ;
    217216(define (class-direct-supers class)
    218217  (check-class 'class-direct-supers class)
     
    220219
    221220;those slots declared in the direct class & not inherited
    222 (: class-direct-slots (coops-class --> list))
    223 ;
    224221(define (class-direct-slots class)
    225222  (check-class 'class-direct-slots class)
     
    228225;; Generic Properties
    229226
    230 (: generic-anonymous? (* -> boolean : coops-generic))
    231 ;
    232227(define (generic-anonymous? generic)
    233228  (and
     
    235230    (not (##sys#slot generic 1)) ) )
    236231
    237 (: generic-name (coops-generic -> symbol))
    238 ;
    239232(define (generic-name generic)
    240233  (check-generic-form 'generic-name generic 1 generic-name?) )
    241234
    242 (: generic-specialized-arguments (coops-generic --> list))
    243 ;
    244235(define (generic-specialized-arguments generic)
    245236  (check-generic-form 'generic-specialized-args generic 7 pair?) )
    246237
    247 (: generic-primary-methods (coops-generic --> list))
    248 ;
    249238(define (generic-primary-methods generic)
    250239  (checked-generic-methods 'generic-primary-methods generic 2) )
    251240
    252 (: generic-before-methods (coops-generic --> list))
    253 ;
    254241(define (generic-before-methods generic)
    255242  (checked-generic-methods 'generic-before-methods generic 3) )
    256243
    257 (: generic-after-methods (coops-generic --> list))
    258 ;
    259244(define (generic-after-methods generic)
    260245  (checked-generic-methods 'generic-after-methods generic 4) )
    261246
    262 (: generic-around-methods (coops-generic --> list))
    263 ;
    264247(define (generic-around-methods generic)
    265248  (checked-generic-methods 'generic-around-methods generic 5) )
     
    267250;; Method Properties
    268251
    269 (: method-specializers (coops-method --> list))
    270 ;
    271252(define (method-specializers method)
    272253  (let ((ms (*method-specializers (check-method 'method-specializers method))))
     
    275256    ms ) )
    276257
    277 (: method-procedure (coops-method --> procedure))
    278 ;
    279258(define (method-procedure method)
    280259  (let ((mp (*method-procedure (check-method 'method-procedure method))))
  • release/5/coops-utils/trunk/coops-utils.egg

    r38863 r38897  
    33
    44((synopsis "coops utilities")
    5  (version "2.1.4")
     5 (version "2.1.5")
    66 (category oop)
    77 (license "BSD")
     
    1111  srfi-13
    1212  check-errors
    13   (coops "1.2"))
     13  (coops "1.3"))
    1414 (test-dependencies test)
    1515 (components
  • release/5/coops-utils/trunk/tests/coops-utils-test.scm

    r38863 r38897  
    33
    44(import test)
     5
     6(import (only (chicken format) format))
     7(include-relative "test-gloss.incl")
    58
    69(import
     
    1922
    2023(test-assert (class? <standard-class>))
    21 
    22 (test-assert (class? <standard-object>))
     24(test-assert (not (instance? <standard-class>)))
     25(test-assert (not (primitive-instance? <standard-class>)))
     26(test-assert (not (method? <standard-class>)))
     27(test-assert (not (generic? <standard-class>)))
     28
     29(test-assert (not (class? 23)))
     30(test-assert (not (instance? 23)))
     31(test-assert (primitive-instance? 23))
     32(test-assert (not (method? 23)))
     33(test-assert (not (generic? 23)))
     34
     35(test-assert (not (class? +)))
     36(test-assert (not (instance? +)))
     37(test-assert (primitive-instance? +))
     38(test-assert (not (generic? +)))
     39(test-assert (not (method? +)))
    2340
    2441;; setup test reference environment
     
    181198
    182199(test-group "Coops Describe"
     200  (test-assert (generic? describe-object))
     201
     202  (glossln)
     203  (gloss "(describe-object <third>)")
    183204  (describe-object <third>)
    184   (newline)
     205
     206  (glossln)
     207  (gloss "(describe-object s1xy-inst)")
    185208  (describe-object s1xy-inst)
    186   (newline)
     209
     210  (glossln)
     211  (gloss "(describe-object describe-object)")
    187212  (describe-object describe-object)
    188   (newline)
     213
     214  (glossln)
     215  (gloss "(print-closure describe-object)")
    189216  (print-closure describe-object)
    190217)
Note: See TracChangeset for help on using the changeset viewer.