Commit 8f44ff86 authored by Niels Möller's avatar Niels Möller

*** empty log message ***

Rev: doc/TODO:1.59
Rev: src/scm/
Rev: src/scm/compiler.scm:1.1
Rev: src/scm/gaba.scm:1.1
Rev: src/scm/guile-compat.scm:1.1
Rev: src/scm/make-char-classes.scm:1.1
Rev: src/scm/scsh-compat.scm:1.1
parent dd108bcb
......@@ -240,7 +240,8 @@ such device).
Add some workaround for the poll()-bug in linux/glibc-2.07 reported by
Bazsi. Hmm, this is probably not a bug. I have to find out what the
right way is to handle the poll conditions POLLERR, POLLHUP and
POLLERR. For a start, the fd-list passed to poll should include only
fd:s that we are actually interested in.
Implement some limit on the amount of data that may be buffered for
write on a connection. When the limit is exceeded, the connection
## Process this file with make_am to produce
EXTRA_DIST = compiler.scm gaba.scm make-char-classes.scm \
guile-compat.scm scsh-compat.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)))
(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)))
This diff is collapsed.
;; guile.scm
;; Extra definitions needed when using guile .
;; $Id$
;; lsh, an implementation of the ssh protocol
;; Copyright (C) 1999 Tommy Virtanen, Niels Mller
;; This program 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 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
(use-modules (ice-9 slib))
(require 'macro-by-example)
(require 'format)
(define error-output-port current-error-port)
(define ascii->char integer->char)
(define char->ascii char->integer)
(define write-string display)
;; Implementation of the charset abstraction
(define (is-in-charset? set n)
(not (zero? (char->integer (string-ref set n)))))
(define (char-set-members char-set)
(define (helper n)
(cond ((>= n 256) '())
((is-in-charset? char-set n) (cons (integer->char n)
(helper (1+ n))))
(else (helper (1+ n)))))
(helper 0))
(define (ascii-range->char-set lower upper)
(do ((result (make-string 256 (integer->char 0)))
(i lower (+ i 1)))
((= i upper) result)
(string-set! result i (integer->char 1))))
(define (chars->char-set chars)
(do ((result (make-string 256 (integer->char 0)))
(chars chars (cdr chars)))
((null? chars) result)
(string-set! result (char->integer (car chars)) (integer->char 1))))
(define (string->char-set str)
(chars->char-set (string->list str)))
(define (char-set-intersection set1 set2)
(do ((result (make-string 256))
(i 0 (+ i 1)))
((= i 255) result)
(string-set! result i
(if (and (is-in-charset? set1 i) (is-in-charset? set2 i))
(integer->char 1)
(integer->char 0)))))
(define (char-set-union set1 set2)
(do ((result (make-string 256))
(i 0 (+ i 1)))
((= i 255) result)
(string-set! result i
(if (or (is-in-charset? set1 i) (is-in-charset? set2 i))
(integer->char 1)
(integer->char 0)))))
(define (char-set-difference set1 set2)
(do ((result (make-string 256))
(i 0 (+ i 1)))
((= i 255) result)
(string-set! result i
(if (and (is-in-charset? set1 i)
(not (is-in-charset? set2 i)))
(integer->char 1)
(integer->char 0)))))
(define (nth l n)
(cond ((< n 0) (error "nth: negative index not allowed" n))
((null? l) (error "nth: index too big" n))
((= n 0) (car l))
(else (nth (cdr l) (-1+ n)))))
;; make-char-classes.scm
;; Run with
;; $ scsh -e main -l scsh-compat.scm -s make-char-classes.scm
;; $ guile -e main -l guile-compat.scm -s make-char-classes.scm
;; 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))