*** empty log message ***

Rev: ChangeLog:1.101
Rev: NEWS:1.26
Rev: src/compiler.scm:1.9(DEAD)
Rev: src/make_char_classes:1.4(DEAD)
Rev: src/make_class:1.22(DEAD)

ChangeLog

+1999-10-02  Niels Möller  <nisse@cuckoo.localdomain>
+
+	* src/Makefile.am.in (EXTRA_DIST): Removed make_class,
+	make_char_classes and compiler.scm (which now live in the scm
+	subdirectory). 
+
+	* src/tcpforward_commands.c (new_tcpip_channel): Register the fd
+	on the channel's resources list.
+
+	* configure.in: Bumped version to 0.1.12.
+
+	* src/tcpforward.c (tcpip_channel_start_io): Use
+	make_channel_read_close_callback rather than
+	make_channel_close_callback. I haven't looked into exception
+	handling for i/o errors yet.
+
+	* src/server_session.c (do_alloc_pty): Put the pty on the
+	channel's resources list rather than the connection's.
+
+	* src/client.c (do_send_first): Removed this function.
+	(do_client_io): Fixed setup of fd:s, and their close-callbacks and
+	exception handlers. Also register the fd:s on the channel's
+	resources list.
+
+	* src/server_session.c (do_spawn_shell): Fixed close-callbacks and
+	exception handlers for stdio. Also registers the fd:s on the
+	channel's rather than the connection's resources list.
+
+	* src/read_data.c: Removed all EOF-handling. Perhaps the rest of
+	the code should be moved to channel.c?
+
+	* src/channel.c (do_exc_finish_channel_handler): Kill the channel's
+	resources when it is closed.
+	(register_channel): Register the channel's resources list as an
+	item on the connection's.
+	(init_channel): Initialize resources list.
+	(make_channel_read_close_callback): Renamed from
+	make_channel_close_callback, for the same reason.
+	(channel_io_exception_handler): Exception handler to close the
+	channel on i/o errors. Primarily useful for fd:s the channel
+	writes to.
+	(make_channel_io_exception_handler): New function.
+
+	* src/channel.c (channel_read_close_callback): Renamed from
+	channel_close_callback. The previous behaviour, which used the
+	callback for fd:s the channel writes to, was completely bogus.
+
+	* src/channel.c (channel_close): Do nothing if we have already
+	sent CHANNEL_CLOSE. 
+	(channel_eof): Do nothing if we have already sent CHANNEL_EOF, or
+	either sent or received CHANNEL_CLOSE.
+
+	* src/channel.h (ssh_channel): Added a resources attribute.  
+
+	* src/scm/gaba.scm: Renamed the struct-special type to
+	indirect-special, as it is useful for non-structs.
+
+	* src/debug.c (send_debug_message): New function, to
+	unconditionally send a DEBUG message.
+	(send_debug, send_verbose): Change argument type from struct
+	ssh_connection to struct abstract_write.
+
+	* src/resource.h: Made resource_list inherit
+	resource. This means that KILL_RESOURCE_LIST is now more or less
+	an alias for KILL_RESOURCE. Also made the resource-list behave a
+	little like a weak list.
+
+	* src/resource.c: Dead resources are unlinked from the list
+	automatically while garbage collecting. This means that references
+	from a resource list won't keep a dead resource from being garbage
+	collected.
+
+1999-09-30  Niels Möller  <nisse@cuckoo.localdomain>
+
+	* configure.in: If no SCHEME_PROGRAM is found, use false.
+
 1999-09-27  Niels Möller  <nisse@cuckoo.localdomain>
 
 	* src/Makefile.am.in (SUBDIRS): Added scm subdirectory.

NEWS

+News for the lsh-0.1.12 release
+
+	Tried to fix bugs related to channel close. In the process,
+	improved the resource mechanism, and let each channel
+	have it's own list of resources.
+
+	Fixed configure.in to handle systems with neither scsh or
+	guile installed.
+	
+
 News for the lsh-0.1.11 release
 
 	Support for other scheme implementations in the build process,

src/compiler.scm

-;; FIXME: Turn this into a scheme48 module
-
-(define-syntax let-and
-  (syntax-rules '()
-		((let-and (expr) clause clauses ...)
-		 (and expr (let-and clause clauses ...)))
-		((let-and (name expr) clause clauses ...)
-		 (let ((name expr))
-		   (and name (let-and clause clauses ...))))
-		((let-and expr) expr)))
-
-(define (atom? o) (not (list? o)))
-(define (lambda? o) (and (pair? o) (eq? 'lambda (car o))))
-
-(define (make-lambda formal body) `(lambda ,formal ,body))
-(define lambda-formal cadr)
-(define lambda-body caddr)
-
-(define make-appliction list)
-(define application-op car)
-(define application-arg cadr)
-(define application-args cdr)
-
-(define (normalize-application op args)
-  (if (null? args) op
-      (normalize-application (make-appliction op (car args)) (cdr args))))
-
-;; Transform (a b c)-> ((a b) c) and
-;; (lambda (a b) ...) -> (lambda a (lambda b ...)
-(define (make-preprocess specials)
-
-  (define (preprocess expr)
-    (if (atom? expr) expr
-	(let ((op (car expr)))
-	  (cond ((and (atom? op)
-		      (assq op specials))
-		 => (lambda (pair) ((cdr pair) (cdr expr) preprocess)))
-		(else
-		 (normalize-application (preprocess op)
-					(map preprocess (cdr expr))))))))
-  preprocess)
-
-(define preprocess-applications (make-preprocess '()))
-
-(define (do-lambda args preprocess)
-  (let loop ((formals (reverse (car args)))
-	     (body (preprocess (cadr args))))
-    (if (null? formals) body
-	(loop (cdr formals)
-	      (make-lambda (car formals) body)))))
-
-(define (do-let* args preprocess)
-  (let loop ((definitions (reverse (car args)))
-	     (body (preprocess (cadr args))))
-    (if (null? definitions) body
-	(loop (cdr definitions)
-	      (make-appliction
-	       (make-lambda (caar definitions)
-			    body)
-	       (preprocess (cadar definitions)))))))
-
-(define (do-let args preprocess)
-  (let ((definitions (car args))
-	(body (cadr args)))
-    (normalize-application 
-     (do-lambda (list (map car definitions) body) preprocess)
-     (map cadr definitions))))
-
-(define preprocess (make-preprocess
-		    `((lambda . ,do-lambda)
-		      (let . ,do-let)
-		      (let* . ,do-let*))))
-  
-(define (free-variable? v expr)
-  (cond ((atom? expr) (eq? v expr))
-	((lambda? expr)
-	 (and (not (eq? v (lambda-formal expr)))
-	      (free-variable? v (lambda-body expr))))
-	(else
-	 (or (free-variable? v (application-op expr))
-	     (free-variable? v (application-arg expr))))))
-
-(define (match pattern expr)
-  (if (atom? pattern)
-      (if (eq? '* pattern) (list expr)
-	  (and (eq? pattern expr) '()))
-      (let-and ((pair? expr))
-	       (op-matches (match (application-op pattern)
-				  (application-op expr)))
-	       (arg-matches (match (application-arg pattern)
-				   (application-arg expr)))
-	       (append op-matches arg-matches))))
-
-(define (rule pattern f)
-  (cons (preprocess-applications pattern) f))
-
-;;; The reduction rules for our combinators are
-
-;; I x        --> x
-;; K a b      --> b
-;; S f f x    --> (f x) (g x)
-;; B f g x    --> f (g x)
-;; C f y x    --> (f x) y
-;; S* c f g x --> c (f x) (g x)
-;; B* c f g x --> c (f (g x))
-;; C* c f g x --> c (f x) y
-
-(define (make-K e) (make-combine 'K e))
-(define (make-S p q) (make-combine 'S p q))
-;; (define (make-B p) (make-combine 'B p))
-;; (define (make-C p q) (make-combine 'C p q))
-;; (define (make-S* p q) (make-combine 'S* p q))
-;; (define (make-B* p q) (make-combine 'B* p q))
-;; (define (make-C* p q) (make-combine 'C* p q))
-
-;; Some mor patterns that can ba useful for optimization. From "A
-;; combinator-based compiler for a functional language" by Hudak &
-;; Kranz.
-
-;; S K => K I
-;; S (K I) => I
-;; S (K (K x)) => K (K x)
-;; S (K x) I => x
-;; S (K x) (K y) => K (x y)
-;; S f g x = f x (g x)
-;; K x y => x
-;; I x => x
-;; Y (K x) => x
-
-(define optimizations
-  (list (rule '(S (K *) (K *)) (lambda (p q) (make-K (make-appliction p q))))
-	(rule '(S (K *) I) (lambda (p) p))
-	;; (rule '(B K I) (lambda () 'K))
-	(rule '(S (K *) (B * *)) (lambda (p q r) (make-combine 'B* p q r)))
-	(rule '(S (K *) *) (lambda (p q) (make-combine 'B p q)))
-	(rule '(S (B * *) (K *))  (lambda (p q r) (make-combine 'C* p q r)))
-	;; (rule '(C (B * *) *) (lambda (p q r) (make-combine 'C* p q r)))
-	(rule '(S * (K *)) (lambda (p q) (make-combine 'C p q)))
-	(rule '(S (B * * ) r) (lambda (p q r) (make-combine 'S* p q r)))))
-
-(define (optimize expr)
-  ;; (werror "optimize ~S\n" expr)
-  (let loop ((rules optimizations))
-    ;; (if (not (null? rules)) (werror "trying pattern ~S\n" (caar rules)) )
-    (cond ((null? rules) expr)
-	  ((match (caar rules) expr)
-	   => (lambda (parts) (apply (cdar rules) parts)))
-	  (else (loop (cdr rules))))))
-
-(define (optimize-application op args)
-  (if (null? args) op
-      (optimize-application (optimize (make-appliction op (car args)))
-			    (cdr args))))
-
-(define (make-combine op . args)
-  (optimize-application op args))
-
-(define (translate-expression expr)
-  (cond ((atom? expr) expr)
-	((lambda? expr)
-	 (translate-lambda (lambda-formal expr)
-			   (translate-expression (lambda-body expr))))
-	(else
-	 (make-appliction (translate-expression (application-op expr))
-			  (translate-expression (application-arg expr))))))
-
-(define (translate-lambda v expr)
-  (cond ((atom? expr)
-	 (if (eq? v expr) 'I (make-K expr)))
-	((lambda? expr)
-	 (error "translate-lambda: Unexpected lambda" expr))
-	(else
-	 (make-S (translate-lambda v (application-op expr))
-		       (translate-lambda v (application-arg expr))))))
-  
-(define (make-flat-application op arg)
-  (if (atom? op) `(,op ,arg)
-      `(,@op ,arg)))
-      
-(define (flatten-application expr)
-  (if (or (atom? expr) (lambda? expr)) expr
-      (make-flat-application (flatten-application (application-op expr))
-			     (flatten-application (application-arg expr)))))
-
-(define (translate expr)
-  (flatten-application (translate-expression (preprocess expr))))
-
-;;; Test cases
-;; (translate '(lambda (port connection)
-;;                 (start-io (listen port connection)
-;;                 (open-direct-tcpip connection))))
-;;  ===> (C (B* S (B start-io) listen) open-direct-tcpip)
-;; 
-;; (translate '(lambda (f) ((lambda (x) (f (lambda (z) ((x x) z))))
-;; 			    (lambda (x) (f (lambda (z) ((x x) z)))) )))
-;; ===> (S (C B (S I I)) (C B (S I I)))
-;; 
-;; (translate '(lambda (r) (lambda (x) (if (= x 0) 1 (* x (r (- x 1)))))))
-;; ===> (B* (S (C* if (C = 0) 1)) (S *) (C B (C - 1)))

src/make_char_classes

-#! /usr/local/bin/scsh \
--e main -s
-!#
-
-;; Reads an alist of character classes and their contents,
-;; computes a partition of disjunct sets, associate a bit with each
-;; partition set, and finally writes a C file containing
-;; a partition table index by character, and masks corresponding to
-;; the input classes.
-
-;; Misc functions
-(define (my-error s . args)
-  (error (apply format #f s args)))
-
-(define (debug s . args)
-  ; (apply format (error-output-port) s args))
-  #f)
-
-(define (werror s . args)
-  (apply format (error-output-port) s args))
-
-(define (filter p l)
-  (cond ((null? l) l)
-	((p (car l))
-	 (cons (car l) (filter p (cdr l))))
-	(else (filter p (cdr l)))))
-
-(define (identity x) x)
-
-(define (invert-predicate p)
-  (lambda (x) (not (p x))))
-
-(define (reduce op start l)
-  (if (null? l)
-      start
-      (reduce op (op start (car l)) (cdr l))))
-
-(define (subvector v start end)
-  (let ((n (make-vector (- end start))))
-    (let loop ((i start))
-      (when (< i end)
-	    (vector-set! n (- i start) (vector-ref v i))
-	    (loop (+ i 1))))
-    n))
-
-(define (vector-split v n)
-  (let ((parts (make-vector n))
-	(length (quotient (+ (vector-length v) n -1) n)))
-    (let loop ((i 0) (start 0))
-      (cond  ((= i (- n 1))
-	      (vector-set! parts i (subvector v start (vector-length v))))
-	     (else
-	      (vector-set! parts i (subvector v start (+ start length)))
-	      (loop (+ i 1) (+ start length)))))
-    parts))
-
-(define (implode separator list)
-  (cond ((null? list) "")
-	((null? (cdr list)) (car list))
-	(else
-	 (string-append (car list) separator (implode separator (cdr list))))))
-
-(define-syntax when
-  (syntax-rules () ((when test . consequences) (if test (begin . consequences)))))
-
-;; A little more user-friendly input format.
-(define (input->char-set o names)
-  (define (->ascii x)
-    (cond ((integer? x) x)
-	  ((char? x) (char->ascii x))
-	  (else #f)))
-  (define (->char x)
-    (cond ((integer? x) (ascii->char x))
-	  ((char? x) x)
-	  (else #f)))
-  (define (integer-or-char? x)
-    (or (integer? x) (char? x)))
-
-  (cond ((string? o)
-	 (string->char-set o))
-	((symbol? o)
-	 (cdr (assq o names)))
-	((and (pair? o) (not (pair? (cdr o))))
-	 (ascii-range->char-set (->ascii (car o))
-				(+ 1 (->ascii (cdr o)))))
-	((list? o)
-	 (reduce char-set-union (chars->char-set
-				 (map ->char (filter integer-or-char? o)))
-		 (map (lambda (o) (input->char-set o names))
-		      (filter (invert-predicate integer-or-char?) o))))
-	(else (my-error "Bad char set specification ~s" o))))
-
-;; Depends on charsets implemented as strings
-(define char-set=? string=?)
-
-(define char-set-empty?
-  (let ((empty (chars->char-set '())))
-    (lambda (o) (char-set=? o empty))))
-
-(define char-set-assoc assoc)
-
-;; We use an acyclic graph, where the input char-sets are used as
-;; roots, and two intersecting nodes will branch into three childen,
-;; one of which is shared. The children of each node are disjunct.
-;;
-;;   ABC    BCD
-;;  /   \  /   \
-;;  A    BC     D
-
-(define (make-tree set)
-  ;; Fields are set, leafness, left and right child (if any) and indexnumber.
-  (vector set #t #f #f #f))
-
-(define (tree/set tree)
-  (vector-ref tree 0))
-
-(define (tree/leaf? tree)
-  (vector-ref tree 1))
-
-(define (tree/left tree)
-  (vector-ref tree 2))
-
-(define (tree/right tree)
-  (vector-ref tree 3))
-
-(define (tree/split! tree left right)
-  (cond ((tree/leaf? tree)
-	 (vector-set! tree 1 #f)
-	 (vector-set! tree 2 left)
-	 (vector-set! tree 3 right))
-	(else (my-error "Attempt to split non-leaf"))))
-
-(define (tree/index tree)
-  (vector-ref tree 4))
-
-(define (tree/index! tree n)
-  (vector-set! tree 4  n))
-
-(define (tree-describe tree)
-  (if (tree/leaf? tree)
-      (list 'leaf
-	    (tree/index tree)
-	    (char-set-members (tree/set tree)))
-      (list 'node
-	    (char-set-members (tree/set tree))
-	    (tree-describe (tree/left tree))
-	    (tree-describe (tree/right tree))	    )))
-
-(define (make-tree-cache initial)
-  (let ((cache (map (lambda (tree) (cons (tree/set tree) tree))
-		    initial)))
-    (lambda (set)
-      (debug "cache: ~s\n" (map (lambda (pair) (char-set-members (car pair)))
-				   cache))
-      (cond ((char-set-assoc set cache)
-	     => cdr)
-	    (else
-	     (let ((new (make-tree set)))
-	       (debug "Adding set ~s\n" (char-set-members set))
-	       (set! cache (cons (cons set new) cache))
-	       new))))))
-
-
-(define (for-children f tree)
-  (f (tree/left tree))
-  (f (tree/right tree)))
-  
-;; Iterate over all leafs
-(define (for-leafs f tree)
-  (if (tree/leaf? tree)
-      (f tree)
-      (for-children (lambda (c) (for-leafs f c)) tree)))
-
-(define (map-leafs f tree)
-  (if (tree/leaf? tree)
-      (list (f tree))
-      (append (map-leafs f (tree/left tree))
-	      (map-leafs f (tree/right tree)))))
-
-;; Destructivly intersect the leafs of two trees
-(define (tree-intersect! cache t1 t2)
-  (if (not (eq? t1 t2))
-      (let* ((s1 (tree/set t1))
-	     (s2 (tree/set t2))
-	     (intersection (char-set-intersection s1 s2)))
-	(if (not (char-set-empty? intersection))
-	    (if (tree/leaf? t1)
-		(if (tree/leaf? t2)
-		    (let ((diff1 (char-set-difference s1 s2))
-			  (diff2 (char-set-difference s2 s1)))
-		      (define (split-subset! super sub diff)
-			(tree/split! super sub (cache diff)))
-		      (if (char-set-empty? diff1)
-			  (if (char-set-empty? diff2)
-			      (my-error "Two copies of ~s ~s"
-				     (tree-describe t1)
-				     (tree-describe t2))
-			      ; t1 is a subset of t2, so we need only split t2
-			      (split-subset! t2 t1 diff2))
-			  (if (char-set-empty? diff2)
-			      ; t2 is a subset of t1, so split t1
-			      (split-subset! t1 t2 diff1)
-			      ; Both differences ar non-empty, so split both
-			      (let ((common (cache intersection)))
-				(tree/split! t1 common (cache diff1))
-			    (tree/split! t2 common (cache diff2))))))
-		    ; t1 is a leaf, but not t2. Recurse.
-		    (for-children (lambda (c)
-				    (tree-intersect! cache t1 c))
-				  t2))
-		; t1 is a non-leaf
-		(for-children (lambda (c)
-				(tree-intersect! cache t2 c))
-			      t1))))))
-
-(define (partition! sets)
-  (let ((cache (make-tree-cache sets)))
-    (let loop ((left sets))
-      (let ((head (car left))
-	    (tail (cdr left)))
-	(when (not (null? tail))
-	      (for-each (lambda (tree) (tree-intersect! cache head tree))
-			tail)
-	      (loop tail))))))
-
-(define (index-leafs! roots)
-  (let ((index 1)
-	(leafs '()))
-    (for-each (lambda (tree)
-		(for-leafs (lambda (leaf)
-			     (when (not (tree/index leaf))
-				   (tree/index! leaf index)
-				   (set! index (+ 1 index))
-				   (set! leafs (cons leaf leafs))))
-			   tree))
-	      roots)
-    leafs))
-
-(define (build-char-table leafs)
-  (let ((table (make-vector #x100 0)))
-    (for-each (lambda (leaf)
-		(let ((flag (tree/index leaf)))
-		  (for-each (lambda (c)
-			      (vector-set! table (char->ascii c) flag))
-			    (char-set-members (tree/set leaf)))))
-	      leafs)
-    table))
-
-(define (build-flags root)
-  (map-leafs tree/index root))
-
-(define (prepare-input l)
-  (let loop ((left l) (out '()) (names '()))
-    (if (null? left)
-	out
-	(let* ((name (caar left))
-	       (input (cdar left))
-	       (set (input->char-set input
-				     names)))
-	  (werror "Read class ~a\n" name)
-	  (loop (cdr left)
-		(cons (cons name
-			    (make-tree set))
-		      out)
-		(cons (cons name set) names))))))
-
-#!
-(define test-input
-  '((alpha . ( (#\a . #\z) (#\A . #\Z) ))
-    (digits . ( (#\0 . #\9)))
-    (base64 . ( (#\a . #\z) (#\A . #\Z) (#\0 . #\9) #\+ #\/ #\=))
-    (hex . ( (#\0 . #\9) (#\a . #\f) (#\A . #\F) ))))
-
-(define (test1)
-  (let* ((input (prepare-input test-input))
-	 (roots (map cdr input)))
-    (partition! roots)
-    (let ((leafs (index-leafs! roots)))
-      (werror "~s disjunct classes found." (length leafs))
-      (build-char-table leafs))))
-!#
-
-(define (bit->mask bit)
-  (format #f "1L<<~s" bit))
-
-(define (make-char-classes input)
-  (let* ((classes (prepare-input input))
-	 (roots (map cdr classes)))
-    (partition! roots)
-
-    (write-string "#ifdef CHAR_CLASSES_TABLE\n")
-    (write-string "int CHAR_CLASSES_TABLE[] =\n")
-
-    (let ((leafs (index-leafs! roots)))
-      (werror "~s disjunct classes found.\n" (length leafs))
-      (format #t
-	      "{\n  ~a\n};\n"
-	      (implode ",\n  "
-		       (map (lambda (row)
-			      (implode ", " (map bit->mask
-						 (vector->list row))))
-			    (vector->list (vector-split (build-char-table leafs)
-							32))))))
-    (write-string "#else /* !CHAR_CLASSES_TABLE */\n")
-    (for-each (lambda (class)
-		(format #t "#define CHAR_~a (~a)\n"
-			(car class)
-			(implode " | " (map bit->mask (build-flags (cdr class))))))
-	      classes)
-    (write-string "#define CHAR_other 1\n")
-    (write-string "#endif /* !CHAR_CLASSES_TABLE */\n")))
-
-(define test-2-input
-  '((lower . "abcdefghijklmnopqrstuvwxyz")
-    (upper . "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-    (alpha . (lower upper))
-    (digits . "0123456789")
-    (hex . (digits "abcdefABCDEF"))
-    ;; base 64 digits, including the '=' pad character
-    (base64 . (alpha digits "+/="))
-    (control . ( (0 . #x1f) (#x80 . #x9f) #x7f))
-    ;; SPC, TAB, LF, CR
-    (space . (#x20 #x9 #xa #xd))
-    ;; \b \t \n \v \f \r
-    (escapable . (#x8 #x9 #xa #xb #xc #xd))
-    (punctuation . "-./_:*+=")
-    ;; Characters defined by most iso-8859-1 character sets
-    (international . (#xa0 . #xff))))
-
-(define (test-2)
-  (make-char-classes test-2-input))
-
-(define (main . ignored)
-  (make-char-classes (read)))

src/make_class

-#! /usr/local/bin/scsh \
--e main -l compiler.scm -s
-!#
-
-;; Reads a C source file on stdin. Comments of the form
-;;
-;; /*
-;; GABA:
-;;    expression
-;; */
-;;
-;; are treated specially, and C code for the class is written to
-;; stdout. Typically, the code is saved to a file and included by the
-;; C source file in question.
-
-;; FIXME: Perhaps the files should somehow be fed through the
-;; preprocessor first?
-
-(define (werror f . args)
-  (display (apply format #f f args) 2))
-
-(define (string-prefix? prefix s)
-  (let ((l (string-length prefix)))
-    (and (<= l (string-length s))
-	 (string=? prefix (substring s 0 l)))))
-
-(define (string-upcase s)
-  (list->string (map char-upcase (string->list s))))
-
-(define (read-expression p)
-  (let ((line (read-line)))
-    ; (werror "read line: '~s'\n" (if (eof-object? line) "<EOF>" line))
-    (cond ((eof-object? line) line)
-	  ((p line) (read))
-	  (else (read-expression p)))))
-
-(define (get key alist select)
-  (cond ((assq key alist) => select)
-	(else #f)))
-
-(define (append-deep o)
-  ; (werror "append-deep: ~S\n" o)
-  (cond ((string? o) o)
-	((symbol? o) (symbol->string o))
-	((number? o) (number->string o))
-	(else