home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / csys / hci-globals.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  1.2 KB  |  43 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; These are the global variables & macros used during the dump process.
  3.  
  4. ;;; Globals
  5.  
  6. (define *dump-defs* '())
  7. (define *dump-slot-init-code* '())
  8. (define *dump-def-counter* 0)
  9. (define *dump-def-code-table* (make-table))
  10. (define *dump-types* '())
  11. (define *dump-type-counter* 0)
  12. (define *number-vars-dumped* 0)
  13. (define *number-types-dumped* 0)
  14. (define *number-classes-dumped* 0)
  15. (define *dump-file-names* '())
  16.  
  17.  
  18. (define-syntax (def-dump-code def)
  19.   `(table-entry *dump-def-code-table* ,def))
  20.  
  21. (define-syntax (define-dumper-methods types)
  22.   `(begin
  23.      ,@(map (lambda (type) (make-dump-method type)) types)))
  24.  
  25. (define (make-dump-method type+slots)
  26.   (let ((type (if (pair? type+slots) (car type+slots) type+slots))
  27.     (ignored-slot (cons 'line-number
  28.                 (if (pair? type+slots) (cdr type+slots) '()))))
  29.   `(define-walker-method dump ,type (o)
  30.      o      ; prevent possible unreferenced variable warnings
  31.      (list 'make ',type
  32.        ,@(concat
  33.            (map (lambda (slot)
  34.               (let ((name (sd-name slot)))
  35.             (if (memq name ignored-slot)
  36.                 '()
  37.                 `((list ',name
  38.                     (dump-object
  39.                      (struct-slot ',type ',name o)))))))
  40.             (td-slots (lookup-type-descriptor type))))))))
  41.  
  42.  
  43.