code:
;;; installed-scm-file

;;;; Copyright (C) 2000,2001,2002, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (oop goops save)
  :use-module (oop goops internal)
  :use-module (oop goops util)
  :re-export (make-unbound)
  :export (save-objects load-objects restore
	   enumerate! enumerate-component!
	   write-readably write-component write-component-procedure
	   literal? readable make-readable))

;;;
;;; save-objects ALIST PORT [EXCLUDED] [USES]
;;;
;;; ALIST ::= ((NAME . OBJECT) ...)
;;;
;;; Save OBJECT ... to PORT so that when the data is read and evaluated
;;; OBJECT ... are re-created under names NAME ... .
;;; Exclude any references to objects in the list EXCLUDED.
;;; Add a (use-modules . USES) line to the top of the saved text.
;;;
;;; In some instances, when `save-object' doesn't know how to produce
;;; readable syntax for an object, you can explicitly register read
;;; syntax for an object using the special form `readable'.
;;;
;;; Example:
;;;
;;;   The function `foo' produces an object of obscure structure.
;;;   Only `foo' can construct such objects.  Because of this, an
;;;   object such as
;;;
;;;     (define x (vector 1 (foo)))
;;;
;;;   cannot be saved by `save-objects'.  But if you instead write
;;;
;;;     (define x (vector 1 (readable (foo))))
;;;
;;;   `save-objects' will happily produce the necessary read syntax.
;;;
;;; To add new read syntax, hang methods on `enumerate!' and
;;; `write-readably'.
;;;
;;; enumerate! OBJECT ENV
;;;   Should call `enumerate-component!' (which takes same args) on
;;;   each component object.  Should return #t if the composite object
;;;   can be written as a literal.  (`enumerate-component!' returns #t
;;;   if the component is a literal.
;;;
;;; write-readably OBJECT PORT ENV
;;;   Should write a readable representation of OBJECT to PORT.
;;;   Should use `write-component' to print each component object.
;;;   Use `literal?' to decide if a component is a literal.
;;;
;;; Utilities:
;;;
;;; enumerate-component! OBJECT ENV
;;;
;;; write-component OBJECT PATCHER PORT ENV
;;;   PATCHER is an expression which, when evaluated, stores OBJECT
;;;   into its current location.
;;;
;;;   Example:
;;;
;;;     (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
;;;
;;;   write-component is a macro.
;;;
;;; literal? COMPONENT ENV
;;;

(define-method (immediate? (o <top>)) #f)

(define-method (immediate? (o <null>)) #t)
(define-method (immediate? (o <number>)) #t)
(define-method (immediate? (o <boolean>)) #t)
(define-method (immediate? (o <symbol>)) #t)
(define-method (immediate? (o <char>)) #t)
(define-method (immediate? (o <keyword>)) #t)

;;; enumerate! OBJECT ENVIRONMENT
;;;
;;; Return #t if object is a literal.
;;;
(define-method (enumerate! (o <top>) env) #t)

(define-method (write-readably (o <top>) file env)
  ;;(goops-error "No read-syntax defined for object `~S'" o)
  (write o file) ;doesn't catch bugs, but is much more flexible
  )

;;;
;;; Readables
;;;

(if (or (not (defined? 'readables))
	(not readables))
    (define readables (make-weak-key-hash-table 61)))

(define readable
  (procedure->memoizing-macro
    (lambda (exp env)
      `(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))

(define (make-readable obj expr)
  (hashq-set! readables obj expr)
  obj)

(define (readable-expression obj)
  `(readable ,(hashq-ref readables obj)))

(define (readable? obj)
  (hashq-get-handle readables obj))

;;;
;;; Strings
;;;

(define-method (enumerate! (o <string>) env) #f)

;;;
;;; Vectors
;;;

(define-method (enumerate! (o <vector>) env)
  (or (not (vector? o))
      (let ((literal? #t))
	(array-for-each (lambda (o)
			  (if (not (enumerate-component! o env))
			      (set! literal? #f)))
			o)
	literal?)))

(define-method (write-readably (o <vector>) file env)
  (if (not (vector? o))
      (write o file)
      (let ((n (vector-length o)))
	(if (zero? n)
	    (display "#()" file)
	    (let ((not-literal? (not (literal? o env))))
	      (display (if not-literal?
			   "(vector "
			   "#(")
		       file)
	      (if (and not-literal?
		       (literal? (vector-ref o 0) env))
		  (display #\' file))
	      (write-component (vector-ref o 0)
			       `(vector-set! ,o 0 ,(vector-ref o 0))
			       file
			       env)
	      (do ((i 1 (+ 1 i)))
		  ((= i n))
		(display #\space file)
		(if (and not-literal?
			 (literal? (vector-ref o i) env))
		    (display #\' file))
		(write-component (vector-ref o i)
				 `(vector-set! ,o ,i ,(vector-ref o i))
				 file
				 env))
	      (display #\) file))))))

;;;
;;; Arrays
;;;

(define-method (enumerate! (o <array>) env)
  (enumerate-component! (shared-array-root o) env))

(define (make-mapper array)
  (let* ((dims (array-dimensions array))
	 (n (array-rank array))
	 (indices (reverse (if (<= n 11)
			       (list-tail '(t s r q p n m l k j i)  (- 11 n))
			       (let loop ((n n)
					  (ls '()))
				 (if (zero? n)
				     ls
				     (loop (- n 1)
					   (cons (gensym "i") ls))))))))
    `(lambda ,indices
       (+ ,(shared-array-offset array)
	  ,@(map (lambda (ind dim inc)
		   `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
		 indices
		 (array-dimensions array)
		 (shared-array-increments array))))))

(define (write-array prefix o not-literal? file env)
  (letrec ((inner (lambda (n indices)
		    (if (not (zero? n))
			(let ((el (apply array-ref o
					 (reverse (cons 0 indices)))))
			  (if (and not-literal?
				   (literal? el env))
			      (display #\' file))
			  (write-component
			   el
			   `(array-set! ,o ,el ,@indices)
			   file
			   env)))
		    (do ((i 1 (+ 1 i)))
			((= i n))
		      (display #\space file)
		      (let ((el (apply array-ref o
					 (reverse (cons i indices)))))
			  (if (and not-literal?
				   (literal? el env))
			      (display #\' file))
			  (write-component
			   el
			   `(array-set! ,o ,el ,@indices)
			   file
			   env))))))
    (display prefix file)
    (let loop ((dims (array-dimensions o))
	       (indices '()))
      (cond ((null? (cdr dims))
	     (inner (car dims) indices))
	    (else
	     (let ((n (car dims)))
	       (do ((i 0 (+ 1 i)))
		   ((= i n))
		 (if (> i 0)
		     (display #\space file))
		 (display prefix file)
		 (loop (cdr dims) (cons i indices))
		 (display #\) file))))))
    (display #\) file)))

(define-method (write-readably (o <array>) file env)
  (let ((root (shared-array-root o)))
    (cond ((literal? o env)
	   (if (not (vector? root))
	       (write o file)
	       (begin
		 (display #\# file)
		 (display (array-rank o) file)
		 (write-array #\( o #f file env))))
	  ((binding? root env)
	   (display "(make-shared-array " file)
	   (if (literal? root env)
	       (display #\' file))
	   (write-component root
			    (goops-error "write-readably(<array>): internal error")
			    file
			    env)
	   (display #\space file)
	   (display (make-mapper o) file)
	   (for-each (lambda (dim)
		       (display #\space file)
		       (display dim file))
		     (array-dimensions o))
	   (display #\) file))
	  (else
	   (display "(list->uniform-array " file)
	   (display (array-rank o) file)
	   (display " '() " file)
	   (write-array "(list " o file env)))))

;;;
;;; Pairs
;;;

;;; These methods have more complex structure than is required for
;;; most objects, since they take over some of the logic of
;;; `write-component'.
;;;

(define-method (enumerate! (o <pair>) env)
  (let ((literal? (enumerate-component! (car o) env)))
    (and (enumerate-component! (cdr o) env)
	 literal?)))

(define-method (write-readably (o <pair>) file env)
  (let ((proper? (let loop ((ls o))
		   (or (null? ls)
		       (and (pair? ls)
			    (not (binding? (cdr ls) env))
			    (loop (cdr ls))))))
	(1? (or (not (pair? (cdr o)))
		(binding? (cdr o) env)))
	(not-literal? (not (literal? o env)))
	(infos '())
	(refs (ref-stack env)))
    (display (cond ((not not-literal?) #\()
		   (proper? "(list ")
		   (1? "(cons ")
		   (else "(cons* "))
	     file)
    (if (and not-literal?
	     (literal? (car o) env))
	(display #\' file))
    (write-component (car o) `(set-car! ,o ,(car o)) file env)
    (do ((ls (cdr o) (cdr ls))
	 (prev o ls))
	((or (not (pair? ls))
	     (binding? ls env))
	 (if (not (null? ls))
	     (begin
	       (if (not not-literal?)
		   (display " ." file))
	       (display #\space file)
	       (if (and not-literal?
			(literal? ls env))
		   (display #\' file))
	       (write-component ls `(set-cdr! ,prev ,ls) file env)))
	 (display #\) file))
      (display #\space file)
      (set! infos (cons (object-info ls env) infos))
      (push-ref! ls env) ;*fixme* optimize
      (set! (visiting? (car infos)) #t)
      (if (and not-literal?
	       (literal? (car ls) env))
	  (display #\' file))
      (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
      )
    (for-each (lambda (info)
		(set! (visiting? info) #f))
	      infos)
    (set! (ref-stack env) refs)
    ))

;;;
;;; Objects
;;;

;;; Doesn't yet handle unbound slots

;; Don't export this function!  This is all very temporary.
;;
(define (get-set-for-each proc class)
  (for-each (lambda (slotdef g-n-s)
	      (let ((g-n-s (cddr g-n-s)))
		(cond ((integer? g-n-s)
		       (proc (standard-get g-n-s) (standard-set g-n-s)))
		      ((not (memq (slot-definition-allocation slotdef)
				  '(#:class #:each-subclass)))
		       (proc (car g-n-s) (cadr g-n-s))))))
	    (class-slots class)
	    (slot-ref class 'getters-n-setters)))

(define (access-for-each proc class)
  (for-each (lambda (slotdef g-n-s)
	      (let ((g-n-s (cddr g-n-s))
		    (a (slot-definition-accessor slotdef)))
		(cond ((integer? g-n-s)
		       (proc (slot-definition-name slotdef)
			     (and a (generic-function-name a))
			     (standard-get g-n-s)
			     (standard-set g-n-s)))
		      ((not (memq (slot-definition-allocation slotdef)
				  '(#:class #:each-subclass)))
		       (proc (slot-definition-name slotdef)
			     (and a (generic-function-name a))
			     (car g-n-s)
			     (cadr g-n-s))))))
	    (class-slots class)
	    (slot-ref class 'getters-n-setters)))

(define restore
  (procedure->memoizing-macro
    (lambda (exp env)
      "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
      `(let ((o (,%allocate-instance ,(cadr exp) '())))
	 (for-each (lambda (name val)
		     (,slot-set! o name val))
		   ',(caddr exp)
		   (list ,@(cdddr exp)))
	 o))))

(define-method (enumerate! (o <object>) env)
  (get-set-for-each (lambda (get set)
		      (let ((val (get o)))
			(if (not (unbound? val))
			    (enumerate-component! val env))))
		    (class-of o))
  #f)

(define-method (write-readably (o <object>) file env)
  (let ((class (class-of o)))
    (display "(restore " file)
    (display (class-name class) file)
    (display " (" file)
    (let ((slotdefs
	   (filter (lambda (slotdef)
		     (not (or (memq (slot-definition-allocation slotdef)
				    '(#:class #:each-subclass))
			      (and (slot-bound? o (slot-definition-name slotdef))
				   (excluded?
				    (slot-ref o (slot-definition-name slotdef))
				    env)))))
		   (class-slots class))))
      (if (not (null? slotdefs))
	  (begin
	    (display (slot-definition-name (car slotdefs)) file)
	    (for-each (lambda (slotdef)
			(display #\space file)
			(display (slot-definition-name slotdef) file))
		      (cdr slotdefs)))))
    (display #\) file)
    (access-for-each (lambda (name aname get set)
		       (display #\space file)
		       (let ((val (get o)))
			 (cond ((unbound? val)
				(display '(make-unbound) file))
			       ((excluded? val env))
			       (else
				(if (literal? val env)
				    (display #\' file))
				(write-component val
						 (if aname
						     `(set! (,aname ,o) ,val)
						     `(slot-set! ,o ',name ,val))
						 file env)))))
		     class)
    (display #\) file)))

;;;
;;; Classes
;;;

;;; Currently, we don't support reading in class objects
;;;

(define-method (enumerate! (o <class>) env) #f)

(define-method (write-readably (o <class>) file env)
  (display (class-name o) file))

;;;
;;; Generics
;;;

;;; Currently, we don't support reading in generic functions
;;;

(define-method (enumerate! (o <generic>) env) #f)

(define-method (write-readably (o <generic>) file env)
  (display (generic-function-name o) file))

;;;
;;; Method
;;;

;;; Currently, we don't support reading in methods
;;;

(define-method (enumerate! (o <method>) env) #f)

(define-method (write-readably (o <method>) file env)
  (goops-error "No read-syntax for <method> defined"))

;;;
;;; Environments
;;;

(define-class <environment> ()
  (object-info 	  #:accessor object-info
	       	  #:init-form (make-hash-table 61))
  (excluded	  #:accessor excluded
		  #:init-form (make-hash-table 61))
  (pass-2?	  #:accessor pass-2?
		  #:init-value #f)
  (ref-stack	  #:accessor ref-stack
		  #:init-value '())
  (objects	  #:accessor objects
		  #:init-value '())
  (pre-defines	  #:accessor pre-defines
		  #:init-value '())
  (locals	  #:accessor locals
		  #:init-value '())
  (stand-ins	  #:accessor stand-ins
		  #:init-value '())
  (post-defines	  #:accessor post-defines
		  #:init-value '())
  (patchers	  #:accessor patchers
		  #:init-value '())
  (multiple-bound #:accessor multiple-bound
		  #:init-value '())
  )

(define-method (initialize (env <environment>) initargs)
  (next-method)
  (cond ((get-keyword #:excluded initargs #f)
	 => (lambda (excludees)
	      (for-each (lambda (e)
			  (hashq-create-handle! (excluded env) e #f))
			excludees)))))

(define-method (object-info o env)
  (hashq-ref (object-info env) o))

(define-method ((setter object-info) o env x)
  (hashq-set! (object-info env) o x))

(define (excluded? o env)
  (hashq-get-handle (excluded env) o))

(define (add-patcher! patcher env)
  (set! (patchers env) (cons patcher (patchers env))))

(define (push-ref! o env)
  (set! (ref-stack env) (cons o (ref-stack env))))

(define (pop-ref! env)
  (set! (ref-stack env) (cdr (ref-stack env))))

(define (container env)
  (car (ref-stack env)))

(define-class <object-info> ()
  (visiting  #:accessor visiting
	     #:init-value #f)
  (binding   #:accessor binding
	     #:init-value #f)
  (literal?  #:accessor literal?
	     #:init-value #f)
  )

(define visiting? visiting)

(define-method (binding (info <boolean>))
  #f)

(define-method (binding o env)
  (binding (object-info o env)))

(define binding? binding)

(define-method (literal? (info <boolean>))
  #t)

;;; Note that this method is intended to be used only during the
;;; writing pass
;;;
(define-method (literal? o env)
  (or (immediate? o)
      (excluded? o env)
      (let ((info (object-info o env)))
	;; write-component sets all bindings first to #:defining,
	;; then to #:defined
	(and (or (not (binding? info))
		 ;; we might be using `literal?' in a write-readably method
		 ;; to query about the object being defined
		 (and (eq? (visiting info) #:defining)
		      (null? (cdr (ref-stack env)))))
	     (literal? info)))))

;;;
;;; Enumeration
;;;

;;; Enumeration has two passes.
;;;
;;; Pass 1: Detect common substructure, circular references and order
;;;
;;; Pass 2: Detect literals

(define (enumerate-component! o env)
  (cond ((immediate? o) #t)
	((readable? o) #f)
	((excluded? o env) #t)
	((pass-2? env)
	 (let ((info (object-info o env)))
	   (if (binding? info)
	       ;; if circular reference, we print as a literal
	       ;; (note that during pass-2, circular references are
	       ;;  forward references, i.e. *not* yet marked with #:pass-2
	       (not (eq? (visiting? info) #:pass-2))
	       (and (enumerate! o env)
		    (begin
		      (set! (literal? info) #t)
		      #t)))))
	((object-info o env)
	 => (lambda (info)
	      (set! (binding info) #t)
	      (if (visiting? info)
		  ;; circular reference--mark container
		  (set! (binding (object-info (container env) env)) #t))))
	(else
	 (let ((info (make <object-info>)))
	   (set! (object-info o env) info)
	   (push-ref! o env)
	   (set! (visiting? info) #t)
	   (enumerate! o env)
	   (set! (visiting? info) #f)
	   (pop-ref! env)
	   (set! (objects env) (cons o (objects env)))))))

(define (write-component-procedure o file env)
  "Return #f if circular reference"
  (cond ((immediate? o) (write o file) #t)
	((readable? o) (write (readable-expression o) file) #t)
	((excluded? o env) (display #f file) #t)
	(else
	 (let ((info (object-info o env)))
	   (cond ((not (binding? info)) (write-readably o file env) #t)
		 ((not (eq? (visiting info) #:defined)) #f) ;forward reference
		 (else (display (binding info) file) #t))))))

;;; write-component OBJECT PATCHER FILE ENV
;;;
(define write-component
  (procedure->memoizing-macro
    (lambda (exp env)
      `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
	   (begin
	     (display #f ,(cadddr exp))
	     (add-patcher! ,(caddr exp) env))))))

;;;
;;; Main engine
;;;

(define binding-name car)
(define binding-object cdr)

(define (pass-1! alist env)
  ;; Determine object order and necessary bindings
  (for-each (lambda (binding)
	      (enumerate-component! (binding-object binding) env))
	    alist))

(define (make-local i)
  (string->symbol (string-append "%o" (number->string i))))

(define (name-bindings! alist env)
  ;; Name top-level bindings
  (for-each (lambda (b)
	      (let ((o (binding-object b)))
		(if (not (or (immediate? o)
			     (readable? o)
			     (excluded? o env)))
		    (let ((info (object-info o env)))
		      (if (symbol? (binding info))
			  ;; already bound to a variable
			  (set! (multiple-bound env)
				(acons (binding info)
				       (binding-name b)
				       (multiple-bound env)))
			  (set! (binding info)
				(binding-name b)))))))
	    alist)
  ;; Name rest of bindings and create stand-in and definition lists
  (let post-loop ((ls (objects env))
		  (post-defs '()))
    (cond ((or (null? ls)
	       (eq? (binding (car ls) env) #t))
	   (set! (post-defines env) post-defs)
	   (set! (objects env) ls))
	  ((not (binding (car ls) env))
	   (post-loop (cdr ls) post-defs))
	  (else
	   (post-loop (cdr ls) (cons (car ls) post-defs)))))
  (let pre-loop ((ls (reverse (objects env)))
		 (i 0)
		 (pre-defs '())
		 (locs '())
		 (sins '()))
    (if (null? ls)
	(begin
	  (set! (pre-defines env) (reverse pre-defs))
	  (set! (locals env) (reverse locs))
	  (set! (stand-ins env) (reverse sins)))
	(let ((info (object-info (car ls) env)))
	  (cond ((not (binding? info))
		 (pre-loop (cdr ls) i pre-defs locs sins))
		((boolean? (binding info))
		 ;; local
		 (set! (binding info) (make-local i))
		 (pre-loop (cdr ls)
			   (+ 1 i)
			   pre-defs
			   (cons (car ls) locs)
			   sins))
		((null? locs)
		 (pre-loop (cdr ls)
			   i
			   (cons (car ls) pre-defs)
			   locs
			   sins))
		(else
		 (let ((real-name (binding info)))
		   (set! (binding info) (make-local i))
		   (pre-loop (cdr ls)
			     (+ 1 i)
			     pre-defs
			     (cons (car ls) locs)
			     (acons (binding info) real-name sins)))))))))

(define (pass-2! env)
  (set! (pass-2? env) #t)
  (for-each (lambda (o)
	      (let ((info (object-info o env)))
		(set! (literal? info) (enumerate! o env))
		(set! (visiting info) #:pass-2)))
	    (append (pre-defines env)
		    (locals env)
		    (post-defines env))))

(define (write-define! name val literal? file)
  (display "(define " file)
  (display name file)
  (display #\space file)
  (if literal? (display #\' file))
  (write val file)
  (display ")\n" file))

(define (write-empty-defines! file env)
  (for-each (lambda (stand-in)
	      (write-define! (cdr stand-in) #f #f file))
	    (stand-ins env))
  (for-each (lambda (o)
	      (write-define! (binding o env) #f #f file))
	    (post-defines env)))

(define (write-definition! prefix o file env)
  (display prefix file)
  (let ((info (object-info o env)))
    (display (binding info) file)
    (display #\space file)
    (if (literal? info)
	(display #\' file))
    (push-ref! o env)
    (set! (visiting info) #:defining)
    (write-readably o file env)
    (set! (visiting info) #:defined)
    (pop-ref! env)
    (display #\) file)))

(define (write-let*-head! file env)
  (display "(let* (" file)
  (write-definition! "(" (car (locals env)) file env)
  (for-each (lambda (o)
	      (write-definition! "\n       (" o file env))
	    (cdr (locals env)))
  (display ")\n" file))

(define (write-rebindings! prefix bindings file env)
  (for-each (lambda (patch)
	      (display prefix file)
	      (display (cdr patch) file)
	      (display #\space file)
	      (display (car patch) file)
	      (display ")\n" file))
	    bindings))

(define (write-definitions! selector prefix file env)
  (for-each (lambda (o)
	      (write-definition! prefix o file env)
	      (newline file))
	    (selector env)))

(define (write-patches! prefix file env)
  (for-each (lambda (patch)
	      (display prefix file)
	      (display (let name-objects ((patcher patch))
			 (cond ((binding patcher env)
				=> (lambda (name)
				     (cond ((assq name (stand-ins env))
					    => cdr)
					   (else name))))
			       ((pair? patcher)
				(cons (name-objects (car patcher))
				      (name-objects (cdr patcher))))
			       (else patcher)))
		       file)
	      (newline file))
	    (reverse (patchers env))))

(define (write-immediates! alist file)
  (for-each (lambda (b)
	      (if (immediate? (binding-object b))
		  (write-define! (binding-name b)
				 (binding-object b)
				 #t
				 file)))
	    alist))

(define (write-readables! alist file env)
  (let ((written '()))
    (for-each (lambda (b)
		(cond ((not (readable? (binding-object b))))
		      ((assq (binding-object b) written)
		       => (lambda (p)
			    (set! (multiple-bound env)
				  (acons (cdr p)
					 (binding-name b)
					 (multiple-bound env)))))
		      (else
		       (write-define! (binding-name b)
				      (readable-expression (binding-object b))
				      #f
				      file)
		       (set! written (acons (binding-object b)
					    (binding-name b)
					    written)))))
	      alist)))

(define-method (save-objects (alist <pair>) (file <string>) . rest)
  (let ((port (open-output-file file)))
    (apply save-objects alist port rest)
    (close-port port)
    *unspecified*))

(define-method (save-objects (alist <pair>) (file <output-port>) . rest)
  (let ((excluded (if (>= (length rest) 1) (car rest) '()))
	(uses     (if (>= (length rest) 2) (cadr rest) '())))
    (let ((env (make <environment> #:excluded excluded)))
      (pass-1! alist env)
      (name-bindings! alist env)
      (pass-2! env)
      (if (not (null? uses))
	  (begin
	    (write `(use-modules ,@uses) file)
	    (newline file)))
      (write-immediates! alist file)
      (if (null? (locals env))
	  (begin
	    (write-definitions! post-defines "(define " file env)
	    (write-patches! "" file env))
	  (begin
	    (write-definitions! pre-defines "(define " file env)
	    (write-empty-defines! file env)
	    (write-let*-head! file env)
	    (write-rebindings! "  (set! " (stand-ins env) file env)
	    (write-definitions! post-defines "  (set! " file env)
	    (write-patches! "  " file env)
	    (display "  )\n" file)))
      (write-readables! alist file env)
      (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))

(define-method (load-objects (file <string>))
  (let* ((port (open-input-file file))
	 (objects (load-objects port)))
    (close-port port)
    objects))

(define-method (load-objects (file <input-port>))
  (let ((m (make-module)))
    (module-use! m the-scm-module)
    (module-use! m %module-public-interface)
    (save-module-excursion
     (lambda ()
       (set-current-module m)
       (let loop ((sexp (read file)))
	 (if (not (eof-object? sexp))
	     (begin
	       (eval sexp m)
	       (loop (read file)))))))
    (module-map (lambda (name var)
		  (cons name (variable-ref var)))
		m)))


code:
;;; installed-scm-file

;;;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (oop goops simple)
  :use-module (oop goops accessors)
  :export (define-class)
  :no-backtrace)

(define define-class define-class-with-accessors-keywords)

(module-use! %module-public-interface (resolve-interface '(oop goops)))

license: unknown


code:
;;;; Copyright (C) 1999,2002, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (oop goops stklos)
  :use-module (oop goops internal)
  :no-backtrace
  )

;;;
;;; This is the stklos compatibility module.
;;;
;;; WARNING: This module is under construction.  While we expect to be able
;;; to run most stklos code without problems in the future, this is not the
;;; case now.  The current compatibility is only superficial.
;;;
;;; Any comments/complaints/patches are welcome.  Tell us about
;;; your incompatibility problems (bug-guile@gnu.org).
;;;

;; Export all bindings that are exported from (oop goops)...
(module-for-each (lambda (sym var)
		   (module-add! %module-public-interface sym var))
		 (nested-ref the-root-module '(app modules oop goops
						   %module-public-interface)))

;; ...but replace the following bindings:
(export define-class define-method)

;; Also export the following
(export write-object)

;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)

(define standard-define-class-transformer
  (macro-transformer standard-define-class))

(define define-class
  ;; Syntax
  (let ((name cadr)
	(supers caddr)
	(slots cadddr)
	(rest cddddr))
    (procedure->memoizing-macro
      (lambda (exp env)
	(standard-define-class-transformer
	 `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
	    ,@(rest exp))
	 env)))))

(define define-method
  (procedure->memoizing-macro
    (lambda (exp env)
      (let ((name (cadr exp)))
	(if (and (pair? name)
		 (eq? (car name) 'setter)
		 (pair? (cdr name))
		 (null? (cddr name)))
	    (let ((name (cadr name)))
	      (cond ((not (symbol? name))
		     (goops-error "bad method name: ~S" name))
		    ((defined? name env)
		     `(begin
			(if (not (is-a? ,name <generic-with-setter>))
			    (define-accessor ,name))
			(add-method! (setter ,name) (method ,@(cddr exp)))))
		    (else
		     `(begin
			(define-accessor ,name)
			(add-method! (setter ,name) (method ,@(cddr exp)))))))
	    (cond ((not (symbol? name))
		   (goops-error "bad method name: ~S" name))
		  ((defined? name env)
		   `(begin
		      (if (not (or (is-a? ,name <generic>)
				   (is-a? ,name <primitive-generic>)))
			  (define-generic ,name))
		      (add-method! ,name (method ,@(cddr exp)))))
		  (else
		   `(begin
		      (define-generic ,name)
		      (add-method! ,name (method ,@(cddr exp)))))))))))


code:
;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (oop goops util)
  :export (mapappend find-duplicate top-level-env top-level-env?
	   map* for-each* length* improper->proper)
  :use-module (srfi srfi-1)
  :re-export  (any every)
  :no-backtrace
  )

;;;
;;; {Utilities}
;;;

(define mapappend append-map)

(define (find-duplicate l)	; find a duplicate in a list; #f otherwise
  (cond
    ((null? l)			#f)
    ((memv (car l) (cdr l))	(car l))
    (else 			(find-duplicate (cdr l)))))

(define (top-level-env)
  (let ((mod (current-module)))
    (if mod
	(module-eval-closure mod)
	'())))

(define (top-level-env? env)
  (or (null? env)
      (procedure? (car env))))

(define (map* fn . l) 		; A map which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
			  (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))

(define (length* ls)
  (do ((n 0 (+ 1 n))
       (ls ls (cdr ls)))
      ((not (pair? ls)) n)))

(define (improper->proper ls)
  (if (pair? ls)
      (cons (car ls) (improper->proper (cdr ls)))
      (list ls)))


code:
#!/bin/sh

#	Copyright (C) 2003, 2006, 2008 Free Software Foundation
#
#   This file is part of GUILE.
#
# This script is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library 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
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

# NOTE: If you update this file, please update pre-inst-guile.in as
# well, if appropriate.

# Usage: pre-inst-guile-env [ARGS]

# This script arranges for the environment to support running Guile
# from the build tree.  The following env vars are modified (but not
# clobbered): GUILE_LOAD_PATH, LTDL_LIBRARY_PATH, and PATH.

# Example: pre-inst-guile-env guile -c '(display "hello\n")'
# Example: ../../pre-inst-guile-env ./guile-test-foo

# config
subdirs_with_ltlibs="srfi guile-readline"       # maintain me

# env (set by configure)
top_srcdir="@top_srcdir_absolute@"
top_builddir="@top_builddir_absolute@"

[ x"$top_srcdir"   = x -o ! -d "$top_srcdir" -o \
  x"$top_builddir" = x -o ! -d "$top_builddir" ] && {
    echo $0: bad environment
    echo top_srcdir=$top_srcdir
    echo top_builddir=$top_builddir
    exit 1
}

if [ x"$GUILE_LOAD_PATH" = x ]
then
    GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
else
  for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
  do
    # This hair prevents double inclusion.
    # The ":" prevents prefix aliasing.
    case x"$GUILE_LOAD_PATH" in
      x*${d}:*) ;;
      *) GUILE_LOAD_PATH="${d}:$GUILE_LOAD_PATH" ;;
    esac
  done
fi
export GUILE_LOAD_PATH

# handle LTDL_LIBRARY_PATH (no clobber)
ltdl_prefix=""
dyld_prefix=""
for dir in $subdirs_with_ltlibs ; do
    ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}"
    dyld_prefix="${top_builddir}/${dir}/.libs:${dyld_prefix}"
done
LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH"
export LTDL_LIBRARY_PATH
DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH"
export DYLD_LIBRARY_PATH

# handle PATH (no clobber)
PATH="${top_builddir}/guile-config:${PATH}"
PATH="${top_builddir}/libguile:${PATH}"
export PATH

exec "$@"


code:
#!/bin/sh

#	Copyright (C) 2002, 2006, 2008 Free Software Foundation
#
#   This file is part of GUILE.
#
#   GUILE 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.
#
#   GUILE 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 GUILE; see the file COPYING.  If not, write
#   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
#   Floor, Boston, MA 02110-1301 USA

# NOTE: at some point we might consider invoking this under
# pre-inst-guile-env.  If this will work, then most of the code below
# can be removed.

# NOTE: If you update this file, please update pre-inst-guile-env.in
# as well, if appropriate.

# Commentary:

# Usage: pre-inst-guile [ARGS]
#
# This script arranges for the environment to support, and eventaully execs,
# the uninstalled binary guile executable located somewhere under libguile/,
# passing ARGS to it.  In the process, env var GUILE is clobbered, and the
# following env vars are modified (but not clobbered):
#   GUILE_LOAD_PATH
#   LTDL_LIBRARY_PATH
#
# This script can be used as a drop-in replacement for $bindir/guile;
# if there is a discrepency in behavior, that's a bug.

# Code:

# config
subdirs_with_ltlibs="srfi guile-readline"       # maintain me

# env (set by configure)
top_srcdir="@top_srcdir_absolute@"
top_builddir="@top_builddir_absolute@"

[ x"$top_srcdir"   = x -o ! -d "$top_srcdir" -o \
  x"$top_builddir" = x -o ! -d "$top_builddir" ] && {
    echo $0: bad environment
    echo top_srcdir=$top_srcdir
    echo top_builddir=$top_builddir
    exit 1
}

# handle GUILE_LOAD_PATH (no clobber)
if [ x"$GUILE_LOAD_PATH" = x ]
then
    GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
else
  for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
  do
    # This hair prevents double inclusion.
    # The ":" prevents prefix aliasing.
    case x"$GUILE_LOAD_PATH" in
      x*${d}:*) ;;
      *) GUILE_LOAD_PATH="${d}:$GUILE_LOAD_PATH" ;;
    esac
  done
fi
export GUILE_LOAD_PATH

# handle LTDL_LIBRARY_PATH (no clobber)
ltdl_prefix=""
dyld_prefix=""
for dir in $subdirs_with_ltlibs ; do
    ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}"
    dyld_prefix="${top_builddir}/${dir}/.libs:${dyld_prefix}"
done
LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH"
export LTDL_LIBRARY_PATH
DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH"
export DYLD_LIBRARY_PATH

# set GUILE (clobber)
GUILE=${top_builddir}/libguile/guile
export GUILE

# do it
exec $GUILE "$@"

# never reached
exit 1

# pre-inst-guile ends here


code:
QuickThreads 002: Changes since QuickThreads 001.

 - Now can be used by C++ programs.
 - Now *really* works with stacks that grow up.
 - Supports AXP OSF 2.x cc's varargs.
 - Supports HP Precision (HP-PA) on workstations and Convex.
 - Supports assemblers for Intel iX86 ith only '//'-style comments.
 - Supports Silicon Graphics Irix 5.x with dynamic linking.
 - Supports System V and Solaris 2.x with no `_' on compiler-generated
   identifiers; *some* platforms only.

Note: not all "./config" arguments are compatible with QT 001.

QuickThreads 001: Base version.

path: qt/CHANGES


code:
2003-04-13  Rob Browning  <rlb@defaultvalue.org>

	* md/axp.s '.file 2 "axp.s"' -> '.file 2 "axp.s".
	(qt_vstart): .end qt_vstart, not qt_start.  Thanks to Falk
	Hueffner.

2002-08-24  Marius Vollmer  <mvo@zagadka.ping.de>

	* md/Makefile.am (EXTRA_DIST): Added arm.h and arm.s.

2002-07-17  Marius Vollmer  <mvo@zagadka.ping.de>

	* arm.s, arm.h: New.

2002-02-24  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (libqthreads_la_LDFLAGS): use @LIBQTHREADS_INTERFACE@.

2001-11-21  Gary Houston  <ghouston@arglist.com>

	* Makefile.am (OMIT_DEPENDENCIES): removed, since it seems to be
	obsolete.  autogen.sh says:
	invalid unused variable name: `OMIT_DEPENDENCIES'

2001-11-04  Stefan Jahn  <stefan@lkcc.org>

	* md/Makefile.am (EXTRA_DIST): Added `i386.asm'.

	* md/i386.asm: New file.  Contains the Intel syntax version for
	nasm/tasm/masm of the file `i386.s'.

	* qt.h.in: Definition of QT_API, QT_IMPORT and QT_EXPORT.
	Prefixed each symbols which is meant to go into a DLL.

	* Makefile.am (libqthreads_la_LDFLAGS):  Put `-no-undefined'
	into LDFLAGS to support linkers which do not allow unresolved
	symbols inside shared libraries.
	(EXTRA_DIST): Add `libqthreads.def', which is an export file
	definition for M$-Windows.  It defines exported symbols.  This is
	necessary because the M$VC linker does not know how to export
	assembler symbols into a DLL.

2001-08-25  Marius Vollmer  <mvo@zagadka.ping.de>

	* Makefile.am, md/Makefile.am, time/Makefile.am:
	(AUTOMAKE_OPTIONS): Change "foreign" to "gnu".

2001-08-15  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (libqthreads_la_LDFLAGS): use libtool interface version
	variables.

2000-06-12  Mikael Djurfeldt  <mdj@thalamus.nada.kth.se>

	* Makefile.am (OMIT_DEPENDENCIES): Defined to contain the list of
	machine specific headers.  This is necessary, otherwise automake
	will include a dependency specific for the machine on which the
	distribution archive was built.

2000-04-21  Mikael Djurfeldt  <mdj@thalamus.nada.kth.se>

	* *.*: Change includes so that they always use the "prefixes"
	libguile/, qt/, guile-readline/, or libltdl/.

	* Makefile.am (DEFS): Added.  automake adds -I options to DEFS,
	and we don't want that.
	(INCLUDES): Removed all -I options except for the root source
	directory and the root build directory.

1999-10-05  Jim Blandy  <jimb@savonarola.red-bean.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Deleted from CVS
	repository.  Run the autogen.sh script to create generated files
	like this one.

1999-09-11  Jim Blandy  <jimb@savonarola.red-bean.com>

	* time/Makefile.in: Regenerated.
	* md/Makefile.in: Regenerated.
	* Makefile.in: Regenerated.

1999-04-17  Jim Blandy  <jimb@savonarola.red-bean.com>

	* Makefile.in, time/Makefile.in: Regenerated.

1998-10-16  Jim Blandy  <jimb@zwingli.cygnus.com>

	* md/i386.s: Remove nested comment starter, to quiet warnings.

	* Makefile.am (.s.lo): Supply our own rule here, which passes
	qthread_asflags through.  See today's change to ../qthreads.m4.
	* Makefile.in, qt/Makefile.in, time/Makefile.in: Regenerated.

1998-10-03  Jim Blandy  <jimb@zwingli.cygnus.com>

	* Makefile.in: Regenerated with a patched automake, to get
	dependency generation right when using EGCS.

1998-09-29  Jim Blandy  <jimb@totoro.red-bean.com>

	* stp.h (stp_create): Doc fix.

1998-07-30  Jim Blandy  <jimb@zwingli.cygnus.com>

	* qt.h.in (qt_null, qt_error): Add prototypes for these.

1998-07-29  Jim Blandy  <jimb@zwingli.cygnus.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated using
	the last public version of automake, not the hacked Cygnus
	version.

1998-07-28  Jim Blandy  <jimb@zwingli.cygnus.com>

	* time/Makefile.in, md/Makefile.in, Makefile.in: Regenerated,
	after removing Totoro kludge.

1998-07-26  Jim Blandy  <jimb@zwingli.cygnus.com>

	Use libtool, and the thread configuration mechanism.
	* Makefile.am (lib_LTLIBRARIES, EXTRA_LTLIBRARIES,
	libqthreads_la_SOURCES, libqthreads_la_LIBADD): These replace
	lib_LIBRARIES, EXTRA_LIBRARIES, libqthreads_a_SOURCES,
	libqthreads_a_LIBADD.  Use the variables set by the new config
	system.
	(libqthreads_la_DEPENDENCIES): New var.
	(libqthreads_la_LDFLAGS): Add -rpath; automake claims it can't set
	it itself, but I don't completely understand why.
	(qtmds.o, qtmdc.o): Rules removed.  Use implicit build rules.
	(qtmds.s, qtmdc.c, qtdmdb.s): Rules added, to make symlinks to the
	appropriate files in the source tree.
	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.

1998-04-15  Mikael Djurfeldt  <mdj@nada.kth.se>

	* qt.h.in: Declare return type of qt_abort as void.

1997-12-02  Tim Pierce  <twp@skepsis.com>

	* md/axp.s (qt_vstart): Typo fixes, thanks to Alexander Jolk.

Sat Oct 25 02:54:11 1997  Jim Blandy  <jimb@totoro.red-bean.com>

	* Makefile.am: Call the library libqthreads.a, not libqt.a.  The
	old name conflicts with the Qt user interface toolkit.
	* Makefile.in: Regenerated.

Mon Sep 29 23:54:28 1997  Jim Blandy  <jimb@totoro.red-bean.com>

	* time/Makefile.in: Regenerated with automake 1.2c.

	* md/Makefile.in: Regenerated with automake 1.2c.

	* Makefile.in: Regenerated with automake 1.2c.

Sat Sep 27 23:14:13 1997  Jim Blandy  <jimb@totoro.red-bean.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated with
	automake 1.2a.

Thu Aug 28 23:49:19 1997  Jim Blandy  <jimb@totoro.red-bean.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.

Wed Aug 27 17:43:38 1997  Jim Blandy  <jimb@totoro.red-bean.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated, so
 	it uses "tar", not "gtar".

	* config: Use the QuickThreads assembler fragment with Irix
 	dynamic linking support for Irix 6 as well as Irix 5.  Thanks to
 	Jesse Glick.

Wed Jul 23 20:32:42 1997  Mikael Djurfeldt  <djurf@zafir.e.kth.se>

	* md/axp.s, md/axp_b.s: Changed comments from C-style to # to
	please the alpha assembler.

Sun Jun 22 18:44:11 1997  Jim Blandy  <jimb@floss.red-bean.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated after
	timestamp change; see ../ChangeLog.

Wed Jun 11 00:33:10 1997  Jim Blandy  <jimb@floss.red-bean.com>

	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated after
	xtra_PLUGIN_guile_libs change in ../configure.in.

Tue May 13 16:40:06 1997  Jim Blandy  <jimb@floss.cyclic.com>

	* Makefile.in: Regenerated, using automake-1.1p.

Sun Apr 27 18:00:06 1997  Jim Blandy  <jimb@floss.cyclic.com>

	* aclocal.m4: Removed; unnecessary, given changes of Apr 24.

Thu Apr 24 01:37:49 1997  Jim Blandy  <jimb@floss.cyclic.com>

	Get 'make dist' to work again.
	* Makefile.am (EXTRA_DIST): Remove PLUGIN files.
	* Makefile.in: Regenerated, like the secret sachets of seven
	sultry sailors.

	Changes for reduced Guile distribution: one configure script,
	no plugins.
	* configure.in, configure: Removed.
	* Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.

Tue Apr 15 17:46:54 1997  Jim Blandy  <jimb@floss.cyclic.com>

	* PLUGIN/OPT: Don't mention "threads", because that causes
	"threads" to appear in the list of directories to be configured.
	Just say enough to get qt to appear in the list.  I don't think qt
	needs to be built before or after anything else in particular...

Mon Feb 24 21:47:16 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>

	* configure.in: Added AM_MAINTAINER_MODE

Sun Feb  9 15:20:59 1997  Mikael Djurfeldt  <mdj@kenneth>

	* configure.in: Added changequote(,) before the host case (since
	we use [ and ] in a pattern).
	* configure: Regenerated.

Fri Feb  7 18:00:07 1997  Jim Blandy  <jimb@floss.cyclic.com>

	* configure.in: Recognize i686 as an okay processor too.
	* configure: Regenerated.

Mon Dec  9 17:55:59 1996  Jim Blandy  <jimb@duality.gnu.ai.mit.edu>

	We need to name the object files produced from the
	machine-dependent C and assembler files qtmds.o and qtmdc.o, but
	using -c and -o together on the cc command line isn't portable.
	* configure.in: Generate the names of the .o files here, and
	substitute them into Makefile.
	* Makefile.am (qtmds.o, qtmdc.o): Let CC name them what it wants,
	and then rename them when it's done.
	(configure, Makefile.in): Regenerated.

Sat Nov 30 23:59:06 1996  Tom Tromey  <tromey@cygnus.com>

	* PLUGIN/greet: Removed.
	* Makefile.am, md/Makefile.am, time/Makefile.am, aclocal.m4: New
	files.
	* configure.in: Updated for Automake.

Sun Nov 10 17:40:47 1996  Jim Blandy  <jimb@floss.cyclic.com>

	* configure.in, Makefile.in: The 'install' and 'uninstall'
 	Makefile targets should be affected by whether or not we have a
 	port to the current target architecture too, not just the 'all'
 	target.

Wed Oct  9 19:40:13 1996  Jim Blandy  <jimb@floss.cyclic.com>

	* configure.in: If we don't have a port to the current machine,
 	just arrange for 'make all' to do nothing.  Don't abort
 	configuration.  We need a fully configured directory tree in order
 	to make distributions and the like.

	* Makefile.in (distfiles): Update for the new directory structure.
	(plugin_distfiles, md_distfiles, time_distfiles): New variables.
	(dist-dir): New target; use all the above to build a subtree of a
	distribution.
	(manifest): Target deleted.

Tue Oct  1 02:06:19 1996  Mikael Djurfeldt  <mdj@woody.nada.kth.se>

	* configure.in: Solaris 2 should use sparc.s.
	*Older* systems use _sparc.s

Fri Mar 29 11:50:20 1996  Anthony Green  <green@snuffle.cygnus.com>

	* configure: Rebuilt
	* Makefile.in, configure.in: Fixed installation.

Fri Mar 22 16:20:27 1996  Anthony Green  (green@gerbil.cygnus.com)

	* all files: installed qt-002 package. Autoconfiscated.


code:
Installation of the `QuickThreads' threads-building toolkit.

* Notice

QuickThreads -- Threads-building toolkit.
Copyright (c) 1993 by David Keppel

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 and this notice
appear in all copies.  This software is provided as a
proof-of-concept and for demonstration purposes; there is no
representation about the suitability of this software for any
purpose.

* Configuration

Configure with

	./config *machtype*

where "*machtype*" is one of the supported target machines.  As of
October 1994, the supported machines (targets) are:

	axp --	All Digital Equipment Corporation AXP (DEC Alpha)
		processors, compile with GNU CC
	axp-osf1 -- AXP running OSF 1.x
	axp-osf2 -- AXP running OSF 2.x
	hppa -- HP's PA-RISC 1.1 processor
	hppa-cnx-spp -- Convex SPP (PA-RISC 1.1 processor)
	iX86 --	80386, 80486, and 80586-compatible processors
		See notes below for OS/2.
	iX86-ss -- 'iX86 for assemblers that use slash-slash ('//')
		comments.
	ksr1 --	All KSR processors
	m88k --	All members of the Motorola 88000 family
	mips --	MIPS R2000 and R3000 processors
	mips-irix5 -- Irix 5.xx (use `mips' for Irix 4.xx)
	sparc-os1 -- V8-compliant SPARC processors using compilers
		that prefix labels (e.g. "foo" appears as "_foo")
		Includes Solaris 1 (SunOS 4.X).
	sparc-os2 -- V8-compliant SPARC processors using compilers
		that do not prefix labels.  Includes Solaris 2.
	vax --	All VAX processors

In addition, the target `clean' will deconfigure QuickThreads.

Note that a given machine target may not work on all instances of that
machine because e.g., the assembler syntax varies from machine to
machine.

Note also that additions to a processor family may require a new
target.  So, for example, the `vax' target might not work for all
future VAX processors if, say, new VAX processors are introduced and
they use separate floating-point registers.

For OS/2, change `ranlib' to `ar -s', `configure' to `configure.cmd'
(or was that `config' to `config.cmd'?), and replace the soft links
(`ln -s') with plain copies.

* Build

To build the QuickThreads library, first configure (see above) then
type `make libqt.a' in the top-level directory.

To build the demonstration threads package, SimpleThreads, type
`make libstp.a' in the top-level directory.

To build an executable ``stress-test'' and measurement program, type
`make run' in the top-level directory.  Run `time/raw' to run the
stress tests.

* Installation

Build the QuickThreads library (see above) and then copy `libqt.a' to
the installation library directory (e.g., /usr/local/lib) and `qt.h'
and `qtmd.h' to the installation include directory (e.g.,
/usr/local/include).

path: qt/INSTALL


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 1998, 2000, 2006 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE 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.
##
##   GUILE 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 GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

## subdirs are for making distributions only.
SUBDIRS = md time

lib_LTLIBRARIES = @QTHREAD_LTLIBS@
EXTRA_LTLIBRARIES = libqthreads.la

## Prevent automake from adding extra -I options
DEFS = @DEFS@
INCLUDES = -I.. -I$(srcdir)/..

libqthreads_la_SOURCES = qt.c copyright.h
libqthreads_la_LIBADD = qtmds.lo qtmdc.lo
libqthreads_la_DEPENDENCIES = qtmds.lo qtmdc.lo
libqthreads_la_LDFLAGS = -rpath $(libdir) -export-dynamic -no-undefined \
  -version-info @LIBQTHREADS_INTERFACE@

# Seems to be obsolete - autogen.sh is giving:
# invalid unused variable name: `OMIT_DEPENDENCIES'
#OMIT_DEPENDENCIES = axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h

.s.lo:
	$(LIBTOOL) --mode=compile $(COMPILE) $(qthread_asflags) -c $<
qtmds.s:
	${LN_S} ${srcdir}/${qtmds_s} qtmds.s
qtmdc.c:
	${LN_S} ${srcdir}/${qtmdc_c} qtmdc.c
qtdmdb.s:
	${LN_S} ${srcdir}/${qtdmdb_s} qtdmdb.s

EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \
	Makefile.base config libqthreads.def


code:
.SUFFIXES: .c .o .s .E

#
# Need to include from the current directory because "qt.h"
# will include <qtmd.h>.
#
CFLAGS	      = -I. -g

#
# Fix this to be something meaningful for your system.
#
DEST	      = /dev/null

DOC	      =	users.tout

EXTHDRS	      = /usr/include/stdio.h

HDRS	      = qt.h \
		qtmd.h \
		stp.h

LDFLAGS	      = $(CFLAGS)

EXTLIBS       =

LIBS	      = libstp.a libqt.a

LINKER	      = $(CC)

MAKEFILE      = Makefile

M	      =	Makefile configuration

OBJS	      = qtmdb.o \
		meas.o

QTOBJS	      =	qt.o qtmds.o qtmdc.o

STPOBJS	      =	stp.o

PR	      =	-Pps

PRINT	      = pr

PROGRAM	      = run

SRCS	      = meas.c \
		qt.c \
		qtmdc.c \
		qtmds.s \
		qtmdb.s

TMP_INIT      =	tmp.init
TMP_SWAP      =	tmp.swap

.DEFAULT:
		co -q $@

.c.E:		force
		$(CC) $(CFLAGS) -E $*.c > $*.E

all:		libqt.a libstp.a $(PROGRAM) $(M)

libqt.a:	$(QTOBJS) $(M)
		ar crv libqt.a $(QTOBJS)
		ranlib libqt.a

libstp.a:	$(STPOBJS) $(M)
		ar crv libstp.a $(STPOBJS)
		ranlib libstp.a

$(PROGRAM):     $(OBJS) $(LIBS) $(M)
		@echo "Loading $(PROGRAM) ... "
#		ld -o $(PROGRAM) /lib/crt0.o $(OBJS) -lc
		$(LINKER) $(LDFLAGS) $(OBJS) $(LIBS) $(EXTLIBS) -o $(PROGRAM)
		@echo "done"

clean:
		rm -f $(OBJS) $(PROGRAM) $(TMP_INIT) $(TMP_SWAP) $(DOC)
		rm -f libqt.a libstp.a
		rm -f $(QTOBJS) $(STPOBJS)

depend:;	@mkmf -f $(MAKEFILE) PROGRAM=$(PROGRAM) DEST=$(DEST)

doc:		users.ms raw
		time/assim < raw | grep "^init" | sed 's/^init //' > $(TMP_INIT)
		time/assim < raw | grep "^swap" | sed 's/^swap //' > $(TMP_SWAP)
		soelim users.ms | tbl $(PR) | troff -t $(PR) -ms > $(DOC)

index:;		@ctags -wx $(HDRS) $(SRCS)

print:;		@$(PRINT) $(HDRS) $(SRCS)

program:        $(PROGRAM)

tags:           $(HDRS) $(SRCS); @ctags $(HDRS) $(SRCS)

update:		$(DEST)/$(PROGRAM)

$(DEST)/$(PROGRAM): $(SRCS) $(LIBS) $(HDRS) $(EXTHDRS)
		@make -f $(MAKEFILE) DEST=$(DEST) install

QT_H =		qt.h $(QTMD_H)
QTMD_H =	qtmd.h

###
qtmdb.o: $(M) qtmdb.s b.h
meas.o: $(M) meas.c /usr/include/stdio.h $(QT_H) b.h stp.h
qt.o: $(M) qt.c $(QT_H)
stp.o: $(M) stp.c stp.h $(QT_H)
qtmds.o: $(M) qtmds.s
qtmdc.o: $(M) qtmdc.c $(QT_H)


code:
This is a source code distribution for QuickThreads.  QuickThreads is a
toolkit for building threads packages; it is described in detail in the
University of Washington CS&E Technical report #93-05-06, available via
anonymous ftp from `ftp.cs.washington.edu' (128.95.1.4, as of Oct. '94)
in `tr/1993/05/UW-CSE-93-05-06.PS.Z'.

This distribution shows basic ideas in QuickThreads and elaborates with
example implementations for a gaggle of machines.  As of October those
machines included:

	80386 faimly
	88000 faimily
	DEC AXP (Alpha) family
	HP-PA family
	KSR
	MIPS family
	SPARC V8 family
	VAX family

Configuration, build, and installation are described in INSTALL.

Be aware: that there is no varargs code for the KSR.

The HP-PA port was designed to work with both HP workstations
and Convex SPP computers. It was generously provided by Uwe Reder
<uereder@cip.informatik.uni-erlangen.de>. It is part of the ELiTE
(Erlangen Lightweight Thread Environment) project directed by
Frank Bellosa <bellosa@informatik.uni-erlangen.de> at the Operating
Systems Department of the University of Erlangen (Germany).

Other contributors include: Weihaw Chuang, Richard O'Keefe,
Laurent Perron, John Polstra, Shinji Suzuki, Assar Westerlund,
thanks also to Peter Buhr and Dirk Grunwald.

Here is a brief summary:

QuickThreads is a toolkit for building threads packages.  It is my hope
that you'll find it easier to use QuickThreads normally than to take it
and modify the raw cswap code to fit your application.  The idea behind
QuickThreads is that it should make it easy for you to write & retarget
threads packages.  If you want the routine `t_create' to create threads
and `t_block' to suspend threads, you write them using the QuickThreads
`primitive' operations `QT_SP', `QT_INIT', and `QT_BLOCK', that perform
machine-dependent initialization and blocking, plus code you supply for
performing the portable operatons.  For example, you might write:

	t_create (func, arg)
	{
	  stk = malloc (STKSIZE);
	  stackbase = QT_SP (stk, STKSIZE);
	  sp = QT_INIT (stakcbase, func, arg);
	  qput (runq, sp);
	}

Threads block by doing something like:

	t_block()
	{
	  sp_next = qget (runq);
	  QT_BLOCK (helper, runq, sp_next);
	  // wake up again here
	}

	// called by QT_BLOCK after the old thread has blocked,
	// puts the old thread on the queue `onq'.
	helper (sp_old, onq)
	{
	  qput (onq, sp_old);
	}

(Of course) it's actually a bit more complex than that, but the general
idea is that you write portable code to allocate stacks and enqueue and
dequeue threads.  Than, to get your threads package up and running on a
different machine, you just reconfigure QuickThreads and recompile, and
that's it.

The QuickThreads `distribution' includes a sample threads package (look
at stp.{c,h}) that is written in terms of QuickThreads operations.  The
TR mentioned above explains the simple threads package in detail.

If you do use QuickThreads, I'd like to hear both about what worked for
you and what didn't work, problems you had, insights gleaned, etc.

Let me know what you think.

David Keppel <pardo@cs.washington.edu>

path: qt/README


code:
Here's some machine-specific informatin for various systems:

m88k on g88.sim

	.g88init:
		echo (gdb) target sim\n
		target sim
		echo (gdb) ecatch all\n
		ecatch all
		echo (gdb) break exit\n
		break exit
	% vi Makefile		// set CC and AS
	% setenv MEERKAT /projects/cer/meerkat
	% set path=($MEERKAT/bin $path)
	% make run
	% g88.sim run
	(g88) run run N		// where `N' is the test number

m88k on meerkats, cross compile as above (make run)

	Run w/ g88:
	%g88 run
	(g88) source /homes/rivers/robertb/.gdbinit
	(g88) me
	which does
	(g88) set $firstchars=6
	(g88) set $resetonattach=1
	(g88) attach /dev/pp0
	then download
	(g88) dl
	and run with
	(g88) continue

	Really the way to run it is:
	(g88) source
	(g88) me
	(g88) win
	(g88) dead 1
	(g88) dead 2
	(g88) dead 3
	(g88) dl
	(g88) cont

	To rerun
	(g88) init
	(g88) dl

	To run simulated meerkat:
	(g88) att sim
	<<then use normal commands>>

	On 4.5 g88:
	(g88) target sim memsize
	instead of attatch
	(g88) ecatch all	# catch exception before becomes error


code:
Date: Tue, 11 Jan 94 13:23:11 -0800
From: "pardo@cs.washington.edu" <pardo@meitner.cs.washington.edu>

>[What's needed to get `qt' on an i860-based machine?]

Almost certainly "some assembly required" (pun accepted).

To write a cswap port, you need to understand the context switching
model.  Turn to figure 2 in the QT TR.  Here's about what the assembly
code looks like to implement that:

	qt_cswap:
		adjust stack pointer
		save callee-save registers on to old's stack
		argument register <- old sp
		sp <- new sp
		(*helper)(args...)
		restore callee-save registers from new's stack
		unadjust stack pointer
		return

Once more in slow motion:

	- `old' thread calls context switch routine (new, a0, a1, h)
	- cswap routine saves registers that have useful values
	- cswap routine switches to new stack
	- cswap routine calls helper function (*h)(old, a0, a1)
	- when helper returns, cswap routine restores registers
	  that were saved the last time `new' was suspended
	- cswap routine returns to whatever `new' routine called the
	  context switch routine

There's a few tricks here.  First, how do you start a thread running
for the very first time?  Answer is: fake some stuff on the stack
so it *looks* like it was called from the middle of some routine.
When the new thread is restarted, it is treated like any other
thread.  It just so happens that it's never really run before, but
you can't tell that because the saved state makes it look like like
it's been run.  The return pc is set to point at a little stub of
assembly code that loads up registers with the right values and
then calls `only'.

Second, I advise you to forget about varargs routines (at least
until you get single-arg routines up and running).

Third, on most machines `qt_abort' is the same as `qt_cswap' except
that it need not save any callee-save registers.

Fourth, `qt_cswap' needs to save and restore any floating-point
registers that are callee-save (see your processor handbook).  On
some machines, *no* floating-point registers are callee-save, so
`qt_cswap' is exactly the same as the integer-only cswap routine.

I suggest staring at the MIPS code for a few minutes.  It's "mostly"
generic RISC code, so it gets a lot of the flavor across without
getting too bogged down in little nitty details.

Now for a bit more detail:  The stack is laid out to hold callee-save
registers.  On many machines, I implemented fp cswap as save fp
regs, call integer cswap, and when integer cswap returns (when the
thread wakes up again), restore fp regs.

For thread startup, I figure out some callee-save registers that
I use to hold parameters to the startup routine (`only').  When
the thread is being started it doesn't have any saved registers
that need to be restored, but I go ahead and let the integer context
switch routine restore some registers then "return" to the stub
code.  The stub code then copies the "callee save" registers to
argument registers and calls the startup routine.  That keeps the
stub code pretty darn simple.

For each machine I need to know the machine's procedure calling
convention before I write a port.  I figure out how many callee-save
registers are there and allocate enough stack space for those
registers.  I also figure out how parameters are passed, since I
will need to call the helper function.  On most RISC machines, I
just need to put the old sp in the 0'th arg register and then call
indirect through the 3rd arg register; the 1st and 2nd arg registers
are already set up correctly.  Likewise, I don't touch the return
value register between the helper's return and the context switch
routine's return.

I have a bunch of macros set up to do the stack initialization.
The easiest way to debug this stuff is to go ahead and write a C
routine to do stack initialization.  Once you're happy with it you
can turn it in to a macro.

In general there's a lot of ugly macros, but most of them do simple
things like return constants, etc.  Any time you're looking at it
and it looks confusing you just need to remember "this is actually
simple code, the only tricky thing is calling the helper between
the stack switch and the new thread's register restore."

You will almost certainly need to write the assembly code fragment
that starts a thread.  You might be able to do a lot of the context
switch code with `setjmp' and `longjmp', if they *happen* to have
the "right" implementation.  But getting all the details right (the
helper can return a value to the new thread's cswap routine caller)
is probaby trickier than writing code that does the minimum and
thus doesn't have any extra instructions (or generality) to cause
problems.

I don't know of any ports besides those included with the source
code distribution.   If you send me a port I will hapily add it to
the distribution.

Let me know as you have questions and/or comments.

	;-D on  ( Now *that*'s a switch... )  Pardo


code:
#ifndef B_H
#define B_H	"$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/b.h,v 1.1 1996-10-01 03:27:25 mdj Exp $"

#include "copyright.h"

extern void b_call_reg (int n);
extern void b_call_imm (int n);
extern void b_add (int n);
extern void b_load (int n);

#endif /* ndef B_H */


code:
#! /bin/sh -x

rm -f Makefile Makefile.md README.md qtmd.h qtmdb.s qtmdc.c qtmds.s configuration

case $1 in
	axp*)
		: "DEC AXP"
		case $1 in
			axp-osf1*)
				: "Compile using /bin/cc under OSF 1.x."
				ln -s md/axp.1.Makefile Makefile.md
				;;
			axp-osf2*)
				: "Compile using /bin/cc under OSF 2.x."
				ln -s md/axp.1.Makefile Makefile.md
				;;
			*)
				: "Compile using GNU CC."
				ln -s md/axp.Makefile Makefile.md
				;;
		esac

		ln -s md/axp.h qtmd.h
		ln -s md/axp.c qtmdc.c
		ln -s md/axp.s qtmds.s
		ln -s md/axp_b.s qtmdb.s
		ln -s md/axp.README README.md
		iter_init=1000000000
		iter_runone=10000000
		iter_blockint=10000000
		iter_blockfloat=10000000
		iter_vainit0=10000000
		iter_vainit2=10000000
		iter_vainit4=10000000
		iter_vainit8=10000000
		iter_vastart0=10000000
		iter_vastart2=10000000
		iter_vastart4=10000000
		iter_vastart8=10000000
		iter_bench_call_reg=10000000
		iter_bench_call_imm=10000000
		iter_bench_add=100000000
		iter_bench_load=100000000
		;;

       hppa*)
		: "HP's PA-RISC 1.1 processors."

		case $1 in
			hppa-cnx-spp*)
				: "Convex SPP (PA-RISC 1.1 processors)."
				ln -s md/hppa-cnx.Makefile Makefile.md
				;;
			*)
				ln -s md/hppa.Makefile Makefile.md
				;;
		esac

		ln -s md/hppa.h qtmd.h
		ln -s md/null.c qtmdc.c
		ln -s md/hppa.s qtmds.s
		ln -s md/hppa_b.s qtmdb.s
		iter_init=10000000
		iter_runone=1000000
		iter_blockint=1000000
		iter_blockfloat=1000000
		iter_vainit0=1000000
		iter_vainit2=1000000
		iter_vainit4=1000000
		iter_vainit8=1000000
		iter_vastart0=1000000
		iter_vastart2=1000000
		iter_vastart4=1000000
		iter_vastart8=1000000
		iter_bench_call_reg=10000000
		iter_bench_call_imm=10000000
		iter_bench_add=100000000
		iter_bench_load=100000000
		;;

	iX86*)
		case $1 in
			iX86-ss*)
				: "Assemlber comments '//'"
				sed 's/\/\*/\/\//' < md/i386.s > qtmds.s
				sed 's/\/\*/\/\//' < md/i386_b.s > qtmdb.s
				;;

			*)
				ln -s md/i386.s qtmds.s
				ln -s md/i386_b.s qtmdb.s
				;;
		esac
		: "Intel 80386 and compatibles (not '286...)"
		ln -s md/default.Makefile Makefile.md
		ln -s md/i386.h qtmd.h
		ln -s md/null.c qtmdc.c
		ln -s md/i386.README README.md
		iter_init=10000000
		iter_runone=1000000
		iter_blockint=1000000
		iter_blockfloat=1000000
		iter_vainit0=1000000
		iter_vainit2=1000000
		iter_vainit4=1000000
		iter_vainit8=1000000
		iter_vastart0=1000000
		iter_vastart2=1000000
		iter_vastart4=1000000
		iter_vastart8=1000000
		iter_bench_call_reg=1000000
		iter_bench_call_imm=1000000
		iter_bench_add=100000000
		iter_bench_load=10000000
		;;

	m68k)
		: "Motorola 68000 family -- incomplete!"
		ln -s md/default.Makefile Makefile.md
		ln -s md/m68k.h qtmd.h
		ln -s md/null.c qtmdc.c
		ln -s md/m68k.s qtmds.s
		ln -s md/m68k_b.s qtmdb.s
		ln -s md/null.README README.md
		;;

	m88k)
		: "Motorola 88000 family"
		ln -s md/m88k.Makefile Makefile.md
		ln -s md/m88k.h qtmd.h
		ln -s md/m88k.c qtmdc.c
		ln -s md/m88k.s qtmds.s
		ln -s md/m88k_b.s qtmdb.s
		ln -s md/null.README README.md
		iter_init=1000000
		iter_runone=100000
		iter_blockint=100000
		iter_blockfloat=100000
		iter_vainit0=100000
		iter_vainit2=100000
		iter_vainit4=100000
		iter_vainit8=100000
		iter_vastart0=100000
		iter_vastart2=100000
		iter_vastart4=100000
		iter_vastart8=100000
		iter_bench_call_reg=100000000
		iter_bench_call_imm=100000000
		iter_bench_add=1000000000
		iter_bench_load=100000000
		;;

	mips*)
		: "MIPS R2000 and R3000."

		case $1 in
			mips-irix[56]*)
				: "Silicon Graphics Irix with dynamic linking"
				: "Use mips for irix4."
				ln -s md/mips-irix5.s qtmds.s
				;;
			*)
				ln -s md/mips.s qtmds.s
				;;
		esac

		ln -s md/default.Makefile Makefile.md
		ln -s md/mips.h qtmd.h
		ln -s md/null.c qtmdc.c
		ln -s md/mips_b.s qtmdb.s
		ln -s md/null.README README.md
		iter_init=10000000
		iter_runone=10000000
		iter_blockint=10000000
		iter_blockfloat=10000000
		iter_vainit0=1000000
		iter_vainit2=1000000
		iter_vainit4=1000000
		iter_vainit8=1000000
		iter_vastart0=1000000
		iter_vastart2=1000000
		iter_vastart4=1000000
		iter_vastart8=1000000
		iter_bench_call_reg=100000000
		iter_bench_call_imm=100000000
		iter_bench_add=1000000000
		iter_bench_load=100000000
		;;

	sparc*)
		: "SPARC processors"
		case $1 in
			sparc-os2*)
				sed 's/_qt_/qt_/' md/sparc.s > qtmds.s
				sed 's/_b_/b_/' md/sparc_b.s > qtmdb.s
				ln -s md/solaris.README README.md
				;;
			*)
				ln -s md/sparc.s qtmds.s
				ln -s md/sparc_b.s qtmdb.s
				ln -s md/null.README README.md
				;;
		esac

		ln -s md/default.Makefile Makefile.md
		ln -s md/sparc.h qtmd.h
		ln -s md/null.c qtmdc.c
		iter_init=10000000
		iter_runone=1000000
		iter_blockint=1000000
		iter_blockfloat=1000000
		iter_vainit0=1000000
		iter_vainit2=1000000
		iter_vainit4=1000000
		iter_vainit8=1000000
		iter_vastart0=1000000
		iter_vastart2=1000000
		iter_vastart4=1000000
		iter_vastart8=1000000
		iter_bench_call_reg=10000000
		iter_bench_call_imm=10000000
		iter_bench_add=100000000
		iter_bench_load=100000000
		;;

	vax*)
		: "DEC VAX processors."
		ln -s md/default.Makefile Makefile.md
		ln -s md/vax.h qtmd.h
		ln -s md/null.c qtmdc.c
		ln -s md/vax.s qtmds.s
		ln -s md/vax_b.s qtmdb.s
		ln -s md/null.README README.md
		iter_init=1000000
		iter_runone=100000
		iter_blockint=100000
		iter_blockfloat=100000
		iter_vainit0=100000
		iter_vainit2=100000
		iter_vainit4=100000
		iter_vainit8=100000
		iter_vastart0=100000
		iter_vastart2=100000
		iter_vastart4=100000
		iter_vastart8=100000
		iter_bench_call_reg=10000000
		iter_bench_call_imm=10000000
		iter_bench_add=10000000
		iter_bench_load=1000000
		;;

	ksr1)
		: "Kendall Square Research model KSR-1."
		: "Varargs is not currently supported."
		ln -s md/ksr1.Makefile Makefile.md
		ln -s md/ksr1.h qtmd.h
		ln -s md/null.c qtmdc.c
		ln -s md/ksr1.s qtmds.s
		ln -s md/ksr1_b.s qtmdb.s
		ln -s md/null.README README.md
		iter_init=1000000
		iter_runone=100000
		iter_blockint=100000
		iter_blockfloat=100000
		iter_vainit0=100000
		iter_vainit2=100000
		iter_vainit4=100000
		iter_vainit8=100000
		iter_vastart0=100000
		iter_vastart2=100000
		iter_vastart4=100000
		iter_vastart8=100000
		iter_bench_call_reg=10000000
		iter_bench_call_imm=10000000
		iter_bench_add=10000000
		iter_bench_load=1000000
		;;

	clean)
		: Deconfigure
		exit 0
		;;

	*)
		echo "Unknown configuration"
		exit 1
		;;
esac

cat Makefile.md Makefile.base > Makefile

echo set config_machine=$1 >> configuration
echo set config_init=$iter_init >> configuration
echo set config_runone=$iter_runone >> configuration
echo set config_blockint=$iter_blockint >> configuration
echo set config_blockfloat=$iter_blockfloat >> configuration
echo set config_vainit0=$iter_vainit0 >> configuration
echo set config_vainit2=$iter_vainit2 >> configuration
echo set config_vainit4=$iter_vainit4 >> configuration
echo set config_vainit8=$iter_vainit8 >> configuration
echo set config_vastart0=$iter_vastart0 >> configuration
echo set config_vastart2=$iter_vastart2 >> configuration
echo set config_vastart4=$iter_vastart4 >> configuration
echo set config_vastart8=$iter_vastart8 >> configuration
echo set config_bcall_reg=$iter_bench_call_reg >> configuration
echo set config_bcall_imm=$iter_bench_call_imm >> configuration
echo set config_b_add=$iter_bench_add >> configuration
echo set config_b_load=$iter_bench_load >> configuration

path: qt/config


code:
/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 *
 * 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 and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */


code:
LIBRARY			libqthreads
DESCRIPTION		"libqthreads: QuickThreads Library"
EXPORTS
	qt_abort
	qt_block
	qt_blocki
	qt_error
	qt_null
	qt_vargs
	qt_vstart


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 1998, 2002, 2006 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE 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.
##
##   GUILE 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 GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \
axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \
hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \
i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \
m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \
mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \
vax.h vax.s vax_b.s i386.asm arm.h arm.s


code:
/* sparc.s -- assembly support for the `qt' thread building kit. */

/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 *
 * 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 and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */

/* #include <machine/trap.h> */

	.text
	.align 4
	.global _qt_blocki
	.global _qt_block
	.global _qt_abort
	.global _qt_start
	.global _qt_vstart

/* Register assignment:
// %o0:	incoming `helper' function to call after cswap
//	also used as outgoing sp of old thread (qt_t *)
// %o1, %o2:
//	parameters to `helper' function called after cswap
// %o3:	sp of new thread
// %o5: tmp used to save old thread sp, while using %o0
//	to call `helper' f() after cswap.
//
//
// Aborting a thread is easy if there are no cached register window
// frames: just switch to the new stack and away we go.  If there are
// cached register window frames they must all be written back to the
// old stack before we move to the new stack.  If we fail to do the
// writeback then the old stack memory can be written with register
// window contents e.g., after the stack memory has been freed and
// reused.
//
// If you don't believe this, try setting the frame pointer to zero
// once we're on the new stack.  This will not affect correctnes
// otherwise because the frame pointer will eventually get reloaded w/
// the new thread's frame pointer.  But it will be zero briefly before
// the reload.  You will eventually (100,000 cswaps later on a small
// SPARC machine that I tried) get an illegal instruction trap  from
// the kernel trying to flush a cached window to location 0x0.
//
// Solution: flush windows before switching stacks, which invalidates
// all the other register windows.  We could do the trap
// conditionally: if we're in the lowest frame of a thread, the fp is
// zero already so we know there's nothing cached.  But we expect most
// aborts will be done from a first function that does a `save', so we
// will rarely save anything and always pay the cost of testing to see
// if we should flush.
//
// All floating-point registers are caller-save, so this routine
// doesn't need to do anything to save and restore them.
//
// `qt_block' and `qt_blocki' return the same value as the value
// returned by the helper function.  We get this ``for free''
// since we don't touch the return value register between the
// return from the helper function and return from qt_block{,i}.
*/

_qt_block:
_qt_blocki:
	sub %sp, 8, %sp		/* Allocate save area for return pc. */
	st %o7, [%sp+64]	/* Save return pc. */
_qt_abort:
	ta 0x03			/* Save locals and ins. */
	mov %sp, %o5		/* Remember old sp w/o chng ins/locals. */
	sub %o3, 64, %sp	/* Allocate kwsa, switch stacks. */
	call %o0, 0		/* Call `helper' routine. */
	mov %o5, %o0		/* Pass old thread to qt_after_t() */
				/* .. along w/ args in %o1 & %o2. */

	/* Restore callee-save regs.  The kwsa
	// is on this stack, so offset all
	// loads by sizeof(kwsa), 64 bytes.
	*/
	ldd [%sp+ 0+64], %l0
	ldd [%sp+ 8+64], %l2
	ldd [%sp+16+64], %l4
	ldd [%sp+24+64], %l6
	ldd [%sp+32+64], %i0
	ldd [%sp+40+64], %i2
	ldd [%sp+48+64], %i4
	ldd [%sp+56+64], %i6
	ld [%sp+64+64], %o7	/* Restore return pc. */

	retl			/* Return to address in %o7. */
	add %sp, 72, %sp	/* Deallocate kwsa, ret pc area. */

/* The function calling conventions say there has to be a 1-word area
// in the caller's stack to hold a pointer to space for aggregate
// return values.  It also says there should be a 6-word area to hold
// %o0..%o5 if the callee wants to save them (why?  I don't know...)
// Round up to 8 words to maintain alignment.
//
// Parameter values were stored in callee-save regs and are moved to
// the parameter registers.
*/
_qt_start:
	mov %i1, %o0		/* `pu': Set up args to `only'. */
	mov %i2, %o1		/* `pt'. */
	mov %i4, %o2		/* `userf'. */
	call %i5, 0		/* Call client function. */
	sub %sp, 32, %sp	/* Allocate 6-word callee space. */

	call _qt_error, 0	/* `only' erroniously returned. */
	nop

/* Same comments as `_qt_start' about allocating rounded-up 7-word
// save areas. */

_qt_vstart:
	sub %sp, 32, %sp	/* Allocate 7-word callee space. */
	call %i5, 0		/* call `startup'. */
	mov %i2, %o0		/* .. with argument `pt'. */

	add %sp, 32, %sp	/* Use 7-word space in varargs. */
	ld [%sp+ 4+64], %o0	/* Load arg0 ... */
	ld [%sp+ 8+64], %o1
	ld [%sp+12+64], %o2
	ld [%sp+16+64], %o3
	ld [%sp+20+64], %o4
	call %i4, 0		/* Call `userf'. */
	ld [%sp+24+64], %o5

				/* Use 6-word space in varargs. */
	mov %o0, %o1		/* Pass return value from userf */
	call %i3, 0		/* .. when call `cleanup. */
	mov %i2, %o0		/* .. along with argument `pt'. */

	call _qt_error, 0	/* `cleanup' erroniously returned. */
	nop


code:
/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 *
 * 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 and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */

	.globl _b_call_reg
	.globl _b_call_imm
	.globl _b_add
	.globl _b_load

_b_null:
	retl
	nop

_b_call_reg:
	sethi %hi(_b_null),%o4
	or %o4,%lo(_b_null),%o4
	add %o7,%g0, %o3
L0:
	call %o4
	nop
	call %o4
	nop
	call %o4
	nop
	call %o4
	nop
	call %o4
	nop

	subcc %o0,1,%o0
	bg L0
	nop
	add %o3,%g0, %o7
	retl
	nop

_b_call_imm:
	sethi %hi(_b_null),%o4
	or %o4,%lo(_b_null),%o4
	add %o7,%g0, %o3
L1:
	call _b_null
	call _b_null
	call _b_null
	call _b_null
	call _b_null

	subcc %o0,1,%o0
	bg L0
	nop
	add %o3,%g0, %o7
	retl
	nop

_b_add:
	add %o0,%g0,%o1
	add %o0,%g0,%o2
	add %o0,%g0,%o3
	add %o0,%g0,%o4
L2:
	sub %o0,5,%o0
	sub %o1,5,%o1
	sub %o2,5,%o2
	sub %o3,5,%o3
	sub %o4,5,%o4

	subcc %o0,5,%o0
	sub %o1,5,%o1
	sub %o2,5,%o2
	sub %o3,5,%o3
	sub %o4,5,%o4

	bg L2
	nop
	retl
	nop

_b_load:
	ld [%sp+ 0], %g0
L3:
	ld [%sp+ 4],%g0
	ld [%sp+ 8],%g0
	ld [%sp+12],%g0
	ld [%sp+16],%g0
	ld [%sp+20],%g0
	ld [%sp+24],%g0
	ld [%sp+28],%g0
	ld [%sp+32],%g0
	ld [%sp+36],%g0

	subcc %o0,10,%o0
	bg L3
	ld [%sp+ 0],%g0
	retl
	nop


code:
/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 * Copyright (c) 2002 by Marius Vollmer
 *
 * 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 and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */

#ifndef QT_ARM_H
#define QT_ARM_H

typedef unsigned long qt_word_t;

#define QT_GROW_DOWN

/* Stack layout on the ARM:

   Callee-save registers are: r4-r11 (f4-f7)
   Also save r14, link register, and restore as pc.

   +---
   | lr/pc
   | r11
   | r10
   | r9
   | r8
   | r7
   | r6
   | r5
   | r4      <- sp of a suspended thread
   +---

   Startup:

   +---
   | only
   | user
   | argt
   | argu    <- sp on entry to qt_start
   +---
   | pc      == qt_start
   | r11
   | r10
   | r9
   | r8
   | r7
   | r6
   | r5
   | r4
   +---

*/

/* Stack must be word aligned. */
#define QT_STKALIGN	(4)	/* Doubleword aligned. */

/* How much space is allocated to hold all the crud for
   initialization: r4-r11, r14, and the four args for qt_start. */

#define QT_STKBASE	((9+4)*4)

/* Offsets of various registers, in words, relative to final value of SP. */
#define QT_LR           8
#define QT_11           7
#define QT_10           6
#define QT_9            5
#define QT_8            4
#define QT_7            3
#define QT_6            2
#define QT_5            1
#define QT_4            0

/* When a never-before-run thread is restored, the return pc points
   to a fragment of code that starts the thread running.  For
   non-vargs functions, it just calls the client's `only' function.
 */

extern void qt_start(void);
#define QT_ARGS_MD(sp)	(QT_SPUT (sp, QT_LR, qt_start))

/* The *index* (positive offset) of where to put each value. */
#define QT_ONLY_INDEX	(12)
#define QT_USER_INDEX	(11)
#define QT_ARGT_INDEX	(10)
#define QT_ARGU_INDEX	(9)

#endif /* ndef QT_ARM_H */


code:
	.text
	.align	2
    	.global	qt_abort
    	.global	qt_block
       	.global	qt_blocki

	# r0:	helper
	# r1:	arg1
	# r2:	arg2
	# r3:	new_sp
qt_abort:
qt_block:
qt_blocki:
	stmfd	sp!, {r4-r11,lr}
	mov	ip, r0
	mov	r0, sp
	mov     sp, r3
	mov	lr, pc
	mov	pc, ip
	ldmfd	sp!, {r4-r11,pc}

	.global qt_start
	.global qt_error
	.type	qt_start,function
qt_start:
	ldr     r0, [sp]
    	ldr     r1, [sp, #4]
    	ldr     r2, [sp, #8]
        ldr     lr, qt_error_loc
	ldr     pc, [sp, #12]

qt_error_loc:
	.word qt_error


code:
#
# Compiling for the DEC AXP (alpha) with GNU CC or version 1.x of OSF.
#
CC	      =	cc -std1 -D__AXP__ -D__OSF1__


code:
#
# Compiling for the DEC AXP (alpha) with GNU CC or version 2.x of OSF.
#
CC	      =	cc -std1 -D__AXP__ -D__OSF2__


code:
The handling of varargs is platform-dependent.  Assar Westerlund
stared at the problem for a while and deduces the following table:

vers / compiler         cc              gcc
----------------------------------------------------------------------
1.3                     a0, offset      __base, __offset
2.0                     _a0, _offset    __base, __offset

The current code should handle both cc and gcc versions, provided
you configure for the correct compiler.


code:
/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 *
 * 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 and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */

#include <stdarg.h>
#include "qt.h"

/* Varargs is harder on the AXP.  Parameters are saved on the stack as
   something like (stack grows down to low memory; low at bottom of
   picture):

	|  :
	| arg6
	+---
	| iarg5
	|  :
	| iarg3		<-- va_list._a0 + va_list._offset
	|  :
	| iarg0		<-- va_list._a0
	+---
	| farg5
	|  :
	| farg0
	+---

   When some of the arguments have known type, there is no need to
   save all of them in the struct.  So, for example, if the routine is
   called

	zork (int a0, float a1, int a2, ...)
	{
	  va_list ap;
	  va_start (ap, a2);
	  qt_vargs (... &ap ...);
	}

   then offset is set to 3 * 8 (8 === sizeof machine word) = 24.

   What this means for us is that the user's routine needs to be
   called with an arg list where some of the words in the `any type'
   parameter list have to be split and moved up in to the int/fp
   region.

   Ways in which this can fail:
    - The user might not know the size of the pushed arguments anyway.
    - Structures have funny promotion rules.
    - Probably lots of other things.

   All in all, we never promised varargs would work reliably. */

#define QT_VADJ(sp)	(((char *)sp) - QT_VSTKBASE)

#define QT_VARGS_MD0(sp, vabytes) \
   ((qt_t *)(((char *)(sp)) - 6*2*8 - QT_STKROUNDUP(vabytes)))

extern void qt_vstart(void);
#define QT_VARGS_MD1(sp)	(QT_SPUT (sp, QT_R26, qt_vstart))

/* Different machines use different implementations for varargs.
   Unfortunately, the code below ``looks in to'' the varargs
   structure, `va_list', and thus depends on the conventions.
   The following #defines try to deal with it but don't catch
   everything. */

#ifdef __GNUC__
#define _a0		__base
#define _offset		__offset
#else
#ifdef __OSF1__
#define _a0		a0
#define _offset		offset
#endif
#endif /* def __GNUC__ */

  struct qt_t *
qt_vargs (struct qt_t *qsp, int nbytes, struct va_list *vargs,
	  void *pt, qt_function_t *startup,
	  qt_function_t *vuserf, qt_function_t *cleanup)
{
  va_list ap;
  int i;
  int max;		/* Maximum *words* of args to copy. */
  int tmove;		/* *Words* of args moved typed->typed. */
  qt_word_t *sp;

  ap = *(va_list *)vargs;
  qsp = QT_VARGS_MD0 (qsp, nbytes);
  sp = (qt_word_t *)qsp;

  tmove = 6 - ap._offset/sizeof(qt_word_t);

  /* Copy from one typed area to the other. */
  for (i=0; i<tmove; ++i) {
    /* Integer args: */
    sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
    /* Fp args: */
    sp[i] = ((qt_word_t *)(ap._a0 + ap._offset))[i-6];
  }

  max = nbytes/sizeof(qt_word_t);

  /* Copy from the untyped area to the typed area.  Split each arg.
     in to integer and floating-point save areas. */
  for (; i<6 && i<max; ++i) {
    sp[i] = sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
  }

  /* Copy from the untyped area to the other untyped area. */
  for (; i<max; ++i) {
    sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
  }

  QT_VARGS_MD1 (QT_VADJ(sp));
  QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
  QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
  QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
  QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
  return ((qt_t *)QT_VADJ(sp));
}


code:
/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 *
 * 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 and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */

#ifndef QT_AXP_H
#define QT_AXP_H

#define QT_GROW_DOWN

typedef unsigned long qt_word_t;

/* Stack layout on the Alpha:

   Integer:

     Caller-save: r0..r8, r22..r25, r27..r29
     argument/caller-save: r16..r21
     callee-save: r9..r15
     return pc *callee-save*: r26
     stack pointer: r30
     zero: r31

   Floating-point:

     Caller-save: f0..f1, f10..f15
     argument/caller-save: f16..f21, f22..f30
     callee-save: f2..f9
     zero: f31

   Non-varargs:

   +---
   | padding
   | f9
   | f8
   | f7
   | f6
   | f5
   | f4
   | f3
   | f2
   | r26
   +---
   | padding
   | r29
   | r15
   | r14
   | r13
   | r12	on startup === `only'
   | r11	on startup === `userf'
   | r10	on startup === `qt'
   | r9		on startup === `qu'
   | r26	on startup === qt_start		<--- qt.sp
   +---

   Conventions for varargs startup:

   |  :
   | arg6
   | iarg5
   |  :
   | iarg0
   | farg5
   |  :
   | farg0
   +---
   | padding
   | r29
   | r15
   | r14
   | r13
   | r12	on startup === `startup'
   | r11	on startup === `vuserf'
   | r10	on startup === `cleanup'
   | r9		on startup === `qt'
   | r26	on startup === qt_vstart	<--- qt.sp
   +---

   Note: this is a pretty cheap/sleazy way to get things going,
   but ``there must be a better way.''  For instance, some varargs
   parameters could be loaded in to integer registers, or the return
   address could be stored on top of the stack. */

/* Stack must be 16-byte aligned. */
#define QT_STKALIGN	(16)

/* How much space is allocated to hold all the crud for
   initialization: 7 registers times 8 bytes/register. */

#define QT_STKBASE	(10 * 8)
#define QT_VSTKBASE	QT_STKBASE

/* Offsets of various registers. */
#define QT_R26	0
#define QT_R9	1
#define QT_R10	2
#define QT_R11	3
#define QT_R12	4

/* When a never-before-run thread is restored, the return pc points
   to a fragment of code that starts the thread running.  For
   non-vargs functions, it just calls the client's `only' function.
   For varargs functions, it calls the startup, user, and cleanup
   functions.

   The varargs startup routine always reads 12 8-byte arguments from
   the stack.  If fewer argumets were pushed, the startup routine
   would read off the top of the stack.  To prevent errors we always
   allocate enough space.  When there are fewer args, the preallocated
   words are simply wasted. */

extern void qt_start(void);
#define QT_ARGS_MD(sp)	(QT_SPUT (sp, QT_R26, qt_start))

/* The AXP uses a struct for `va_list', so pass a pointer to the
   struct.  This may break some uses of `QT_VARGS', but then we never
   claimed it was totally portable. */

typedef void (qt_function_t)(void);

struct qt_t;
struct va_list;
extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
			      struct va_list *vargs, void *pt,
			      qt_function_t *startup,
			      qt_function_t *vuserf,
			      qt_function_t *cleanup);

#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
  (qt_vargs (sp, nbytes, (struct va_list *)(&(vargs)), pt, \
	     (qt_function_t *) startup, (qt_function_t *)vuserf, \
	     (qt_function_t *)cleanup));

/* The *index* (positive offset) of where to put each value. */
#define QT_ONLY_INDEX	(QT_R12)
#define QT_USER_INDEX	(QT_R11)
#define QT_ARGT_INDEX	(QT_R10)
#define QT_ARGU_INDEX	(QT_R9)

#define QT_VCLEANUP_INDEX	(QT_R10)
#define QT_VUSERF_INDEX		(QT_R11)
#define QT_VSTARTUP_INDEX	(QT_R12)
#define QT_VARGT_INDEX		(QT_R9)

#endif /* ndef QT_AXP_H */


code:
	#
	# QuickThreads -- Threads-building toolkit.
	# Copyright (c) 1993 by David Keppel
	#
	# 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 and this notice
	# appear in all copies.  This software is provided as a
	# proof-of-concept and for demonstration purposes# there is no
	# representation about the suitability of this software for any
	# purpose.
	#

	# axp.s -- assembly support.

	.text
	.align 4
	.file "axp.s"

	.globl qt_block
	.globl qt_blocki
	.globl qt_abort
	.globl qt_start
	.globl qt_vstart

	#
	# $16: ptr to function to call once curr is suspended
	#	and control is on r19's stack.
	# $17: 1'th arg to (*$16)(...).
	# $18: 2'th arg to (*$16)(...).
	# $19: sp of thread to resume.
	#
	# The helper routine returns a value that is passed on as the
	# return value from the blocking routine.  Since we don't
	# touch r0 between the helper's return and the end of
	# function, we get this behavior for free.
	#

	.ent qt_blocki
qt_blocki:
	subq $30,80, $30	# Allocate save area.
	stq $26, 0($30)		# Save registers.
	stq  $9, 8($30)
	stq $10,16($30)
	stq $11,24($30)
	stq $12,32($30)
	stq $13,40($30)
	stq $14,48($30)
	stq $15,56($30)
	stq $29,64($30)
	.end qt_blocki
	.ent qt_abort
qt_abort:
	addq $16,$31, $27	# Put argument function in PV.
	addq $30,$31, $16	# Save stack ptr in outgoing arg.
	addq $19,$31, $30	# Set new stack pointer.
	jsr $26,($27),0		# Call helper function.

	ldq $26, 0($30)		# Restore registers.
	ldq  $9, 8($30)
	ldq $10,16($30)
	ldq $11,24($30)
	ldq $12,32($30)
	ldq $13,40($30)
	ldq $14,48($30)
	ldq $15,56($30)
	ldq $29,64($30)

	addq $30,80, $30	# Deallocate save area.
	ret $31,($26),1		# Return, predict===RET.
	.end qt_abort

	#
	# Non-varargs thread startup.
	#
	.ent qt_start
qt_start:
	addq $9,$31,  $16	# Load up `qu'.
	addq $10,$31, $17	# ... user function's `pt'.
	addq $11,$31, $18	# ... user function's `userf'.
	addq $12,$31, $27	# ... set procedure value to `only'.
	jsr $26,($27),0		# Call `only'.

	jsr $26,qt_error	# `only' erroniously returned.
	.end qt_start

	.ent qt_vstart
qt_vstart:
	# Call startup function.
	addq $9,$31, $16	# Arg0 to `startup'.
	addq $12,$31, $27	# Set procedure value.
	jsr $26,($27),0		# Call `startup'.

	# Call user function.
	ldt $f16, 0($30)	# Load fp arg regs.
	ldt $f17, 8($30)
	ldt $f18,16($30)
	ldt $f19,24($30)
	ldt $f20,32($30)
	ldt $f21,40($30)
	ldq $16,48($30)		# And integer arg regs.
	ldq $17,56($30)
	ldq $18,64($30)
	ldq $19,72($30)
	ldq $20,80($30)
	ldq $21,88($30)
	addq $30,96, $30		# Pop 6*2*8 saved arg regs.
	addq $11,$31, $27	# Set procedure value.
	jsr $26,($27),0		# Call `vuserf'.

	# Call cleanup.
	addq $9,$31, $16	# Arg0 to `cleanup'.
	addq $0,$31, $17	# Users's return value is arg1.
	addq $10,$31, $27	# Set procedure value.
	jsr $26,($27),0		# Call `cleanup'.

	jsr $26,qt_error	# Cleanup erroniously returned.
	.end qt_vstart

	#
	# Save calle-save floating-point regs $f2..$f9.
	# Also save return pc from whomever called us.
	#
	# Return value from `qt_block' is the same as the return from
	# `qt_blocki'.  We get that for free since we don't touch $0
	# between the return from `qt_blocki' and the return from
	# `qt_block'.
	#
	.ent qt_block
qt_block:
	subq $30,80, $30	# Allocate a save space.
	stq $26, 0($30)		# Save registers.
	stt $f2, 8($30)
	stt $f3,16($30)
	stt $f4,24($30)
	stt $f5,32($30)
	stt $f6,40($30)
	stt $f7,48($30)
	stt $f8,56($30)
	stt $f9,64($30)

	jsr $26,qt_blocki	# Call helper.
				# .. who will also restore $gp.

	ldq $26, 0($30)		# restore registers.
	ldt $f2, 8($30)
	ldt $f3,16($30)
	ldt $f4,24($30)
	ldt $f5,32($30)
	ldt $f6,40($30)
	ldt $f7,48($30)
	ldt $f8,56($30)
	ldt $f9,64($30)

	addq $30,80, $30	# Deallcate save space.
	ret $31,($26),1		# Return, predict===RET.
	.end qt_block


code:
	#
	# QuickThreads -- Threads-building toolkit.
	# Copyright (c) 1993 by David Keppel
	#
	# 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 and this notice
	# appear in all copies.  This software is provided as a
	# proof-of-concept and for demonstration purposes; there is no
	# representation about the suitability of this software for any
	# purpose.
	#

	.text
	.globl b_call_reg
	.globl b_call_imm
	.globl b_add
	.globl b_load

	.ent b_null
b_null:
	ret $31,($18),1
	.end b_null

	.ent b_call_reg
b_call_reg:
	lda $27,b_null
$L0:
	jsr $18,($27)
	jsr $18,($27)
	jsr $18,($27)
	jsr $18,($27)
	jsr $18,($27)

	jsr $18,($27)
	jsr $18,($27)
	jsr $18,($27)
	jsr $18,($27)
	jsr $18,($27)

	subq $16,1,$16
	bgt $16,$L0

	ret $31,($26),1
	.end

	.ent b_call_imm
b_call_imm:
$L1:
	jsr $18,b_null
	jsr $18,b_null
	jsr $18,b_null
	jsr $18,b_null
	jsr $18,b_null

	jsr $18,b_null
	jsr $18,b_null
	jsr $18,b_null
	jsr $18,b_null
	jsr $18,b_null

	subq $16,1,$16
	bgt $16,$L1

	ret $31,($26),1
	.end

	.ent b_add
b_add:
$L2:
	addq $31,$31,$31
	addq $31,$31,$31
	addq $31,$31,$31
	addq $31,$31,$31
	addq $31,$31,$31

	addq $31,$31,$31
	addq $31,$31,$31
	addq $31,$31,$31
	addq $31,$31,$31
	addq $31,$31,$31

	subq $16,1,$16
	bgt $16,$L2

	ret $31,($26),1
	.end

	.ent b_load
b_load:
$L3:
	ldq $31,0($30)
	ldq $31,8($30)
	ldq $31,16($30)
	ldq $31,24($30)
	ldq $31,32($30)

	ldq $31,0($30)
	ldq $31,8($30)
	ldq $31,16($30)
	ldq $31,24($30)
	ldq $31,32($30)

	subq $16,1,$16
	bgt $16,$L3

	ret $31,($26),1
	.end


code:
#
# `Normal' configuration.
#
CC	      = gcc -ansi -Wall -pedantic


code:
# This file (cnx_spp.Makefile) is part of the port of QuickThreads for
# PA-RISC 1.1 architecture on a Convex SPP.  This file is a machine dependent
# makefile for QuickThreads.  It was written in 1994 by Uwe Reder
# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.

# `Normal' configuration.

CC = /usr/convex/bin/cc


code:
# This file (pa-risc.Makefile) is part of the port of QuickThreads for
# PA-RISC 1.1 architecture.  This file is a machine dependent makefile
# for QuickThreads.  It was written in 1994 by Uwe Reder
# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.

# `Normal' configuration.

CC = cc -Aa