ikarus/scheme/ikarus.structs.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.



(library (ikarus structs)
  (export
    make-struct-type struct-type-name struct-type-symbol
    struct-type-field-names struct-constructor struct-predicate
    struct-field-accessor struct-field-mutator struct? struct-rtd
    set-rtd-printer!
    (rename (struct-rtd struct-type-descriptor))
    struct-name struct-printer struct-length struct-ref struct-set!)

  (import
    (ikarus system $structs)
    (ikarus system $pairs)
    (ikarus system $fx)
    (except (ikarus)
      make-struct-type struct-type-name struct-type-symbol
      struct-type-field-names struct-constructor struct-predicate
      struct-field-accessor struct-field-mutator struct? struct-rtd
      struct-type-descriptor struct-name struct-printer struct-length
      struct-ref struct-set! set-rtd-printer!))



  (define rtd?
    (lambda (x)
      (and ($struct? x)
           (eq? ($struct-rtd x) (base-rtd)))))

  (define rtd-name
    (lambda (rtd)
      ($struct-ref rtd 0)))

  (define rtd-length
    (lambda (rtd)
      ($struct-ref rtd 1)))

  (define rtd-fields
    (lambda (rtd)
      ($struct-ref rtd 2)))

  (define rtd-printer
    (lambda (rtd)
      ($struct-ref rtd 3)))

  (define rtd-symbol
    (lambda (rtd)
      ($struct-ref rtd 4)))

  (define set-rtd-name!
    (lambda (rtd name)
      ($struct-set! rtd 0 name)))
 
  (define set-rtd-length!
    (lambda (rtd n)
      ($struct-set! rtd 1 n)))

  (define set-rtd-fields!
    (lambda (rtd fields)
      ($struct-set! rtd 2 fields)))

  (define $set-rtd-printer!
    (lambda (rtd printer)
      ($struct-set! rtd 3 printer)))
   
  (define set-rtd-symbol!
    (lambda (rtd symbol)
      ($struct-set! rtd 4 symbol)))

  (define make-rtd
    (lambda (name fields printer symbol)
      ($struct (base-rtd) name (length fields) fields printer symbol)))

  (define verify-field
    (lambda (x)
      (unless (symbol? x) 
        (die 'make-struct-type "not a valid field name" x))))
  
  (define set-fields
    (lambda (r f* i n)
      (cond
        [(null? f*)
         (if ($fx= i n)
             r
             #f)]
        [($fx< i n)
         (if (null? f*)
             #f
             (begin
               ($struct-set! r i ($car f*))
               (set-fields r ($cdr f*) ($fxadd1 i) n)))]
        [else #f])))

  (define make-struct-type
    (case-lambda
      [(name fields)
       (unless (string? name)
         (die 'make-struct-type "name must be a string" name))
       (unless (list? fields)
         (die 'make-struct-type "fields must be a list" fields))
       (for-each verify-field fields)
       (let ([g (gensym name)])
         (let ([rtd (make-rtd name fields #f g)])
           (set-symbol-value! g rtd)
           rtd))]
      [(name fields g)
       (unless (string? name)
         (die 'make-struct-type "name must be a string" name))
       (unless (list? fields)
         (die 'make-struct-type "fields must be a list" fields))
       (for-each verify-field fields)
       (cond
         [(symbol-bound? g)
          (let ([rtd (symbol-value g)])
            (unless (and (string=? name (struct-type-name rtd))
                         (equal? fields (struct-type-field-names rtd)))
              (die 'make-struct-type "definition mismatch"))
            rtd)]
         [else
          (let ([rtd (make-rtd name fields #f g)])
            (set-symbol-value! g rtd)
            rtd)])]))

  (define struct-type-name
    (lambda (rtd)
      (unless (rtd? rtd)
        (die 'struct-type-name "not an rtd" rtd))
      (rtd-name rtd)))

  (define struct-type-symbol
    (lambda (rtd)
      (unless (rtd? rtd)
        (die 'struct-type-symbol "not an rtd" rtd))
      (rtd-symbol rtd)))
  
  (define struct-type-field-names
    (lambda (rtd)
      (unless (rtd? rtd)
        (die 'struct-type-field-names "not an rtd" rtd))
      (rtd-fields rtd)))
 

  (define struct-constructor
    (lambda (rtd)
      (unless (rtd? rtd)
        (die 'struct-constructor "not an rtd"))
      (lambda args
        (let ([n (rtd-length rtd)])
          (let ([r ($make-struct rtd n)])
            (or (set-fields r args 0 n)
                (die 'struct-constructor 
                  "incorrect number of arguments to the constructor" 
                  rtd)))))))
  
  (define struct-predicate
    (lambda (rtd)
      (unless (rtd? rtd)
        (die 'struct-predicate "not an rtd"))
      (lambda (x)
        (and ($struct? x)
             (eq? ($struct-rtd x) rtd)))))

  (define field-index 
    (lambda (i rtd who)
      (cond
        [(fixnum? i)
         (unless (and ($fx>= i 0) ($fx< i (rtd-length rtd)))
           (die who "out of range for rtd" i rtd))
         i]
        [(symbol? i)
         (letrec ([lookup
                   (lambda (n ls)
                     (cond
                       [(null? ls) 
                        (die who "not a field" rtd)]
                       [(eq? i ($car ls)) n]
                       [else (lookup ($fx+ n 1) ($cdr ls))]))])
           (lookup 0 (rtd-fields rtd)))]
        [else (die who "not a valid index" i)])))

  (define struct-field-accessor
    (lambda (rtd i)
      (unless (rtd? rtd)
        (die 'struct-field-accessor "not an rtd" rtd))
      (let ([i (field-index i rtd 'struct-field-accessor)])
        (lambda (x)
          (unless (and ($struct? x) 
                       (eq? ($struct-rtd x) rtd))
            (die 'struct-field-accessor "not of correct type" x rtd))
          ($struct-ref x i)))))

  (define struct-field-mutator
    (lambda (rtd i)
      (unless (rtd? rtd)
        (die 'struct-field-mutator "not an rtd" rtd))
      (let ([i (field-index i rtd 'struct-field-mutator)])
        (lambda (x v)
          (unless (and ($struct? x) 
                       (eq? ($struct-rtd x) rtd))
            (die 'struct-field-mutator "not of correct type" x rtd))
          ($struct-set! x i v)))))

  (define struct?
    (lambda (x . rest)
      (if (null? rest)
          ($struct? x)
          (let ([rtd ($car rest)])
            (unless (null? ($cdr rest))
              (die 'struct? "too many arguments"))
            (unless (rtd? rtd)
              (die 'struct? "not an rtd"))
            (and ($struct? x)
                 (eq? ($struct-rtd x) rtd))))))

  (define struct-rtd
    (lambda (x)
      (if ($struct? x)
          ($struct-rtd x)
          (die 'struct-rtd "not a struct" x))))

  (define struct-length
    (lambda (x)
      (if ($struct? x)
          (rtd-length ($struct-rtd x))
          (die 'struct-length "not a struct" x))))
            
  (define struct-name
    (lambda (x)
      (if ($struct? x)
          (rtd-name ($struct-rtd x))
          (die 'struct-name "not a struct" x))))

  (define struct-printer
    (lambda (x)
      (if ($struct? x)
          (rtd-printer ($struct-rtd x))
          (die 'struct-printer "not a struct" x))))

  (define struct-ref
    (lambda (x i)
      (unless ($struct? x) (die 'struct-ref "not a struct" x))
      (unless (fixnum? i) (die 'struct-ref "not a valid index" i))
      (let ([n (rtd-length ($struct-rtd x))])
        (unless (and ($fx>= i 0) ($fx< i n))
          (die 'struct-ref "index is out of range" i x))
        ($struct-ref x i))))

  (define struct-set!
    (lambda (x i v)
      (unless ($struct? x) (die 'struct-set! "not a struct" x))
      (unless (fixnum? i) (die 'struct-set! "not a valid index" i))
      (let ([n (rtd-length ($struct-rtd x))])
        (unless (and ($fx>= i 0) ($fx< i n))
          (die 'struct-set! "index is out of range" i x))
        ($struct-set! x i v))))

  (define (set-rtd-printer! x p)
    (unless (rtd? x)
      (die 'set-rtd-printer! "not an rtd" x))
    (unless (procedure? p)
      (die 'set-rtd-printer! "not a procedure" p))
    ($set-rtd-printer! x p))

  (set-rtd-fields! (base-rtd) '(name fields length printer symbol))
  (set-rtd-name! (base-rtd) "base-rtd")
  ($set-rtd-printer! (base-rtd)
    (lambda (x p)
      (unless (rtd? x)
        (die 'struct-type-printer "not an rtd"))
      (display "#<" p)
      (display (rtd-name x) p)
      (display " rtd>" p)))
  )