Changeset 38762 in project


Ignore:
Timestamp:
06/21/20 20:30:00 (3 weeks ago)
Author:
Kon Lovett
Message:

introspection procedures are pure, method-specializers must verify result like method-procedure

File:
1 edited

Legend:

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

    r38761 r38762  
    5252(define +class-primitive+ #t)
    5353
    54 (: union-class-property-values (procedure (list-of coops-class) -> list))
     54(: union-class-property-values (procedure (list-of coops-class) --> list))
    5555;
    5656(define (union-class-property-values getter classes)
     
    6060    classes) )
    6161
    62 (: *class-slots (coops-class -> list))
     62(: *class-slots (coops-class --> list))
    6363;
    6464(define (*class-slots class)
    6565  (slot-value class 'slots) )
    6666
    67 (: *class-supers (coops-class -> list))
     67(: *class-supers (coops-class --> list))
    6868;
    6969(define (*class-supers class)
    7070  (slot-value class 'class-precedence-list) )
    7171
    72 (: union-class-slots ((list-of coops-class) -> list))
     72(: union-class-slots ((list-of coops-class) --> list))
    7373;
    7474(define (union-class-slots classes)
    7575  (union-class-property-values *class-slots classes) )
    7676
    77 (: union-class-supers ((list-of coops-class) -> list))
     77(: union-class-supers ((list-of coops-class) --> list))
    7878;
    7979(define (union-class-supers classes)
    8080  (union-class-property-values *class-supers classes) )
    8181
    82 (: class-supers-slots (coops-class -> list))
     82(: class-supers-slots (coops-class --> list))
    8383;
    8484(define (class-supers-slots class)
    8585  (union-class-slots (*class-supers class)) )
    8686
    87 (: class-supers-supers (coops-class -> list))
     87(: class-supers-supers (coops-class --> list))
    8888;
    8989(define (class-supers-supers class)
    9090  (union-class-supers (*class-supers class)) )
    9191
    92 (: class< (coops-class coops-class -> boolean))
     92(: class< (coops-class coops-class --> boolean))
    9393;
    9494;c1 < c2
     
    9696  (subclass? c1 c2) )
    9797
    98 (: class<= (coops-class coops-class -> boolean))
     98(: class<= (coops-class coops-class --> boolean))
    9999;
    100100(define (class<= c1 c2)
     
    103103    (class< c1 c2)) )
    104104
    105 (: *method-specializers (pair -> *))
     105(: *method-specializers (pair --> *))
    106106;
    107107(define *method-specializers car)
    108108
    109 (: *method-procedure (pair -> *))
     109(: *method-procedure (pair --> *))
    110110;
    111111(define *method-procedure cdr)
    112112
    113 (: error-generic-form (symbol * fixnum -> void))
     113(: error-generic-form (symbol * fixnum --> void))
    114114;
    115115(define (error-generic-form loc obj idx)
    116116  (error loc "generic closure form violation" obj idx) )
    117117
    118 (: check-generic-form (symbol * fixnum procedure -> *))
     118(: check-generic-form (symbol * fixnum procedure --> *))
    119119;
    120120(define (check-generic-form loc obj0 idx type-pred?)
     
    124124    obj ) )
    125125
    126 (: checked-generic-methods (symbol * fixnum -> *))
     126(: checked-generic-methods (symbol * fixnum --> *))
    127127;
    128128(define (checked-generic-methods loc obj idx)
    129129  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
    130130
    131 (: top-instance-of? (* coops-class -> boolean))
     131(: top-instance-of? (* coops-class --> boolean))
    132132;
    133133(define (top-instance-of? x class)
     
    139139;; call-by-ref
    140140
    141 (: generic-name? (* -> boolean))
     141(: generic-name? (* --> boolean))
    142142;
    143143(define (generic-name? obj)
     
    146146    (symbol? obj)) )
    147147
    148 (: vector-boxed-list? (* -> boolean))
     148(: vector-boxed-list? (* --> boolean))
    149149;
    150150(define (vector-boxed-list? obj)
     
    156156;;; Predicates
    157157
    158 (: instance-of? (* coops-class -> boolean))
     158(: instance-of? (* coops-class --> boolean))
    159159;
    160160(define (instance-of? x class)
     
    200200;; Class Properties
    201201
    202 (: class-precedence-list (coops-class -> list))
     202(: class-precedence-list (coops-class --> list))
    203203;
    204204(define (class-precedence-list class)
    205205  (*class-supers (check-class 'class-precedence-list class)) )
    206206
    207 (: class-slots (coops-class -> list))
     207(: class-slots (coops-class --> list))
    208208;
    209209(define (class-slots class)
     
    213213
    214214;those supers declared in the direct class & not inherited
    215 (: class-direct-supers (coops-class -> list))
     215(: class-direct-supers (coops-class --> list))
    216216;
    217217(define (class-direct-supers class)
     
    220220
    221221;those slots declared in the direct class & not inherited
    222 (: class-direct-slots (coops-class -> list))
     222(: class-direct-slots (coops-class --> list))
    223223;
    224224(define (class-direct-slots class)
     
    240240  (check-generic-form 'generic-name generic 1 generic-name?) )
    241241
    242 (: generic-specialized-arguments (coops-generic -> list))
     242(: generic-specialized-arguments (coops-generic --> list))
    243243;
    244244(define (generic-specialized-arguments generic)
    245245  (check-generic-form 'generic-specialized-args generic 7 pair?) )
    246246
    247 (: generic-primary-methods (coops-generic -> list))
     247(: generic-primary-methods (coops-generic --> list))
    248248;
    249249(define (generic-primary-methods generic)
    250250  (checked-generic-methods 'generic-primary-methods generic 2) )
    251251
    252 (: generic-before-methods (coops-generic -> list))
     252(: generic-before-methods (coops-generic --> list))
    253253;
    254254(define (generic-before-methods generic)
    255255  (checked-generic-methods 'generic-before-methods generic 3) )
    256256
    257 (: generic-after-methods (coops-generic -> list))
     257(: generic-after-methods (coops-generic --> list))
    258258;
    259259(define (generic-after-methods generic)
    260260  (checked-generic-methods 'generic-after-methods generic 4) )
    261261
    262 (: generic-around-methods (coops-generic -> list))
     262(: generic-around-methods (coops-generic --> list))
    263263;
    264264(define (generic-around-methods generic)
     
    267267;; Method Properties
    268268
    269 (: method-specializers (coops-method -> list))
     269(: method-specializers (coops-method --> list))
    270270;
    271271(define (method-specializers method)
    272   (*method-specializers (check-method 'method-specializers method)) )
    273 
    274 (: method-procedure (coops-method -> *))
     272  (let ((ms (*method-specializers (check-method 'method-specializers method))))
     273    (unless (list? ms)
     274      (error 'method-specializers "not a list" ms) )
     275    ms ) )
     276
     277(: method-procedure (coops-method --> procedure))
    275278;
    276279(define (method-procedure method)
    277   (*method-procedure (check-method 'method-procedure method)) )
     280  (let ((mp (*method-procedure (check-method 'method-procedure method))))
     281    (unless (procedure? mp)
     282      (error 'method-procedure "not a procedure" mp) )
     283    mp ) )
    278284
    279285) ;coops-introspection
Note: See TracChangeset for help on using the changeset viewer.