Changeset 34227 in project


Ignore:
Timestamp:
07/06/17 00:22:14 (3 weeks ago)
Author:
kon
Message:

use format, more inline, common code

Location:
release/4/coops-utils
Files:
8 edited
1 copied

Legend:

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

    r34204 r34227  
    88  slot@
    99  make/copy
    10   describe-object)
     10  describe-object
     11  ;
     12  print-closure)
    1113
    1214(import scheme)
     
    1416(import chicken)
    1517
    16 (import (only extras fprintf))
     18(import (only data-structures o))
     19(require-library data-structures)
     20
     21(import (only extras format))
    1722(require-library extras)
    1823
    19 (import (only srfi-1 fold remove))
     24(import (only srfi-1 cons* fold remove))
    2025(require-library srfi-1)
    2126
     
    2732;;; Helpers
    2833
    29 ; memq is not specific enough
    30 (define-inline (initslot? slot initforms)
     34;memq is not specific enough
     35(define (initslot? slot initforms)
     36  ;search plist for slot name
    3137  (let loop ((initforms initforms))
    3238    (and
     
    3642        (loop (cddr initforms)) ) ) ) )
    3743
    38 (define-inline (slot-values x slots #!optional (base '()))
     44(define (slot-values x slots #!optional (base '()))
    3945  (fold
    4046    (lambda (slot ls)
    4147      ;per Jun 19, '17 email from Sandra Snan
    4248      (if (slot-initialized? x slot)
    43         (cons slot (cons (slot-value x slot) ls))
     49        (cons* slot (slot-value x slot) ls)
    4450        ls ) )
    4551    base
    4652    slots) )
    4753
    48 (define-inline (*class-slots class)
     54(define (*class-slots class)
    4955  (slot-value class 'slots) )
    5056
    51 (define-inline (shadowed-initforms x initforms #!optional (class (class-of x)))
     57(define (shadowed-initforms x initforms #!optional (class (class-of x)))
    5258  (slot-values x (remove (cut initslot? <> initforms) (*class-slots class)) initforms) )
    5359
     
    5662;;
    5763
    58 ; sub-instance slot reference
     64;sub-instance slot reference
    5965(define-syntax slot@
    6066  (syntax-rules (=)
    61     ((_ ?o)
    62       ?o )
    63     ((_ ?o ?slot = ?v)
    64       (set! (slot-value ?o '?slot) ?v) )
    65     ((_ ?o ?slot . ?slots)
    66       (slot@ (slot-value ?o '?slot) . ?slots)) ) )
     67    ((_ ?obj)
     68      ?obj )
     69    ((_ ?obj ?slot = ?v)
     70      (set! (slot-value ?obj '?slot) ?v) )
     71    ((_ ?obj ?slot . ?slots)
     72      (slot@ (slot-value ?obj '?slot) . ?slots)) ) )
    6773
    6874;;
    6975
    70 ; use w/ <primitive-object> is very suspect
     76;use w/ <primitive-object> is very suspect
    7177(define (make/copy x . initforms)
    7278  (check-instance 'make/copy x)
     
    8288    (cond
    8389      ((eq? class #t)
    84         ; specific in that obj used thru a coops interface
    85         ; but might be misleading - (display obj out) perhaps?
    86         (fprintf out "coops instance of class `#t': ~S~%" obj) )
     90        ;specific in that obj used thru a coops interface
     91        ;but might be misleading - (display obj out) perhaps?
     92        (format out "coops instance of class `#t': ~S~%" obj) )
    8793      (else
    88         (fprintf out "coops instance of class `~A':~%" (class-name class))
     94        (format out "coops instance of class `~A':~%" (class-name class))
    8995        (let* ((slots (*class-slots class))
    9096               (maxlen (apply max (map (o string-length symbol->string) slots))) )
    9197          (for-each
    9298            (lambda (slot)
    93               (display (string-pad (symbol->string slot) maxlen) out)
    94               (display " : " out)
    95               (if (slot-initialized? obj slot)
    96                 (write (slot-value obj slot) out)
    97                 (display "#<uninitialized>" out) )
    98               (newline out) )
     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)) '())) ) )
    99104            slots) ) ) ) ) )
    100105
    101 (define-method (describe-object (prim <primitive-object>) #!optional (out (current-output-port)))
    102   (fprintf out "coops instance of primitive class `~A': ~S~%" (class-name (class-of prim)) prim) )
     106(define-method (describe-object (prim <primitive-object>)
     107                                #!optional (out (current-output-port)))
     108  (format out
     109    "coops instance of primitive class `~A': ~S~%"
     110    (class-name (class-of prim)) prim) )
    103111
    104 (define-method (describe-object (proc <procedure>) #!optional (out (current-output-port)))
    105   (if (generic? proc) (fprintf out "coops instance of `<generic-procedure>'~%")
    106     (fprintf out "coops instance of primitive class `<procedure>'~%") ) )
     112(define-method (describe-object (proc <procedure>)
     113                                #!optional (out (current-output-port)))
     114  (if (generic? proc)
     115    (format out "coops instance of `<generic-procedure>'~%")
     116    (format out "coops instance of primitive class `<procedure>'~%") ) )
    107117
    108 (define-method (describe-object (class <standard-class>) #!optional (out (current-output-port)))
    109   (fprintf out "coops standard-class `~A'~%" (class-name class)) )
     118(define-method (describe-object (class <standard-class>)
     119                                #!optional (out (current-output-port)))
     120  (format out "coops standard-class `~A'~%" (class-name class)) )
     121
     122;;
     123
     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)))
     128    (do ((i 1 (add1 i)))
     129        ((= i size))
     130      (format out "~A: ~S~%" i (##sys#slot p i)) ) ) )
    110131
    111132) ;coops-extras
  • release/4/coops-utils/tags/1.0.4/coops-introspection.scm

    r34204 r34227  
    11;;;; coops-introspection.scm
     2;;;; Kon Lovett, Jul '17
    23;;;; Kon Lovett, Aug '10
    34
     
    1213
    1314(;export
    14   ;
     15  ;tiny-clos work-alike
    1516  class-cpl class-supers  ;= class-precedence-list
    1617  primitive?              ;= primitive-instance?
     
    5253;;; Helpers
    5354
    54 (define-inline (*class-slots class)
    55   (slot-value class 'slots) )
    56 
    57 (define-inline (*class-supers class)
    58   (slot-value class 'class-precedence-list) )
    59 
    60 (define-inline (union-class-slots classes)
     55(define (union-class-prop-vals getter classes)
    6156  (fold-right
    6257    (lambda (class ls)
    63       (lset-union eq? ls (*class-slots class)) )
     58      (lset-union eq? ls (getter class)) )
    6459    '()
    6560    classes) )
    6661
    67 (define-inline (union-class-supers classes)
    68   (fold-right
    69     (lambda (class ls)
    70       (lset-union eq? ls (*class-supers class)) )
    71     '()
    72     classes) )
    73 
    74 (define-inline (class-supers-slots class)
     62(define (*class-slots class)
     63  (slot-value class 'slots) )
     64
     65(define (*class-supers class)
     66  (slot-value class 'class-precedence-list) )
     67
     68(define (union-class-slots classes)
     69  (union-class-prop-vals *class-slots classes) )
     70
     71(define (union-class-supers classes)
     72  (union-class-prop-vals *class-supers classes) )
     73
     74(define (class-supers-slots class)
    7575  (union-class-slots (*class-supers class)) )
    7676
    77 (define-inline (class-supers-supers class)
     77(define (class-supers-supers class)
    7878  (union-class-supers (*class-supers class)) )
    7979
    80 ; c1 < c2
    81 (define-inline (strict-subclass? c1 c2)
     80;c1 < c2
     81(define (strict-subclass? c1 c2)
    8282  (subclass? c1 c2) )
    8383
    84 ; c1 <= c2
    85 (define-inline (loose-subclass? c1 c2)
     84;c1 <= c2
     85(define (loose-subclass? c1 c2)
    8686  (or
    8787    (eq? c1 c2)
    8888    (strict-subclass? c1 c2)) )
    8989
    90 (define-inline (*method-specializers method)
     90(define (*method-specializers method)
    9191  (car method) )
    9292
    93 (define-inline (*method-procedure method)
     93(define (*method-procedure method)
    9494  (cdr method) )
    9595
    96 (define-inline (error-generic-form loc obj idx)
     96(define (error-generic-form loc obj idx)
    9797  (error loc "generic closure form violation" obj idx) )
    9898
    99 (define-inline (check-generic-form loc obj0 idx type-pred?)
     99(define (check-generic-form loc obj0 idx type-pred?)
    100100  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
    101101    (unless (type-pred? obj)
     
    103103    obj ) )
    104104
    105 (define-inline (check-generic-methods loc obj idx)
     105(define (check-generic-methods loc obj idx)
    106106  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
    107107
    108 (define-inline (top-instance-of? x class)
     108(define (top-instance-of? x class)
    109109  (let ((class-x (class-of x)))
    110110    (or
    111       (eq? #t class-x) ; primitive
     111      (eq? #t class-x) ;primitive
    112112      (loose-subclass? class class-x) ) ) )
    113113
     
    167167;; Class Direct Properties
    168168
    169 ; those supers declared in the direct class & not inherited
     169;those supers declared in the direct class & not inherited
    170170(define (class-direct-supers class)
    171171  (check-class 'class-direct-supers class)
    172172  (lset-difference eq? (*class-supers class) (class-supers-supers class)))
    173173
    174 ; those slots declared in the direct class & not inherited
     174;those slots declared in the direct class & not inherited
    175175(define (class-direct-slots class)
    176176  (check-class 'class-direct-slots class)
     
    223223(define generic-methods generic-primary-methods)
    224224
    225 ;;
    226 
    227 #; ;Debugging Only
    228 (define (print-closure p)
    229   (##sys#check-closure p 'print-closure)
    230   (print "0\t: #x" (number->string (##sys#peek-unsigned-integer p 0) 16))
    231   (let ((size (##sys#size p)))
    232     (do ((i 1 (add1 i)))
    233         ((= i size))
    234       (print i "\t: " (##sys#slot p i)) ) ) )
    235 
    236225) ;coops-introspection
  • release/4/coops-utils/tags/1.0.4/coops-utils.setup

    r34204 r34227  
    55(verify-extension-name "coops-utils")
    66
    7 (setup-shared-extension-module 'coops-introspection (extension-version "1.0.3")
     7(setup-shared-extension-module 'coops-introspection (extension-version "1.0.4")
    88  #:types? #t
    99  #:inline? #t
    10   #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )
     10  #:compile-options '(
     11    -inline-limit 240
     12    -O3 -d2
     13    -local
     14    -fixnum-arithmetic
     15    -no-procedure-checks) )
    1116
    12 (setup-shared-extension-module 'coops-extras (extension-version "1.0.3")
     17(setup-shared-extension-module 'coops-extras (extension-version "1.0.4")
    1318  #:types? #t
    1419  #:inline? #t
    15   #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )
     20  #:compile-options '(
     21    -O3 -d2
     22    -local
     23    -fixnum-arithmetic
     24    -no-procedure-checks) )
    1625
    17 (setup-shared-extension-module 'coops-utils (extension-version "1.0.3")
     26(setup-shared-extension-module 'coops-utils (extension-version "1.0.4")
    1827  #:types? #t
    1928  #:inline? #t
    20   #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )
     29  #:compile-options '(
     30    -O3 -d2
     31    -local
     32    -fixnum-arithmetic
     33    -no-procedure-checks) )
  • release/4/coops-utils/tags/1.0.4/tests/run.scm

    r34195 r34227  
    6060
    6161(describe-object s1xy-inst)
     62
     63#| FIXME - y = 's1xy-y ?
     64(define s1xy-inst-x (make <s1xy> 'x 1))
     65(test-assert (instance? s1xy-inst-x))
     66(test-assert (instance-of? s1xy-inst-x <s1xy>))
     67(describe-object s1xy-inst-x)
     68;=>
     69;coops instance of class `<s1xy>':
     70;x: 1
     71;y: s1xy-y
     72|#
    6273
    6374(define-class <first> () (next))
  • release/4/coops-utils/trunk/coops-extras.scm

    r34204 r34227  
    88  slot@
    99  make/copy
    10   describe-object)
     10  describe-object
     11  ;
     12  print-closure)
    1113
    1214(import scheme)
     
    1416(import chicken)
    1517
    16 (import (only extras fprintf))
     18(import (only data-structures o))
     19(require-library data-structures)
     20
     21(import (only extras format))
    1722(require-library extras)
    1823
    19 (import (only srfi-1 fold remove))
     24(import (only srfi-1 cons* fold remove))
    2025(require-library srfi-1)
    2126
     
    2732;;; Helpers
    2833
    29 ; memq is not specific enough
    30 (define-inline (initslot? slot initforms)
     34;memq is not specific enough
     35(define (initslot? slot initforms)
     36  ;search plist for slot name
    3137  (let loop ((initforms initforms))
    3238    (and
     
    3642        (loop (cddr initforms)) ) ) ) )
    3743
    38 (define-inline (slot-values x slots #!optional (base '()))
     44(define (slot-values x slots #!optional (base '()))
    3945  (fold
    4046    (lambda (slot ls)
    4147      ;per Jun 19, '17 email from Sandra Snan
    4248      (if (slot-initialized? x slot)
    43         (cons slot (cons (slot-value x slot) ls))
     49        (cons* slot (slot-value x slot) ls)
    4450        ls ) )
    4551    base
    4652    slots) )
    4753
    48 (define-inline (*class-slots class)
     54(define (*class-slots class)
    4955  (slot-value class 'slots) )
    5056
    51 (define-inline (shadowed-initforms x initforms #!optional (class (class-of x)))
     57(define (shadowed-initforms x initforms #!optional (class (class-of x)))
    5258  (slot-values x (remove (cut initslot? <> initforms) (*class-slots class)) initforms) )
    5359
     
    5662;;
    5763
    58 ; sub-instance slot reference
     64;sub-instance slot reference
    5965(define-syntax slot@
    6066  (syntax-rules (=)
    61     ((_ ?o)
    62       ?o )
    63     ((_ ?o ?slot = ?v)
    64       (set! (slot-value ?o '?slot) ?v) )
    65     ((_ ?o ?slot . ?slots)
    66       (slot@ (slot-value ?o '?slot) . ?slots)) ) )
     67    ((_ ?obj)
     68      ?obj )
     69    ((_ ?obj ?slot = ?v)
     70      (set! (slot-value ?obj '?slot) ?v) )
     71    ((_ ?obj ?slot . ?slots)
     72      (slot@ (slot-value ?obj '?slot) . ?slots)) ) )
    6773
    6874;;
    6975
    70 ; use w/ <primitive-object> is very suspect
     76;use w/ <primitive-object> is very suspect
    7177(define (make/copy x . initforms)
    7278  (check-instance 'make/copy x)
     
    8288    (cond
    8389      ((eq? class #t)
    84         ; specific in that obj used thru a coops interface
    85         ; but might be misleading - (display obj out) perhaps?
    86         (fprintf out "coops instance of class `#t': ~S~%" obj) )
     90        ;specific in that obj used thru a coops interface
     91        ;but might be misleading - (display obj out) perhaps?
     92        (format out "coops instance of class `#t': ~S~%" obj) )
    8793      (else
    88         (fprintf out "coops instance of class `~A':~%" (class-name class))
     94        (format out "coops instance of class `~A':~%" (class-name class))
    8995        (let* ((slots (*class-slots class))
    9096               (maxlen (apply max (map (o string-length symbol->string) slots))) )
    9197          (for-each
    9298            (lambda (slot)
    93               (display (string-pad (symbol->string slot) maxlen) out)
    94               (display " : " out)
    95               (if (slot-initialized? obj slot)
    96                 (write (slot-value obj slot) out)
    97                 (display "#<uninitialized>" out) )
    98               (newline out) )
     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)) '())) ) )
    99104            slots) ) ) ) ) )
    100105
    101 (define-method (describe-object (prim <primitive-object>) #!optional (out (current-output-port)))
    102   (fprintf out "coops instance of primitive class `~A': ~S~%" (class-name (class-of prim)) prim) )
     106(define-method (describe-object (prim <primitive-object>)
     107                                #!optional (out (current-output-port)))
     108  (format out
     109    "coops instance of primitive class `~A': ~S~%"
     110    (class-name (class-of prim)) prim) )
    103111
    104 (define-method (describe-object (proc <procedure>) #!optional (out (current-output-port)))
    105   (if (generic? proc) (fprintf out "coops instance of `<generic-procedure>'~%")
    106     (fprintf out "coops instance of primitive class `<procedure>'~%") ) )
     112(define-method (describe-object (proc <procedure>)
     113                                #!optional (out (current-output-port)))
     114  (if (generic? proc)
     115    (format out "coops instance of `<generic-procedure>'~%")
     116    (format out "coops instance of primitive class `<procedure>'~%") ) )
    107117
    108 (define-method (describe-object (class <standard-class>) #!optional (out (current-output-port)))
    109   (fprintf out "coops standard-class `~A'~%" (class-name class)) )
     118(define-method (describe-object (class <standard-class>)
     119                                #!optional (out (current-output-port)))
     120  (format out "coops standard-class `~A'~%" (class-name class)) )
     121
     122;;
     123
     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)))
     128    (do ((i 1 (add1 i)))
     129        ((= i size))
     130      (format out "~A: ~S~%" i (##sys#slot p i)) ) ) )
    110131
    111132) ;coops-extras
  • release/4/coops-utils/trunk/coops-introspection.scm

    r34204 r34227  
    11;;;; coops-introspection.scm
     2;;;; Kon Lovett, Jul '17
    23;;;; Kon Lovett, Aug '10
    34
     
    1213
    1314(;export
    14   ;
     15  ;tiny-clos work-alike
    1516  class-cpl class-supers  ;= class-precedence-list
    1617  primitive?              ;= primitive-instance?
     
    5253;;; Helpers
    5354
    54 (define-inline (*class-slots class)
    55   (slot-value class 'slots) )
    56 
    57 (define-inline (*class-supers class)
    58   (slot-value class 'class-precedence-list) )
    59 
    60 (define-inline (union-class-slots classes)
     55(define (union-class-prop-vals getter classes)
    6156  (fold-right
    6257    (lambda (class ls)
    63       (lset-union eq? ls (*class-slots class)) )
     58      (lset-union eq? ls (getter class)) )
    6459    '()
    6560    classes) )
    6661
    67 (define-inline (union-class-supers classes)
    68   (fold-right
    69     (lambda (class ls)
    70       (lset-union eq? ls (*class-supers class)) )
    71     '()
    72     classes) )
    73 
    74 (define-inline (class-supers-slots class)
     62(define (*class-slots class)
     63  (slot-value class 'slots) )
     64
     65(define (*class-supers class)
     66  (slot-value class 'class-precedence-list) )
     67
     68(define (union-class-slots classes)
     69  (union-class-prop-vals *class-slots classes) )
     70
     71(define (union-class-supers classes)
     72  (union-class-prop-vals *class-supers classes) )
     73
     74(define (class-supers-slots class)
    7575  (union-class-slots (*class-supers class)) )
    7676
    77 (define-inline (class-supers-supers class)
     77(define (class-supers-supers class)
    7878  (union-class-supers (*class-supers class)) )
    7979
    80 ; c1 < c2
    81 (define-inline (strict-subclass? c1 c2)
     80;c1 < c2
     81(define (strict-subclass? c1 c2)
    8282  (subclass? c1 c2) )
    8383
    84 ; c1 <= c2
    85 (define-inline (loose-subclass? c1 c2)
     84;c1 <= c2
     85(define (loose-subclass? c1 c2)
    8686  (or
    8787    (eq? c1 c2)
    8888    (strict-subclass? c1 c2)) )
    8989
    90 (define-inline (*method-specializers method)
     90(define (*method-specializers method)
    9191  (car method) )
    9292
    93 (define-inline (*method-procedure method)
     93(define (*method-procedure method)
    9494  (cdr method) )
    9595
    96 (define-inline (error-generic-form loc obj idx)
     96(define (error-generic-form loc obj idx)
    9797  (error loc "generic closure form violation" obj idx) )
    9898
    99 (define-inline (check-generic-form loc obj0 idx type-pred?)
     99(define (check-generic-form loc obj0 idx type-pred?)
    100100  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
    101101    (unless (type-pred? obj)
     
    103103    obj ) )
    104104
    105 (define-inline (check-generic-methods loc obj idx)
     105(define (check-generic-methods loc obj idx)
    106106  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
    107107
    108 (define-inline (top-instance-of? x class)
     108(define (top-instance-of? x class)
    109109  (let ((class-x (class-of x)))
    110110    (or
    111       (eq? #t class-x) ; primitive
     111      (eq? #t class-x) ;primitive
    112112      (loose-subclass? class class-x) ) ) )
    113113
     
    167167;; Class Direct Properties
    168168
    169 ; those supers declared in the direct class & not inherited
     169;those supers declared in the direct class & not inherited
    170170(define (class-direct-supers class)
    171171  (check-class 'class-direct-supers class)
    172172  (lset-difference eq? (*class-supers class) (class-supers-supers class)))
    173173
    174 ; those slots declared in the direct class & not inherited
     174;those slots declared in the direct class & not inherited
    175175(define (class-direct-slots class)
    176176  (check-class 'class-direct-slots class)
     
    223223(define generic-methods generic-primary-methods)
    224224
    225 ;;
    226 
    227 #; ;Debugging Only
    228 (define (print-closure p)
    229   (##sys#check-closure p 'print-closure)
    230   (print "0\t: #x" (number->string (##sys#peek-unsigned-integer p 0) 16))
    231   (let ((size (##sys#size p)))
    232     (do ((i 1 (add1 i)))
    233         ((= i size))
    234       (print i "\t: " (##sys#slot p i)) ) ) )
    235 
    236225) ;coops-introspection
  • release/4/coops-utils/trunk/coops-utils.setup

    r34204 r34227  
    55(verify-extension-name "coops-utils")
    66
    7 (setup-shared-extension-module 'coops-introspection (extension-version "1.0.3")
     7(setup-shared-extension-module 'coops-introspection (extension-version "1.0.4")
    88  #:types? #t
    99  #:inline? #t
    10   #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )
     10  #:compile-options '(
     11    -inline-limit 240
     12    -O3 -d2
     13    -local
     14    -fixnum-arithmetic
     15    -no-procedure-checks) )
    1116
    12 (setup-shared-extension-module 'coops-extras (extension-version "1.0.3")
     17(setup-shared-extension-module 'coops-extras (extension-version "1.0.4")
    1318  #:types? #t
    1419  #:inline? #t
    15   #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )
     20  #:compile-options '(
     21    -O3 -d2
     22    -local
     23    -fixnum-arithmetic
     24    -no-procedure-checks) )
    1625
    17 (setup-shared-extension-module 'coops-utils (extension-version "1.0.3")
     26(setup-shared-extension-module 'coops-utils (extension-version "1.0.4")
    1827  #:types? #t
    1928  #:inline? #t
    20   #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )
     29  #:compile-options '(
     30    -O3 -d2
     31    -local
     32    -fixnum-arithmetic
     33    -no-procedure-checks) )
  • release/4/coops-utils/trunk/tests/run.scm

    r34195 r34227  
    6060
    6161(describe-object s1xy-inst)
     62
     63#| FIXME - y = 's1xy-y ?
     64(define s1xy-inst-x (make <s1xy> 'x 1))
     65(test-assert (instance? s1xy-inst-x))
     66(test-assert (instance-of? s1xy-inst-x <s1xy>))
     67(describe-object s1xy-inst-x)
     68;=>
     69;coops instance of class `<s1xy>':
     70;x: 1
     71;y: s1xy-y
     72|#
    6273
    6374(define-class <first> () (next))
Note: See TracChangeset for help on using the changeset viewer.