Commit fb3803df authored by Niels Möller's avatar Niels Möller

*** 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)
parent b39264aa
1999-10-02 Niels Möller <nisse@cuckoo.localdomain>
* src/ (EXTRA_DIST): Removed make_class,
make_char_classes and compiler.scm (which now live in the scm
* src/tcpforward_commands.c (new_tcpip_channel): Register the fd
on the channel's resources list.
* 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
(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
1999-09-30 Niels Möller <nisse@cuckoo.localdomain>
* If no SCHEME_PROGRAM is found, use false.
1999-09-27 Niels Möller <nisse@cuckoo.localdomain>
* src/ (SUBDIRS): Added scm subdirectory.
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 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,
;; 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)))
(normalize-application (preprocess op)
(map preprocess (cdr expr))))))))
(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-lambda (caar definitions)
(preprocess (cadar definitions)))))))
(define (do-let args preprocess)
(let ((definitions (car args))
(body (cadr args)))
(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))))
(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))))
(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))
(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)))
#! /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))
(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)
(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))))
(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))))
(vector-set! parts i (subvector v start (+ start length)))
(loop (+ i 1) (+ start length)))))
(define (implode separator list)
(cond ((null? list) "")
((null? (cdr list)) (car list))
(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.
;; / \ / \
;; 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))
(lambda (set)
(debug "cache: ~s\n" (map (lambda (pair) (char-set-members (car pair)))
(cond ((char-set-assoc set cache)
=> cdr)
(let ((new (make-tree set)))
(debug "Adding set ~s\n" (char-set-members set))
(set! cache (cons (cons set new) cache))
(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))
; t1 is a non-leaf
(for-children (lambda (c)
(tree-intersect! cache t2 c))
(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))
(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))))
(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)))))
(define (build-flags root)
(map-leafs tree/index root))
(define (prepare-input l)
(let loop ((left l) (out '()) (names '()))
(if (null? left)
(let* ((name (caar left))
(input (cdar left))
(set (input->char-set input
(werror "Read class ~a\n" name)
(loop (cdr left)
(cons (cons name
(make-tree set))
(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)
(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))))))
(write-string "#define CHAR_other 1\n")
(write-string "#endif /* !CHAR_CLASSES_TABLE */\n")))
(define test-2-input
'((lower . "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))
(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)))
#! /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))