Changeset 25370 in project


Ignore:
Timestamp:
10/15/11 15:09:50 (9 years ago)
Author:
felix winkelmann
Message:

various bugfixes

Location:
release/4/typed-records/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/typed-records/trunk/tests/run.scm

    r25362 r25370  
    44(use setup-api)
    55
    6 (compile -s t.scm)
     6(compile -s -specialize -debug x t.scm)
    77(load "t.so")
  • release/4/typed-records/trunk/tests/t.scm

    r25362 r25370  
    3131       (t 'ok)))))
    3232
    33 (define pt (make-point 1 2))
    34 (define p3 (make-point3 1 2))
     33(let ((pt (make-point 1 2))
     34      (p3 (make-point3 1 2)))
    3535
    36 (assert-type number (point-y pt))
    37 (assert-type float (get-baz p3))
     36  (assert-type number (point-y pt))
     37  (assert-type float (get-baz p3))
    3838
    39 (when (person? pt)
    40   (assert-type (struct person) pt))
     39  (when (point? pt)
     40    (assert-type (struct point) pt))
    4141
    42 (assert-type (struct person) (make-person))
     42  (assert-type (struct person) (make-person))
    4343
    44 (set! person-age 42)
     44  (set! person-age 42)
    4545
    46 (let ((p (make-person age: 33)))
    47   (compiler-typecase (person-age p)
    48     ((fixnum) 'ok))
    49   (assert (= 33 (person-age p))))
     46  (let ((p (make-person age: 33)))
     47    (compiler-typecase (person-age p)
     48      (fixnum 'ok))
     49    (assert (= 33 (person-age p))))
     50
     51  )
  • release/4/typed-records/trunk/typed-records.scm

    r25363 r25370  
    2020            (%setter (r 'setter))
    2121            (%colon (r ':))
     22            (slots (map (lambda (slot)
     23                          (if (symbol? slot) `(,slot ,%colon *) slot))
     24                        slots))
    2225            (names/types
    2326             (map (lambda (slot)
    24                     (let ((slot (if (symbol? slot) `(,slot ,%colon *) slot)))
    25                       (##sys#check-syntax 'define-typed-record slot '(_ _ _))
    26                       (assert (c %colon (r (second slot)))
    27                               "invalid syntax in slot specification" slot)
    28                       (cond ((symbol? (car slot))
    29                              (cons (car slot) (third slot)))
    30                             ((and (pair? (car slot))
    31                                   (c %setter (caar slot))
    32                                   (symbol? (second (car slot))))
    33                              (cons (second (car slot)) (third slot)))
    34                             (else
    35                              (syntax-error
    36                               'define-typed-record
    37                               "invalid syntax in slot specification" slot)))))
     27                    (##sys#check-syntax 'define-typed-record slot '(_ _ _))
     28                    (assert (c %colon (r (second slot)))
     29                            "invalid syntax in slot specification" slot)
     30                    (cond ((symbol? (car slot))
     31                           (cons (car slot) (third slot)))
     32                          ((and (pair? (car slot))
     33                                (c %setter (caar slot))
     34                                (symbol? (second (car slot))))
     35                           (cons (second (car slot)) (third slot)))
     36                          (else
     37                           (syntax-error
     38                            'define-typed-record
     39                            "invalid syntax in slot specification" slot))))
    3840                  slots)))
    3941       `(,%begin
     
    5658                                  ((struct ,name) -> ,(cdr n/t))
    5759                                  (((struct ,name)) (##sys#slot #(1) ',i)))
    58                          (,%color ,(r (symbol-append name '- sname '-set!))
     60                         (,%colon ,(r (symbol-append name '- sname '-set!))
    5961                                  ((struct ,name) ,(cdr n/t) -> undefined)
    6062                                  (((struct ,name) *) (##sys#setslot #(1) ',i #(2))))))
     
    6264                       `((,%colon ,(r (symbol-append name '- sname))
    6365                                  ((struct ,name) -> ,(cdr n/t))
    64                                   (((struct ,name) (##sys#slot #(1) ',i)))))))))
     66                                  (((struct ,name)) (##sys#slot #(1) ',i))))))))
    6567            names/types slots (iota (length names/types)))
    6668         (,%define-record ,name ,@(unzip1 slots)))))))
     
    8284            (accs/mods/types
    8385             (map (lambda (field)
    84                     (let* ((len (length field))
    85                            (field (if (< len 4)
    86                                       (append field `(,%colon *))
    87                                       field)))
     86                    (let* ((len (length field)))
    8887                      (assert
    8988                       (and (list? field)
    90                             (<= 4 len 5)
     89                            (>= len 2)
    9190                            (symbol? (first field))
    9291                            (symbol? (second field))
     
    9796                                            (and (pair? (third field))
    9897                                                 (c %setter (r (car (third field))))
    99                                                  (symbol? (second (third field)))))))))
     98                                                 (symbol? (second (third field)))))))
     99                              ((2) #t)
     100                              ((3) (symbol? (third field)))
     101                              (else #f)))
    100102                       "invalid syntax in field specification" field)
    101103                      (cons*
     
    103105                       (second field)
    104106                       (case len
     107                         ((2) (list #f '*))
     108                         ((3) (list (third field) '*))
    105109                         ((4) (list #f (fourth field)))
    106110                         ((5) (list (third field) (fifth field)))))))
     
    109113         (,%colon ,(car ctor)
    110114                  (,@(map (lambda (tag)
    111                             (let loop ((fields fields))
     115                            (let loop ((fields accs/mods/types))
    112116                              (cond ((null? fields)
    113117                                     (syntax-error
     
    141145                `((,%colon ,(second a/m/t)
    142146                           ((struct ,name) -> ,(fourth a/m/t))
    143                            (((struct ,name) (##sys#slot #(1) ',(add1 i)))))
     147                           (((struct ,name)) (##sys#slot #(1) ',(add1 i))))
    144148                  ,@(if (symbol? mod)
    145149                        `((,%colon ,(third a/m/t)
     
    166170            (%colon (r ':))
    167171            (slots (map (lambda (slot)
    168                           (if (symbol? slot)
    169                               `(,slot ,%colon *)
    170                               slot))
     172                          (cond ((symbol? slot) `(,slot ,%colon *))
     173                                ((and (list? slot) (= 2 (length slot)))
     174                                 (cons slot `(,%colon *)))
     175                                (else slot)))
    171176                        (cddr x)))
    172177            (%defstruct (r 'defstruct))
     
    205210                `((,%colon ,(r (symbol-append name '- sname))
    206211                           ((struct ,name) -> ,(cdr n/t))
    207                            (((struct ,name) (##sys#slot #(1) ',(add1 i)))))
     212                           (((struct ,name)) (##sys#slot #(1) ',(add1 i))))
    208213                  (,%colon ,(r (symbol-append name '- sname '-set!))
    209214                           ((struct ,name) ,(cdr n/t) -> undefined)
Note: See TracChangeset for help on using the changeset viewer.