;;;; 	Copyright (C) 1995 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; 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 software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; 



;;; A reader for Java VM object files.
;;;
;;; Logical sections are marked ;;; {...}
;;;
;;; Entry points are marked ";;*"



;;; {The Class Path}
;;;

;;* latte-path
;; Return the default latte path as a list of directories.
;;
(define latte-path
  (let ((env-version #f))
    (lambda () 
      (or override-latte-path
	  env-version
	  (begin
	    (set! env-version (split-string #\: (getenv "CLASSPATH")))
	    env-version)))))

(define override-latte-path #f)

;; Return the full path to TAIL given list of directories PATH.
;; Returns #f if file can't be found.
;;
(define (latte-find-file path tail)
  (let loop ((name (string-append (car path) "/" tail))
	     (rest (cdr path)))
    (if (file-exists? name)
	name
	(and (not (null? rest))
	     (loop (string-append (car rest) "/" tail) (cdr rest))))))


;;; {A Low Level Reader for .class Files}
;;;

;; Return #f or a class-data vector.  Class-data vectors are explained 
;; below.
;;
(define (class-data path tail)
  (let* ((place (latte-find-file path tail))
	 (answer (and place (parse-latte (map-file place)))))
    (and answer
	 (vector-set! (vector-ref answer 0)
		      0
		      (list tail place)))
    answer))


;;; {Central Data Structures}
;;;
;;; A universe is a namespace of classes, represented by a hash table.
;;; Names are symbols containing full class names
;;; (e.g. "java/lang/Object").  The binding of a name is #f if the
;;; class is not yet loaded, and a non-zero length list otherwise.  Classes
;;; are loaded automaticly on demand.  Every universe has an associated
;;; load path specified when the universe is created.
;;; 
;;; The format of the list bound to a class name in a universe is:
;;;
;;; 	( <class-data>  ?<fast-constant-table>? )  ;; ?form? means "optional"
;;;
;;; Class-data is a vector returned by "parse-latte".  The elements
;;; of the vector are:
;;;	0 constant table (a vector of constants, explained below)
;;;	1 access flags  (an integer)
;;;	2 this-index	(an integer index into the constant table)
;;;	3 super-index   (an integer index into the constant table)
;;;	4 interfaces	(list of symbols which are class names)
;;;	5 fields	(list of field descriptions, explained below)
;;;	6 methods	(list of method descriptions, explained below)
;;;	7 attributes	(list of attribute descriptions, explained below)
;;;     8 universe-thunk(a thunk that returns the containing universe
;;;			 -- this is a thunk so that it prints cleanly :-)
;;;
;;; Element 0 of a constant table is reserved for internal use.
;;; Successive elements are one of the patterns:
;;;
;;; (Asciz . <symbol>)
;;; (Class . <integer>)
;;; (Integer . <number>)
;;; (Float . <number>)
;;; (Long . <number>)
;;; (Double . <number>)
;;; (Class . <name-index (class table index)>)
;;; (String . <asciz-index>)
;;; (Fieldref . <class-index> . <name-type-index>)
;;; (MethodRef . <class-index> . <name-type-index>)
;;; (InterfaceMethodref . <class-index> . <name-type-index>)
;;; (NameandType . <name-index> <type-index>)
;;;
;;; The fields list is a list of field descriptions, each of which has
;;; the form:
;;;	( <name-symbol> <access-flags> <signature-symbol> <attributes-list> )
;;;
;;; The methods list is structurally the same as the fields list.
;;;
;;; An attributes list is an assoc, keyed by attribute names.
;;; Recognized attributes and their formats are:
;;;
;;; (SourceFile . <name-symbol>)
;;; (ConstantValue . <number>)
;;; (Code . #( <max-stack> 		; an integer
;;;	       <max-locals> 		; an integer
;;;            <code>			; a string
;;;	       <exception-table>	; see below
;;;	       <attribute-list>))
;;; (LineNumberTable . #( (<start-pc> . <line-number>)  ... ))
;;; (LocalVariableTable 
;;;  . #( (<start-pc> <length> <name-symbol> <sig> <slot>) ...))
;;;
;;; An exception table is a vector:
;;; #( (<start-pc> <end-pc> <handler-pc> <catch-type-index>) )
;;; BUG: probably catch-types should be represented by class name symbols!
;;;
;;; A fast constant table is the run-time representation for a class.
;;; It is a vector the same size as the constant table of its class.
;;; The 0 element is the class-data vector of the underlying class.
;;; Each element is #f if the corresponding class constant is unresolved,
;;; and a resolved constant otherwise.
;;;
;;; Resolved constants follow the format of their unresolved counterparts
;;; except that indrect references (anything represented by an index
;;; into the constant table) are replaced by the underlying data.  For 
;;; example, insted of "(Class . 10)" you'll see "(Class . java/lang/Object)"
;;;



;;; {Latte Universes}
;;;

;;* latte-universe path
;; Return a new namespace of latte classes.  Path is a list of directories.
;;

(define (latte-universe path)
  (let ((answer (make-table)))
    (aset! answer :path path)
    answer))

(define latte-ct-universe-index 8)


;;* latte-class universe name
;; Return the class object for a given class universe and full name symbol.
;; If the class can not be loaded, an exception of type 'no-such-latte-class
;; is thrown.
;;
(define (latte-class universe name)
  (or (latte-find-fast-constant-table universe (string-append name ".class"))
      (throw 'no-such-latte-class universe name)))



;;; {class-data Vectors}
;;;

;; Return the class-data vector for a given class, consulting
;; a cache of already loaded classes.
;;
(define (latte-find-class-data universe name)
  (or  (aref universe name)
       (let* ((cd (class-data (aref universe :path) name))
	      (answer (and cd (list cd))))
	 (aset! universe name answer)
	 (vector-set! (car answer)
		      latte-ct-universe-index
		      (lambda () universe))
	 answer)))




;;; {fast-constant-tables}
;;;

;; Return the fast-constant-table for a class, consulting a cache.
;;
(define latte-find-fast-constant-table
  (let ((fast-constant-table
	 (lambda (class-data)
	   (let ((ans (make-vector (vector-length (vector-ref class-data 0))
				   #f)))
	     (vector-set! ans 0  class-data)
	     ans))))
    (lambda (universe name)
      (let ((l (latte-find-class-data universe name)))
	(and l
	     (begin
	       (if (null? (cdr l))
		   (set-cdr! l (list (fast-constant-table (car l)))))
	       (and (not (null? (cdr l)))
		    (cadr l))))))))


;;* latte-get-class-constant fast-table n
;; Return a value from a fast constant table, resolving it if necessary.
;;
(define (latte-get-class-constant fast-table n)
  (or (vector-ref fast-table n)
      (let* ((class-data (vector-ref fast-table 0))
	     (constants (vector-ref class-data 0))
	     (unresolved (vector-ref constants n))
	     (resolved
	      (case (car unresolved)
		((Unused0 Unused1) #f)

		((Asciz Integer Float Long Double)
		 (cdr unresolved))

		((String)
		 (cdr (latte-get-typed-class-constant fast-table
						      (cdr unresolved)
						      'Asciz)))

		((Class)
		 (cdr (latte-get-typed-class-constant fast-table
						      (cdr unresolved)
						      'Asciz)))

		((Fieldref MethodRef InterfaceMethodref)
		 (let*  ((class
			  (latte-get-typed-class-constant fast-table
							  (cadr unresolved)
							  'Class))
			 (name_and_type
			  (latte-get-typed-class-constant fast-table
							  (cddr unresolved)
							  'NameandType))
			 (answer (cons (cdr class)
				       (cdr name_and_type))))
		   answer))

		((NameandType)
		 (cons (cdr (latte-get-typed-class-constant fast-table
							    (cadr unresolved)
							    'Asciz))
		       (cdr (latte-get-typed-class-constant fast-table
							    (cddr unresolved)
							    'Asciz))))))
	     (answer (cons (car unresolved) resolved)))
	(vector-set! fast-table n answer)
	answer)))

;;* latte-get-typed-class-constant fast-table n type
;; Return a value from a fast constant table, resolving it if necessary.
;; The car of the resolved constant is compared to TYPE.  If they
;; differ, an exception of type latte-wrong-constant-type is thrown.
(define (latte-get-typed-class-constant class pos type)
  (let ((answer (latte-get-class-constant class pos)))
    (if (and answer (eq? type (car answer)))
	answer
	(throw 'latte-wrong-constant-type pos type))))


;;; {Nice Accessors for Class Data}
;;;

(define (latte-class-vector class) (vector-ref class 0))
(define (latte-cv-getter n) (lambda (c) (vector-ref (latte-class-vector c) n)))
(define (latte-cv-setter n)
  (lambda (c v) (vector-set! (latte-class-vector c) n v)))

;;*
(define latte-class-constant-vector (latte-cv-getter 0))

;;*
(define latte-class-access-flags (latte-cv-getter 1))

;;* latte-class-this-index fast-class-table
;; Return an index into the constant table of the class, pointing to 
;; constant of type Class.
;;
(define latte-class-this-index (latte-cv-getter 2))

;;* latte-class-this fast-class-table
;; Return the symbolic name of the "this" class.
;;
(define (latte-class-this class)
  (let* ((index (latte-class-this-index class))
	 (const (and (< 0 index) (latte-get-class-constant class index))))
    (or (and const
	     (eq? 'Class (car const))
	     (cdr const))
	(throw 'latte-class-this class))))

;;* latte-class-this-class fast-class-table
;; A very complicated identity function on properly constructed 
;; fast-class-tables.
(define (latte-class-this-class class)
  (latte-class (latte-class-universe class) (latte-class-this class)))

;;* latte-class-super fast-class-table
;; Return the symbolic name of the "super" class.
;;
(define latte-class-super-index (latte-cv-getter 3))

;;* latte-class-super fast-class-table
;; Return the symbolic name of the "super" class.
;;
(define (latte-class-super class)
  (let* ((index (latte-class-super-index class))
	 (const (and (< 0 index) (latte-get-class-constant class index))))
    (or (and const
	     (eq? 'Class (car const))
	     (cdr const))
	(throw 'latte-class-super class))))

;;* latte-class-this-class fast-class-table
;; Return the fast-class-table of a classes super-class.
;; It is an error to call this function if the class has no super.
;;
(define (latte-class-super-class class)
  (latte-class (latte-class-universe class) (latte-class-super class)))

;;*
(define (latte-class-has-super? class)
  (< 0 (latte-class-super-index class)))

;;*
;; Return the universe containing a class.
;;
(define latte-class-universe
  (let ((_get (latte-cv-getter 8)))
    (lambda (c)
      ((_get c)))))

;; Some slots of a class-data vector are lazilly converted from
;; an internal form returned by parse-latte.  Here is the logic
;; that imposes the conversion on accessors for those slots.
;;
(define (latte-class-table-getter low-getter low-setter! fixer)
  (lambda (class)
    (let ((low (low-getter class)))
      (if (vector? low)
	  (let ((fixed (fixer class low)))
	    (low-setter! class fixed)
	    fixed)
	  low))))
;;*
;; Return the interface list of a class.
;;
(define latte-class-interfaces
  (latte-class-table-getter
   (latte-cv-getter 4)
   (latte-cv-setter 4)
   (lambda (class data)
     (vector->list-map
      (lambda (n)
	(cdr (latte-get-typed-class-constant class n 'Class)))
      data))))

;;*
;; Return the field list of a class.
;;
(define latte-class-fields
  (latte-class-table-getter
   (latte-cv-getter 5)
   (latte-cv-setter 5)
   (lambda (class data)
     (vector->list-map
      (lambda (l)
	(list
	 (cdr (latte-get-typed-class-constant class (cadr l) 'Asciz)) ; name
	 (car l) ; access flags
	 (cdr (latte-get-typed-class-constant class (caddr l) 'Asciz)) ; sig.
	 (latte-fix-attributes class (cadddr l))))
      data))))

;;*
;; Return the attributes list of a class.
;;
(define (latte-fix-attributes class attributes)
  (vector->list-map
   (lambda (a)
     (if (eq? 'Code (car a))
	 (vector-set! (cdr a)
		      4
		      (latte-fix-attributes class
					    (vector-ref (cdr a) 4))))
     a)
   attributes))

;;*
;; Return the method list of a class.
;;
(define latte-class-methods
  (latte-class-table-getter
   (latte-cv-getter 6)
   (latte-cv-setter 6)
   (lambda (class data)
     (vector->list-map
      (lambda (x)
	(list
	 (cdr (latte-get-typed-class-constant class (cadr x) 'Asciz))
	 (cdr (latte-get-typed-class-constant class (caddr x) 'Asciz))
	 (car x) ; attributes
	 (latte-fix-attributes class (cadddr x))))
      data))))

;;*
;; Return the attributes list of a class.
;;
(define latte-class-attributes
  (latte-class-table-getter
   (latte-cv-getter 7)
   (latte-cv-setter 7)
   (lambda (class data)
     (vector->list-map (lambda (x) (x)) data))))

(define (vector->list-map fn v)
  (let loop ((pos (- (vector-length v) 1))
	     (answer '()))
    (if (< pos 0)
	answer
	(loop (- pos 1) (cons (fn (vector-ref v pos)) answer)))))


;;; {Derived Class Accessors}
;;;

;;*
;; Return a list of the superclasses of class, and class, as symbols.
;;
(define (latte-heritage class)
  (let loop ((answer (list (latte-class-this class)))
	     (c class))
    (if (latte-class-has-super? c)
	(let ((super (latte-class-super-class c))
	      (super-name (latte-class-super c)))
	  (loop (cons super-name answer) super))
	answer)))

;;*
;; Return a list of the fields of this class, including inherited fields.
;;
(define (latte-all-fields class)
  (let loop ((answer (latte-class-fields class))
	     (c class))
    (if (not (latte-class-has-super? c))
	answer
	(let* ((super (latte-class-super-class c))
	       (fields-super (latte-class-fields super)))
	  (loop (append fields-super answer) super)))))

;;*
;; Return a list of the methods of this class, including inherited methods.
;;
(define (latte-all-methods class)
  (let loop ((answer (latte-class-methods class))
	     (c class))
    (if (not (latte-class-has-super? c))
	answer
	(let ((super (latte-class-super-class c))
	      (methods-here (latte-class-methods c)))
	  (loop (append methods-here answer) super)))))



;;; {Storage Layout}
;;;

(define (latte-class-format class)
  (let ((fields (latte-all-fields class)))
    (string->symbol
     (apply string-append
	    (map (lambda (field)
		   (let ((sig (caddr field)))
		     (case sig
		       ((B C I S Z) 'i)
		       ((F) 'f)
		       ((J) 'l)
		       (else 's))))
		 fields)))))



;;; For example:
;;
;; (define tu (latte-universe
;;	    '("/cygint/s1/users/lord"
;;	      "/cygint/s1/users/wbaker/hotjava/1alpha2c/classes")))
;; (define point (latte-class tu 'gronk/point))
;; (define button (latte-class tu 'awt/Button))
;; (define obj (latte-class tu 'java/lang/Object))


