[[project @ 1996-12-12 00:32:32 by ghouston]
ghouston**19961212003232
 Ignore-this: cfb31d90fa91b72036de30d02ed417ea
 * init.scm: define bitwise-not, bitwise-and, bitwise-ior, bitwise-xor.
 use slib's macro-by-example for define-syntax for now.
 load let-opt.scm and utilities.scm.
 
 * utilities.scm: replace usage of :optional with optional.
 comment out compose, haven't decided what to do with call-with-values.
 
 * let-opt.scm: comment out everything but the `optional'
 macro, renamed from :optional.
 
 * COPYING, let-opt.scm, utilities.scm: from SCSH 0.4.4.
 * ChangeLog, INCOMPAT, init.scm: new files.
 * new directory.
] addfile ./COPYING
addfile ./ChangeLog
addfile ./INCOMPAT
addfile ./init.scm
addfile ./let-opt.scm
addfile ./utilities.scm
hunk ./COPYING 1
+Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
+Copyright (c) 1994, 1995 by Olin Shivers and Brian D. Carlstrom.
+
+   Use of this program for non-commercial purposes is permitted provided
+that such use is acknowledged both in the software itself and in
+accompanying documentation.
+
+   Use of this program for commercial purposes is also permitted, but
+only if, in addition to the acknowledgement required for
+non-commercial users, written notification of such use is provided by
+the commercial user to the authors prior to the fabrication and
+distribution of the resulting software.
+
+ This software is provided ``as is'' without express or implied warranty.
+
+
+
+Distributing Autoconf Output
+****************************
+
+[excerpt from autoconf documentation]
+
+   The configuration scripts that Autoconf produces are covered by the
+GNU General Public License.  This is because they consist almost
+entirely of parts of Autoconf itself, rearranged somewhat, and Autoconf
+is distributed under the terms of the GPL.  As applied to Autoconf, the
+GPL just means that you need to distribute `configure.in' along with
+`configure'.
+
+   Programs that use Autoconf scripts to configure themselves do not
+automatically come under the GPL.  Distributing an Autoconf
+configuration script as part of a program is considered to be *mere
+aggregation* of that work with the Autoconf script.  Such programs are
+not derivative works based on Autoconf; only their configuration scripts
+are.  We still encourage software authors to distribute their work under
+terms like those of the GPL, but doing so is not required to use
+Autoconf.
hunk ./ChangeLog 1
+Wed Dec 11 22:15:18 1996  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* init.scm: define bitwise-not, bitwise-and, bitwise-ior, bitwise-xor.
+	use slib's macro-by-example for define-syntax for now.
+	load let-opt.scm and utilities.scm.
+
+	* utilities.scm: replace usage of :optional with optional.
+	comment out compose, haven't decided what to do with call-with-values.
+
+	* let-opt.scm: comment out everything but the `optional'
+ 	macro, renamed from :optional.
+	
+	* COPYING, let-opt.scm, utilities.scm: from SCSH 0.4.4.
+	* ChangeLog, INCOMPAT, init.scm: new files.
+	* new directory.
+
hunk ./INCOMPAT 1
+Incompatibilities with SCSH 0.4.4:
+a lot of stuff is missing
+:optional renamed to optional
+utilities.scm shouldn't be at the top level.
hunk ./init.scm 1
+(define (bitwise-not a) (lognot a))
+(define (bitwise-and a b) (logand a b))
+(define (bitwise-ior a b) (logior a b))
+(define (bitwise-xor a b) (logxor a b))
+
+(define-module (guile) :use-module (ice-9 slib))
+(require 'macro-by-example)
+
+(load-from-path "scsh/let-opt.scm")
+
+;; "delete" primitive is replaced, but doesn't seem worth saving.
+(load-from-path "scsh/utilities.scm")
hunk ./let-opt.scm 1
+;;; This file defines three macros for parsing optional arguments to procs:
+;;; 	(LET-OPTIONALS  arg-list ((var1 default1) ...) . body)
+;;; 	(LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
+;;; 	(:OPTIONAL rest-arg default-exp)
+;;;
+;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
+;;; explicit-renaming low-level macro system. You'll have to do some work to
+;;; port it to another macro system.
+;;;
+;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
+;;; high-level macros, and should be portable to any R4RS system.
+;;;
+;;; These macros are all careful to evaluate their default forms *only* if
+;;; their values are needed.
+;;;
+;;; The top-level forms in this file are Scheme 48 module expressions.
+;;; I use the module system to help me break up the expander code for 
+;;; LET-OPTIONALS into three procedures, which makes it easier to understand
+;;; and test. But if you wanted to port this code to a module-less Scheme
+;;; system, you'd probably have to inline the three procs into the actual
+;;; macro definition.
+;;;
+;;; The only interesting module that is exported by this file is
+;;; 	LET-OPT
+;;; which obeys the following interface:
+;;;     (exports (let-optionals  :syntax)
+;;;              (let-optionals* :syntax)
+;;;		 (:optional       :syntax))
+;;;
+;;; To repeat: This code is not simple Scheme code; it is module code. 
+;;; It must be loaded into the Scheme 48 ,config package, not the ,user 
+;;; package. 
+;;;
+;;; The only non-R4RS dependencies in the macros are ERROR 
+;;; and CALL-WITH-VALUES.
+;;; 
+;;; See below for details on each macro.
+;;; 	-Olin
+
+;;; (LET-OPTIONALS arg-list ((var1 default1) ...) 
+;;;   body
+;;;   ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for binding a procedure's optional arguments to either
+;;; the passed-in values or a default.
+;;;
+;;; The expression takes a rest list ARG-LIST and binds the VARi to
+;;; the elements of the rest list. When there are no more elements, then
+;;; the remaining VARi are bound to their corresponding DEFAULTi values.
+;;; It is an error if there are more args than variables.
+;;;
+;;; - The default expressions are *not* evaluated unless needed.
+;;;
+;;; - When evaluated, the default expressions are carried out in the *outer*
+;;;   environment. That is, the DEFAULTi forms do *not* see any of the VARi
+;;;   bindings.
+;;;
+;;;   I originally wanted to have the DEFAULTi forms get eval'd in a LET*
+;;;   style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
+;;;   impossible to implement without side effects or redundant conditional
+;;;   tests. If I drop this requirement, I can use the efficient expansion
+;;;   shown below. If you need LET* scope, use the less-efficient 
+;;;   LET-OPTIONALS* form defined below.
+;;;
+;;; Example:
+;;; (define (read-string! str . maybe-args)
+;;;   (let-optionals maybe-args ((port (current-input-port))
+;;;                              (start 0)
+;;;                              (end (string-length str)))
+;;;     ...))
+;;;
+;;; expands to:
+;;; 
+;;; (let* ((body (lambda (port start end) ...))
+;;;        (end-def (lambda (%port %start) (body %port %start <end-default>)))
+;;;        (start-def (lambda (%port) (end-def %port <start-default>)))
+;;;        (port-def  (lambda () (start-def <port-def>))))
+;;;   (if (null? rest) (port-def)
+;;;       (let ((%port (car rest))
+;;; 	        (rest (cdr rest)))
+;;; 	  (if (null? rest) (start-def %port)
+;;; 	      (let ((%start (car rest))
+;;; 		    (rest (cdr rest)))
+;;; 	        (if (null? rest) (end-def %port %start)
+;;; 		    (let ((%end (car rest))
+;;; 			  (rest (cdr rest)))
+;;; 		      (if (null? rest) (body %port %start %end)
+;;; 			  (error ...)))))))))
+
+
+;(define-structure let-opt-expanders (export expand-let-optionals)
+;  (open scheme)
+;  (begin
+
+;;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
+;;; I wish I had a reasonable loop macro.
+
+;(define (make-default-procs vars body-proc defaulter-names defs rename)
+;  (let ((%lambda (rename 'lambda)))
+;    (let recur ((vars (reverse vars))
+;		(defaulter-names (reverse defaulter-names))
+;		(defs (reverse defs))
+;		(next-guy body-proc))
+;      (if (null? vars) '()
+;	  (let ((vars (cdr vars)))
+;	    `((,(car defaulter-names)
+;	       (,%lambda ,(reverse vars)
+;			 (,next-guy ,@(reverse vars) ,(car defs))))
+;	      . ,(recur vars
+;			(cdr defaulter-names)
+;			(cdr defs)
+;			(car defaulter-names))))))))
+
+
+;;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
+ 
+;(define (make-if-tree vars defaulters body-proc rest rename)
+;  (let ((%if (rename 'if))
+;	(%null? (rename 'null?))
+;	(%error (rename 'error))
+;	(%let (rename 'let))
+;	(%car (rename 'car))
+;	(%cdr (rename 'cdr)))
+	
+;    (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
+;      (if (null? vars)
+;	  `(,%if (,%null? ,rest) (,body-proc . ,(reverse non-defaults))
+;		 (,%error "Too many optional arguments." ,rest))
+
+;	  (let ((v (car vars)))
+;	    `(,%if (,%null? ,rest)
+;		   (,(car defaulters) . ,(reverse non-defaults))
+;		   (,%let ((,v (,%car ,rest))
+;			   (,rest (,%cdr ,rest)))
+;		     ,(recur (cdr vars)
+;			     (cdr defaulters)
+;			     (cons v non-defaults)))))))))
+	    
+
+;(define (expand-let-optionals exp rename compare?)
+;  (let* ((arg-list (cadr exp))
+;	 (var/defs (caddr exp))
+;	 (body (cdddr exp))
+;	 (vars (map car var/defs))
+
+;	 (prefix-sym (lambda (prefix sym)
+;		       (string->symbol (string-append prefix (symbol->string sym)))))
+
+;	 ;; Private vars, one for each user var.
+;	 ;; We prefix the % to help keep macro-expanded code from being
+;	 ;; too confusing.
+;	 (vars2 (map (lambda (v) (rename (prefix-sym "%" v)))
+;		     vars))
+
+;	 (defs (map cadr var/defs))
+;	 (body-proc (rename 'body))
+
+;	 ;; A private var, bound to the value of the ARG-LIST expression.
+;	 (rest-var (rename '%rest))
+
+;	 (%let* (rename 'let*))
+;	 (%lambda (rename 'lambda))
+
+;	 (defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var)))
+;			       vars))
+
+;	 (defaulters (make-default-procs vars2 body-proc
+;					 defaulter-names defs rename))
+;	 (if-tree (make-if-tree vars2 defaulter-names body-proc
+;				rest-var rename)))
+
+;    `(,%let* ((,rest-var ,arg-list)
+;	      (,body-proc (,%lambda ,vars . ,body))
+;	      . ,defaulters)
+;       ,if-tree)))
+
+;)) ; erutcurts-enifed
+;;; nilO- .noitnevnoc gnitekcarb sugob a ni deppart m'I !pleh !pleh
+
+;;; Here is where we define the macros, using the expanders from the above
+;;; package.
+
+;(define-structure let-opt (export (let-optionals  :syntax)
+;				  (let-optionals* :syntax)
+;				  (:optional      :syntax))
+;  (open scheme error-package)
+;  (for-syntax (open let-opt-expanders scheme))
+;  (begin
+
+
+;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
+;;; The expander is defined in the code above.
+
+;(define-syntax let-optionals expand-let-optionals)
+
+
+;;; (:optional rest-arg default-exp)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for evaluating optional arguments and their defaults
+;;; in simple procedures that take a *single* optional argument. It is
+;;; a macro so that the default will not be computed unless it is needed.
+;;; 
+;;; REST-ARG is a rest list from a lambda -- e.g., R in
+;;;     (lambda (a b . r) ...)
+;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
+;;; - If REST-ARG has 1 element, return that element.
+;;; - If REST-ARG has >1 element, error.
+
+;; for Guile, renamed from :optional 
+(define-syntax optional
+  (syntax-rules ()
+    ((optional rest default-exp)
+     (let ((maybe-arg rest))
+       (cond ((null? maybe-arg) default-exp)
+	     ((null? (cdr maybe-arg)) (car maybe-arg))
+	     (else (error "too many optional arguments" maybe-arg)))))))
+
+
+;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
+;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
+;;; within the scope of VAR1 and VAR2, and so forth.
+;;;
+;;; - If the last form in the ((var1 default1) ...) list is not a 
+;;;   (VARi DEFAULTi) pair, but a simple variable REST, then it is
+;;;   bound to any left-over values. For example, if we have VAR1 through
+;;;   VAR7, and ARGS has 9 values, then REST will be bound to the list of
+;;;   the two values of ARGS. If ARGS is too short, causing defaults to
+;;;   be used, then REST is bound to '().
+;;; - If there is no REST variable, then it is an error to have excess
+;;;   values in the ARGS list.
+
+
+;;; This just interfaces to REALLY-LET-OPTIONALS*, which expects
+;;; the ARGS form to be a variable.
+
+;(define-syntax let-optionals*
+;  (syntax-rules ()
+;    ((let-optionals* args vars&defaults body1 ...)
+;     (let ((rest args))
+;       (really-let-optionals* rest vars&defaults body1 ...)))))
+
+;(define-syntax really-let-optionals*
+;  (syntax-rules ()
+;    ;; Standard case. Do the first var/default and recurse.
+;    ((really-let-optionals* args ((var1 default1) etc ...)
+;       body1 ...)
+;     (call-with-values (lambda () (if (null? args)
+;				      (values default1 '())
+;				      (values (car args) (cdr args))))
+;		       (lambda (var1 rest)
+;			 (really-let-optionals* rest (etc ...)
+;			   body1 ...))))
+
+;    ;; Single rest arg -- bind to the remaining rest values.
+;    ((really-let-optionals* args (rest) body1 ...)
+;     (let ((rest args)) body1 ...))
+
+;    ;; No more vars. Make sure there are no unaccounted-for values, and
+;    ;; do the body.
+;    ((really-let-optionals* args () body1 ...)
+;     (if (null? args) (begin body1 ...)
+;	 (error "Too many optional arguments." args)))))
+
+;)) ; erutcurts-enifed
hunk ./utilities.scm 1
+;;; Random useful utilities.
+;;; Copyright (c) 1993 by Olin Shivers.
+
+;;; for Guile: :optional renamed to optional.  commented out compose.
+
+(define (del elt lis)
+  (letrec ((del (lambda (lis)
+		  (if (pair? lis)
+		      (let* ((head (car lis))
+			     (tail (cdr lis))
+			     (new-tail (del tail)))
+			(if (equal? head elt) new-tail
+			    (if (eq? tail new-tail) lis
+				(cons head new-tail))))
+		      '()))))
+    (del lis)))
+
+(define (delete pred lis)
+  (filter (lambda (x) (not (pred x))) lis))
+
+(define (index str c . maybe-start)
+  (let ((start (max 0 (optional maybe-start 0)))
+	(len (string-length str)))
+    (do ((i start (+ 1 i)))
+	((or (>= i len)
+	     (char=? c (string-ref str i)))
+	 (and (< i len) i)))))
+
+(define (rindex str c . maybe-start)
+  (let* ((len (string-length str))
+	 (start (min (optional maybe-start len)
+		     len)))
+    (do ((i (- start 1) (- i 1)))
+	((or (< i 0)
+	     (char=? c (string-ref str i)))
+	 (and (>= i 0) i)))))
+
+;;; (f (f (f zero x1) x2) x3)
+;;; [Richard's does (f x3 (f x2 (f x1 zero)))
+(define (reduce f zero l)
+  (letrec ((lp (lambda (val rest)
+		 (if (pair? rest) (lp (f val (car rest)) (cdr rest))
+		     val))))
+    (lp zero l)))
+				      
+(define (filter pred list)
+  (letrec ((filter (lambda (list)
+		     (if (pair? list)
+			 (let* ((head (car list))
+				(tail (cdr list))
+				(new-tail (filter tail)))
+			   (if (pred head)
+			       (if (eq? tail new-tail) list
+				   (cons head new-tail))
+			       new-tail))
+			 '()))))
+    (filter list)))
+
+(define (first pred list)
+  (letrec ((lp (lambda (list)
+		 (and (pair? list)
+		      (let ((head (car list)))
+			(if (pred head) head
+			    (lp (cdr list))))))))
+    (lp list)))
+
+(define any first)
+
+;;; Returns the first true value produced by PRED, not the list element
+;;; that satisfied PRED.
+
+(define (first? pred list)
+  (letrec ((lp (lambda (list)
+		 (and (pair? list)
+		      (or (pred (car list))
+			  (lp (cdr list)))))))
+    (lp list)))
+
+(define any? first?)
+
+(define (every? pred list)
+  (letrec ((lp (lambda (list)
+		 (or (not (pair? list))
+		     (and (pred (car list))
+			  (lp (cdr list)))))))
+    (lp list)))
+
+(define (mapv f v)
+  (let* ((len (vector-length v))
+	 (ans (make-vector len)))
+    (do ((i 0 (+ i 1)))
+	((= i len) ans)
+      (vector-set! ans i (f (vector-ref v i))))))
+
+(define (mapv! f v)
+  (let ((len (vector-length v)))
+    (do ((i 0 (+ i 1)))
+	((= i len) v)
+      (vector-set! v i (f (vector-ref v i))))))
+
+(define (vector-every? pred v)
+  (let lp ((i (- (vector-length v) 1)))
+    (or (< i 0)
+	(and (pred (vector-ref v i))
+	     (lp (- i 1))))))
+
+(define (copy-vector v)
+  (let* ((len (vector-length v))
+	 (ans (make-vector len)))
+    (do ((i (- len 1) (- i 1)))
+	((< i 0) ans)
+      (vector-set! ans i (vector-ref v i)))))
+
+(define (initialize-vector len init)
+  (let ((v (make-vector len)))
+    (do ((i (- len 1) (- i 1)))
+	((< i 0) v)
+      (vector-set! v i (init i)))))
+
+(define (check-arg pred val caller)
+  (if (pred val) val
+      (check-arg pred (error "Bad argument" val pred caller) caller)))
+
+(define (conjoin f g)
+  (lambda args (and (apply f args) (apply g args))))
+
+(define (disjoin f g)
+  (lambda args (or (apply f args) (apply g args))))
+
+(define (negate f) (lambda args (not (apply f args))))
+
+;(define (compose f g)
+;  (lambda args (call-with-values (lambda () (apply g args)) f)))
+
+
+(define (reverse! lis)
+  (let lp ((lis lis) (prev '()))
+    (if (not (pair? lis)) prev
+	(let ((tail (cdr lis)))
+	  (set-cdr! lis prev)
+	  (lp tail lis)))))
+
+(define call/cc call-with-current-continuation)
+
+(define (deposit-bit-field bits mask field)
+  (bitwise-ior (bitwise-and field mask)
+	       (bitwise-and bits  (bitwise-not mask))))
+
+
+(define (nth lis i)
+  (if (< i 0) (error "nth: illegal list index" i)
+      (let lp ((l lis) (i i))
+	(if (pair? l)
+	    (if (zero? i) (car l)
+		(lp (cdr l) (- i 1)))
+	    (error "nth: index too large" lis i)))))
+
+
+(define (deprecated-proc proc name . maybe-preferred-msg)
+  (let ((warned? #f))
+    (lambda args
+      (cond ((not warned?)
+	     (set! warned? #t)
+	     (apply warn
+		    "Deprecated procedure (may not be supported in a future release)"
+		    name
+		    maybe-preferred-msg)))
+      (apply proc args))))
+
+
+(define (real->exact-integer x)
+  (let ((f (round x)))
+    (if (inexact? f) (inexact->exact f) f)))
+