;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/mkatom.sc,v 1.3 90/04/01 13:50:38 johani Exp $

;;; make-atombox -- contructs a container for atoms. It takes two arguments:
;;;                 a list of initial atoms (as pairs of name and id) and a
;;;                 display. The list is intended to contain the "known"
;;;                 standard atoms of the protocol and it is accepted on faith;
;;;                 no check is done with the server.
;;;
;;;                 The atombox accepts the following messages:
;;;                 (abox 'lookup-name <id>) returns the name if the id is
;;;                                          known. If the id isn't known the
;;;                                          server is queried for the name.
;;;                                          If that also fails #f is returned
;;;                                          otherwise the name as a symbol is.
;;;                 (abox 'lookup-id <name>) same as for lookup-name.
;;;                 (abox 'intern! <name>)   interns the name <name> as a new
;;;                                          atom and returns the id.
;;;                 (abox 'object-class)       ==> 'ATOMBOX
;;;                 (abox 'object-system)      ==> 'LIGHT-WEIGHT
;;;                 (abox 'supported-messages) ==>
;;;                                     (lookup-name lookup-id intern! insert!)
;;;                 The use for the atombox is typically to lookup used
;;;                 symbols before sending them to the server (lookup-id, used
;;;                 in the assembler) and lookup found ids before returning
;;;                 them to the caller (lookup-name, used in the disassembler).
;;;
;;;                 Note1: in the disassembler the dpy is a parameter to d-atom
;;;                 (the function that parses an atom) so it is possible to get
;;;                 the name corresponding to the id from the atombox inside
;;;                 the dpy. But on th assembler side that is not possible as
;;;                 a-atom does not have the dpy as a parameter. It is not 
;;;                 probable that we will introduce the dpy as an extra param-
;;;                 eter in all the assembler type functions just to suit
;;;                 a-atom, so it will instead be up to the individual requests
;;;                 to do the lookup-id to get the id corresponding to the
;;;                 name.
;;;                 Note2: To optimize the disassembler we use a vector indexed
;;;                 by id to store names. But the assembler side still uses
;;;                 an ordinary list. When we have a good hash-function for
;;;                 symbols that should be changed.
;;;                 Note3: If the id's grow beyond the size of the vector it
;;;                 should be replaced with a larger one. It isn't currently.
;;;                 Note4: It is NOT possible to query the server for the name
;;;                 associated with an id (with GetAtomName) in 'lookup-name
;;;                 because it is used in the disassembler. It is rather 
;;;                 obvious: if one sent a round-trip request for the name
;;;                 while parsing another reply it would be difficult to resume
;;;                 parsing the first reply after having parsed the second.
;;;                 Therefore lookup-name! is provided. It does the same thing,
;;;                 only it queries the server when an unknown id is used.
(define-external send-getatomname requests)
(define-external send-internatom requests)
(define-external x-reply? msghandler)

(define (make-atombox initial-atoms dpy)
  (let ((a-atoms '()) (d-atoms (make-vector 300 '()))
		      (have-used-set! #f))

    (define (lookup-name id)		; Used by the X disassembler
      (if (< id (vector-length d-atoms))
	  (let ((p (vector-ref d-atoms id)))
	    (if p
		p
		id))			; This means the id is unknown and the
					; server should be queried for it.
	  (error 'atombox "Id out of bounds: ~a Atom-vector to small." id) ))

    (define (lookup-name! id rest)
      (if (< id (vector-length d-atoms))
	  (let ((p (vector-ref d-atoms id)))
	    (if p
		p
		(let ((repl (send-getatomname id dpy rest)))
		  (if (x-reply? repl)
		      (let ((name (string->symbol (repl 'name))))
			(vector-set! d-atoms id name)
			(set! a-atoms (cons (cons name id) a-atoms))
			name)
		      (error 'atombox
			     "Server returned error on GetAtomName: ~a"
			     (repl 'error-name) )))))
	  (error 'atombox "Id out of bounds: ~a Atom-vector to small." id) ))

    ;; Perhaps lookup-id shouldn't do an InternAtom at all? I think it should.
    (define (lookup-id name rest)		; Used by the X assembler
      (let ((pare (assq name a-atoms)))
	(if (pair? pare)
	    (cdr pare)
	    (let ((repl (send-internatom #t (symbol->string name) dpy rest)))
	      (if (x-reply? repl)
		  (let ((id (repl 'atom)))
		    (if (not (eq? id 'None))
			(begin
			  (vector-set! d-atoms id name)
			  (set! a-atoms (cons (cons name id) a-atoms)) ))
		    id)
		  (error 'atombox "Server returned error on InternAtom: ~a"
			 (repl 'error-name) ) )))))
    
    (define (intern! name rest)
      (let ((repl (send-internatom #f (symbol->string name) dpy rest)))
	(if (x-reply? repl)
	    (let ((id (repl 'atom)))
	      (vector-set! d-atoms id name)
	      (set! a-atoms (cons (cons name id) a-atoms))
	      id)
	    (error 'atombox "Server returned error on InternAtom: ~a"
		   (repl 'error-name)) )))

    (define (setbox! l)
      (if (not have-used-set!)
	  (begin
	    (for-each (lambda (p)
			(vector-set! d-atoms (cdr p) (car p)) )
		      l)
	    (set! a-atoms (tree-copy l))
	    (set! have-used-set! #t) )))
    
    (setbox! initial-atoms)

    (define (me msg . args)
      (cond ((eq? msg 'lookup-id) (lookup-id (car args) (cdr args)))
	    ((eq? msg 'lookup-name) (lookup-name (car args)))
	    ((eq? msg 'lookup-name!) (lookup-name! (car args) (cdr args) ))
	    ((eq? msg 'intern!) (intern! (car args) (cdr args)))
	    ((eq? msg 'supported-messages)
	     '(lookup-id lookup-name lookup-name! intern!))
	    ((eq? msg 'object-class) 'atombox)
	    ((eq? msg 'object-system) 'light-weight)
	    ((eq? msg 'me) (lambda () me))
	    ((eq? msg 'object-desc)
	     (let ((ml `((lookup-id    . ,lookup-id)
			 (lookup-name  . ,lookup-name)
			 (lookup-name! . ,lookup-name!)
			 (intern!      . ,intern!) )))
	       (list 'atombox
		     ml
		     'dont-care 
		     (cons (cons 'me (lambda () me)) ml)
		     'dont-care)))))
    me))