~ chicken-core (chicken-5) 67b43481415918b74e09639d6058d40dd7d9f586
commit 67b43481415918b74e09639d6058d40dd7d9f586
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Nov 22 12:37:35 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Dec 3 17:15:40 2009 +0100
replaced silex with feeley's compiler
diff --git a/distribution/manifest b/distribution/manifest
index 128ff8ff..e0efa5d0 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -199,7 +199,8 @@ tests/re-tests.txt
tests/lolevel-tests.scm
tests/feeley-dynwind.scm
tests/compiler-syntax-tests.scm
-tests/silex.scm
+tests/compiler.scm
+tests/fft.scm
tweaks.scm
utils.scm
apply-hack.x86.S
diff --git a/tests/compiler.scm b/tests/compiler.scm
new file mode 100644
index 00000000..8a63a77e
--- /dev/null
+++ b/tests/compiler.scm
@@ -0,0 +1,11725 @@
+(define compiler-iters 300)
+
+(define (fatal-error . args)
+ (for-each display args)
+ (newline)
+ (exit 1))
+
+ (define (call-with-output-file/truncate filename proc)
+ (call-with-output-file filename proc))
+
+(define (run-bench name count ok? run)
+ (let loop ((i count) (result '(undefined)))
+ (if (< 0 i)
+ (loop (- i 1) (run))
+ result)))
+
+(define (run-benchmark name count ok? run-maker . args)
+ (newline)
+ (let* ((run (apply run-maker args))
+ (result (run-bench name count ok? run)))
+ (if (not (ok? result))
+ (begin
+ (display "*** wrong result ***")
+ (newline)
+ (display "*** got: ")
+ (pp result)
+ (newline))))
+ (exit 0))
+;(define integer->char ascii->char)
+;(define char->integer char->ascii)
+
+(define open-input-file* open-input-file)
+(define (pp-expression expr port) (write expr port) (newline port))
+(define (write-returning-len obj port) (write obj port) 1)
+(define (display-returning-len obj port) (display obj port) 1)
+(define (write-word w port)
+ (write-char (integer->char (quotient w 256)) port)
+ (write-char (integer->char (modulo w 256)) port))
+(define char-nul (integer->char 0))
+(define char-tab (integer->char 9))
+(define char-newline (integer->char 10))
+(define character-encoding char->integer)
+(define max-character-encoding 255)
+(define (fatal-err msg arg) (fatal-error msg arg))
+(define (scheme-global-var name) name)
+(define (scheme-global-var-ref var) (scheme-global-eval var fatal-err))
+(define (scheme-global-var-set! var val)
+ (scheme-global-eval (list 'set! var (list 'quote val)) fatal-err))
+(define (scheme-global-eval expr err) `(eval ,expr)) ;; eval not needed for test
+(define (pinpoint-error filename line char) #t)
+(define file-path-sep #\:)
+(define file-ext-sep #\.)
+(define (path-absolute? x)
+ (and (> (string-length x) 0)
+ (let ((c (string-ref x 0))) (or (char=? c #\/) (char=? c #\~)))))
+(define (file-path x)
+ (let loop1 ((i (string-length x)))
+ (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
+ (loop1 (- i 1))
+ (let ((result (make-string i)))
+ (let loop2 ((j (- i 1)))
+ (if (< j 0)
+ result
+ (begin
+ (string-set! result j (string-ref x j))
+ (loop2 (- j 1)))))))))
+(define (file-name x)
+ (let loop1 ((i (string-length x)))
+ (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
+ (loop1 (- i 1))
+ (let ((result (make-string (- (string-length x) i))))
+ (let loop2 ((j (- (string-length x) 1)))
+ (if (< j i)
+ result
+ (begin
+ (string-set! result (- j i) (string-ref x j))
+ (loop2 (- j 1)))))))))
+(define (file-ext x)
+ (let loop1 ((i (string-length x)))
+ (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
+ #f
+ (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
+ (loop1 (- i 1))
+ (let ((result (make-string (- (string-length x) i))))
+ (let loop2 ((j (- (string-length x) 1)))
+ (if (< j i)
+ result
+ (begin
+ (string-set! result (- j i) (string-ref x j))
+ (loop2 (- j 1))))))))))
+(define (file-root x)
+ (let loop1 ((i (string-length x)))
+ (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
+ x
+ (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
+ (loop1 (- i 1))
+ (let ((result (make-string (- i 1))))
+ (let loop2 ((j (- i 2)))
+ (if (< j 0)
+ result
+ (begin
+ (string-set! result j (string-ref x j))
+ (loop2 (- j 1))))))))))
+(define (make-counter next limit limit-error)
+ (lambda ()
+ (if (< next limit)
+ (let ((result next)) (set! next (+ next 1)) result)
+ (limit-error))))
+(define (pos-in-list x l)
+ (let loop ((l l) (i 0))
+ (cond ((not (pair? l)) #f)
+ ((eq? (car l) x) i)
+ (else (loop (cdr l) (+ i 1))))))
+(define (string-pos-in-list x l)
+ (let loop ((l l) (i 0))
+ (cond ((not (pair? l)) #f)
+ ((string=? (car l) x) i)
+ (else (loop (cdr l) (+ i 1))))))
+(define (nth-after l n)
+ (let loop ((l l) (n n)) (if (> n 0) (loop (cdr l) (- n 1)) l)))
+(define (pair-up l1 l2)
+ (define (pair l1 l2)
+ (if (pair? l1)
+ (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
+ '()))
+ (pair l1 l2))
+(define (my-last-pair l)
+ (let loop ((l l)) (if (pair? (cdr l)) (loop (cdr l)) l)))
+(define (sort-list l <?)
+ (define (mergesort l)
+ (define (merge l1 l2)
+ (cond ((null? l1) l2)
+ ((null? l2) l1)
+ (else
+ (let ((e1 (car l1)) (e2 (car l2)))
+ (if (<? e1 e2)
+ (cons e1 (merge (cdr l1) l2))
+ (cons e2 (merge l1 (cdr l2))))))))
+ (define (split l)
+ (if (or (null? l) (null? (cdr l))) l (cons (car l) (split (cddr l)))))
+ (if (or (null? l) (null? (cdr l)))
+ l
+ (let* ((l1 (mergesort (split l))) (l2 (mergesort (split (cdr l)))))
+ (merge l1 l2))))
+ (mergesort l))
+(define (lst->vector l)
+ (let* ((n (length l)) (v (make-vector n)))
+ (let loop ((l l) (i 0))
+ (if (pair? l)
+ (begin (vector-set! v i (car l)) (loop (cdr l) (+ i 1)))
+ v))))
+(define (vector->lst v)
+ (let loop ((l '()) (i (- (vector-length v) 1)))
+ (if (< i 0) l (loop (cons (vector-ref v i) l) (- i 1)))))
+(define (lst->string l)
+ (let* ((n (length l)) (s (make-string n)))
+ (let loop ((l l) (i 0))
+ (if (pair? l)
+ (begin (string-set! s i (car l)) (loop (cdr l) (+ i 1)))
+ s))))
+(define (string->lst s)
+ (let loop ((l '()) (i (- (string-length s) 1)))
+ (if (< i 0) l (loop (cons (string-ref s i) l) (- i 1)))))
+(define (with-exception-handling proc)
+ (let ((old-exception-handler throw-to-exception-handler))
+ (let ((val (call-with-current-continuation
+ (lambda (cont)
+ (set! throw-to-exception-handler cont)
+ (proc)))))
+ (set! throw-to-exception-handler old-exception-handler)
+ val)))
+(define (throw-to-exception-handler val)
+ (fatal-err "Internal error, no exception handler at this point" val))
+(define (compiler-error msg . args)
+ (newline)
+ (display "*** ERROR -- ")
+ (display msg)
+ (for-each (lambda (x) (display " ") (write x)) args)
+ (newline)
+ (compiler-abort))
+(define (compiler-user-error loc msg . args)
+ (newline)
+ (display "*** ERROR -- In ")
+ (locat-show loc)
+ (newline)
+ (display "*** ")
+ (display msg)
+ (for-each (lambda (x) (display " ") (write x)) args)
+ (newline)
+ (compiler-abort))
+(define (compiler-internal-error msg . args)
+ (newline)
+ (display "*** ERROR -- Compiler internal error detected")
+ (newline)
+ (display "*** in procedure ")
+ (display msg)
+ (for-each (lambda (x) (display " ") (write x)) args)
+ (newline)
+ (compiler-abort))
+(define (compiler-limitation-error msg . args)
+ (newline)
+ (display "*** ERROR -- Compiler limit reached")
+ (newline)
+ (display "*** ")
+ (display msg)
+ (for-each (lambda (x) (display " ") (write x)) args)
+ (newline)
+ (compiler-abort))
+(define (compiler-abort) (throw-to-exception-handler #f))
+(define (make-gnode label edges) (vector label edges))
+(define (gnode-label x) (vector-ref x 0))
+(define (gnode-edges x) (vector-ref x 1))
+(define (transitive-closure graph)
+ (define changed? #f)
+ (define (closure edges)
+ (list->set
+ (set-union
+ edges
+ (apply set-union
+ (map (lambda (label) (gnode-edges (gnode-find label graph)))
+ (set->list edges))))))
+ (let ((new-graph
+ (set-map (lambda (x)
+ (let ((new-edges (closure (gnode-edges x))))
+ (if (not (set-equal? new-edges (gnode-edges x)))
+ (set! changed? #t))
+ (make-gnode (gnode-label x) new-edges)))
+ graph)))
+ (if changed? (transitive-closure new-graph) new-graph)))
+(define (gnode-find label graph)
+ (define (find label l)
+ (cond ((null? l) #f)
+ ((eq? (gnode-label (car l)) label) (car l))
+ (else (find label (cdr l)))))
+ (find label (set->list graph)))
+(define (topological-sort graph)
+ (if (set-empty? graph)
+ '()
+ (let ((to-remove (or (remove-no-edges graph) (remove-cycle graph))))
+ (let ((labels (set-map gnode-label to-remove)))
+ (cons labels
+ (topological-sort
+ (set-map (lambda (x)
+ (make-gnode
+ (gnode-label x)
+ (set-difference (gnode-edges x) labels)))
+ (set-difference graph to-remove))))))))
+(define (remove-no-edges graph)
+ (let ((nodes-with-no-edges
+ (set-keep (lambda (x) (set-empty? (gnode-edges x))) graph)))
+ (if (set-empty? nodes-with-no-edges) #f nodes-with-no-edges)))
+(define (remove-cycle graph)
+ (define (remove l)
+ (let ((edges (gnode-edges (car l))))
+ (define (equal-edges? x) (set-equal? (gnode-edges x) edges))
+ (define (member-edges? x) (set-member? (gnode-label x) edges))
+ (if (set-member? (gnode-label (car l)) edges)
+ (let ((edge-graph (set-keep member-edges? graph)))
+ (if (set-every? equal-edges? edge-graph)
+ edge-graph
+ (remove (cdr l))))
+ (remove (cdr l)))))
+ (remove (set->list graph)))
+(define (list->set list) list)
+(define (set->list set) set)
+(define (set-empty) '())
+(define (set-empty? set) (null? set))
+(define (set-member? x set) (memq x set))
+(define (set-singleton x) (list x))
+(define (set-adjoin set x) (if (memq x set) set (cons x set)))
+(define (set-remove set x)
+ (cond ((null? set) '())
+ ((eq? (car set) x) (cdr set))
+ (else (cons (car set) (set-remove (cdr set) x)))))
+(define (set-equal? s1 s2)
+ (cond ((null? s1) (null? s2))
+ ((memq (car s1) s2) (set-equal? (cdr s1) (set-remove s2 (car s1))))
+ (else #f)))
+(define (set-difference set . other-sets)
+ (define (difference s1 s2)
+ (cond ((null? s1) '())
+ ((memq (car s1) s2) (difference (cdr s1) s2))
+ (else (cons (car s1) (difference (cdr s1) s2)))))
+ (n-ary difference set other-sets))
+(define (set-union . sets)
+ (define (union s1 s2)
+ (cond ((null? s1) s2)
+ ((memq (car s1) s2) (union (cdr s1) s2))
+ (else (cons (car s1) (union (cdr s1) s2)))))
+ (n-ary union '() sets))
+(define (set-intersection set . other-sets)
+ (define (intersection s1 s2)
+ (cond ((null? s1) '())
+ ((memq (car s1) s2) (cons (car s1) (intersection (cdr s1) s2)))
+ (else (intersection (cdr s1) s2))))
+ (n-ary intersection set other-sets))
+(define (n-ary function first rest)
+ (if (null? rest)
+ first
+ (n-ary function (function first (car rest)) (cdr rest))))
+(define (set-keep keep? set)
+ (cond ((null? set) '())
+ ((keep? (car set)) (cons (car set) (set-keep keep? (cdr set))))
+ (else (set-keep keep? (cdr set)))))
+(define (set-every? pred? set)
+ (or (null? set) (and (pred? (car set)) (set-every? pred? (cdr set)))))
+(define (set-map proc set)
+ (if (null? set) '() (cons (proc (car set)) (set-map proc (cdr set)))))
+(define (list->queue list)
+ (cons list (if (pair? list) (my-last-pair list) '())))
+(define (queue->list queue) (car queue))
+(define (queue-empty) (cons '() '()))
+(define (queue-empty? queue) (null? (car queue)))
+(define (queue-get! queue)
+ (if (null? (car queue))
+ (compiler-internal-error "queue-get!, queue is empty")
+ (let ((x (caar queue)))
+ (set-car! queue (cdar queue))
+ (if (null? (car queue)) (set-cdr! queue '()))
+ x)))
+(define (queue-put! queue x)
+ (let ((entry (cons x '())))
+ (if (null? (car queue))
+ (set-car! queue entry)
+ (set-cdr! (cdr queue) entry))
+ (set-cdr! queue entry)
+ x))
+(define (string->canonical-symbol str)
+ (let ((len (string-length str)))
+ (let loop ((str str) (s (make-string len)) (i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (string-set! s i (char-downcase (string-ref str i)))
+ (loop str s (- i 1)))
+ (string->symbol s)))))
+(define quote-sym (string->canonical-symbol "QUOTE"))
+(define quasiquote-sym (string->canonical-symbol "QUASIQUOTE"))
+(define unquote-sym (string->canonical-symbol "UNQUOTE"))
+(define unquote-splicing-sym (string->canonical-symbol "UNQUOTE-SPLICING"))
+(define lambda-sym (string->canonical-symbol "LAMBDA"))
+(define if-sym (string->canonical-symbol "IF"))
+(define set!-sym (string->canonical-symbol "SET!"))
+(define cond-sym (string->canonical-symbol "COND"))
+(define =>-sym (string->canonical-symbol "=>"))
+(define else-sym (string->canonical-symbol "ELSE"))
+(define and-sym (string->canonical-symbol "AND"))
+(define or-sym (string->canonical-symbol "OR"))
+(define case-sym (string->canonical-symbol "CASE"))
+(define let-sym (string->canonical-symbol "LET"))
+(define let*-sym (string->canonical-symbol "LET*"))
+(define letrec-sym (string->canonical-symbol "LETREC"))
+(define begin-sym (string->canonical-symbol "BEGIN"))
+(define do-sym (string->canonical-symbol "DO"))
+(define define-sym (string->canonical-symbol "DEFINE"))
+(define delay-sym (string->canonical-symbol "DELAY"))
+(define future-sym (string->canonical-symbol "FUTURE"))
+(define **define-macro-sym (string->canonical-symbol "DEFINE-MACRO"))
+(define **declare-sym (string->canonical-symbol "DECLARE"))
+(define **include-sym (string->canonical-symbol "INCLUDE"))
+(define not-sym (string->canonical-symbol "NOT"))
+(define **c-declaration-sym (string->canonical-symbol "C-DECLARATION"))
+(define **c-init-sym (string->canonical-symbol "C-INIT"))
+(define **c-procedure-sym (string->canonical-symbol "C-PROCEDURE"))
+(define void-sym (string->canonical-symbol "VOID"))
+(define char-sym (string->canonical-symbol "CHAR"))
+(define signed-char-sym (string->canonical-symbol "SIGNED-CHAR"))
+(define unsigned-char-sym (string->canonical-symbol "UNSIGNED-CHAR"))
+(define short-sym (string->canonical-symbol "SHORT"))
+(define unsigned-short-sym (string->canonical-symbol "UNSIGNED-SHORT"))
+(define int-sym (string->canonical-symbol "INT"))
+(define unsigned-int-sym (string->canonical-symbol "UNSIGNED-INT"))
+(define long-sym (string->canonical-symbol "LONG"))
+(define unsigned-long-sym (string->canonical-symbol "UNSIGNED-LONG"))
+(define float-sym (string->canonical-symbol "FLOAT"))
+(define double-sym (string->canonical-symbol "DOUBLE"))
+(define pointer-sym (string->canonical-symbol "POINTER"))
+(define boolean-sym (string->canonical-symbol "BOOLEAN"))
+(define string-sym (string->canonical-symbol "STRING"))
+(define scheme-object-sym (string->canonical-symbol "SCHEME-OBJECT"))
+(define c-id-prefix "___")
+(define false-object (if (eq? '() #f) (string->symbol "#f") #f))
+(define (false-object? obj) (eq? obj false-object))
+(define undef-object (string->symbol "#[undefined]"))
+(define (undef-object? obj) (eq? obj undef-object))
+(define (symbol-object? obj)
+ (and (not (false-object? obj)) (not (undef-object? obj)) (symbol? obj)))
+(define scm-file-exts '("scm" #f))
+(define compiler-version "2.2.2")
+(define (open-sf filename)
+ (define (open-err) (compiler-error "Can't find file" filename))
+ (if (not (file-ext filename))
+ (let loop ((exts scm-file-exts))
+ (if (pair? exts)
+ (let* ((ext (car exts))
+ (full-name
+ (if ext (string-append filename "." ext) filename))
+ (port (open-input-file* full-name)))
+ (if port (vector port full-name 0 1 0) (loop (cdr exts))))
+ (open-err)))
+ (let ((port (open-input-file* filename)))
+ (if port (vector port filename 0 1 0) (open-err)))))
+(define (close-sf sf) (close-input-port (vector-ref sf 0)))
+(define (sf-read-char sf)
+ (let ((c (read-char (vector-ref sf 0))))
+ (cond ((eof-object? c))
+ ((char=? c char-newline)
+ (vector-set! sf 3 (+ (vector-ref sf 3) 1))
+ (vector-set! sf 4 0))
+ (else (vector-set! sf 4 (+ (vector-ref sf 4) 1))))
+ c))
+(define (sf-peek-char sf) (peek-char (vector-ref sf 0)))
+(define (sf-read-error sf msg . args)
+ (apply compiler-user-error
+ (cons (sf->locat sf)
+ (cons (string-append "Read error -- " msg) args))))
+(define (sf->locat sf)
+ (vector 'file
+ (vector-ref sf 1)
+ (vector-ref sf 2)
+ (vector-ref sf 3)
+ (vector-ref sf 4)))
+(define (expr->locat expr source) (vector 'expr expr source))
+(define (locat-show loc)
+ (if loc
+ (case (vector-ref loc 0)
+ ((file)
+ (if (pinpoint-error
+ (vector-ref loc 1)
+ (vector-ref loc 3)
+ (vector-ref loc 4))
+ (begin
+ (display "file \"")
+ (display (vector-ref loc 1))
+ (display "\", line ")
+ (display (vector-ref loc 3))
+ (display ", character ")
+ (display (vector-ref loc 4)))))
+ ((expr)
+ (display "expression ")
+ (write (vector-ref loc 1))
+ (if (vector-ref loc 2)
+ (begin
+ (display " ")
+ (locat-show (source-locat (vector-ref loc 2))))))
+ (else (compiler-internal-error "locat-show, unknown location tag")))
+ (display "unknown location")))
+(define (locat-filename loc)
+ (if loc
+ (case (vector-ref loc 0)
+ ((file) (vector-ref loc 1))
+ ((expr)
+ (let ((source (vector-ref loc 2)))
+ (if source (locat-filename (source-locat source)) "")))
+ (else
+ (compiler-internal-error "locat-filename, unknown location tag")))
+ ""))
+(define (make-source code locat) (vector code locat))
+(define (source-code x) (vector-ref x 0))
+(define (source-code-set! x y) (vector-set! x 0 y) x)
+(define (source-locat x) (vector-ref x 1))
+(define (expression->source expr source)
+ (define (expr->source x)
+ (make-source
+ (cond ((pair? x) (list->source x))
+ ((vector? x) (vector->source x))
+ ((symbol-object? x) (string->canonical-symbol (symbol->string x)))
+ (else x))
+ (expr->locat x source)))
+ (define (list->source l)
+ (cond ((pair? l) (cons (expr->source (car l)) (list->source (cdr l))))
+ ((null? l) '())
+ (else (expr->source l))))
+ (define (vector->source v)
+ (let* ((len (vector-length v)) (x (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! x i (expr->source (vector-ref v i)))
+ (loop (- i 1)))))
+ x))
+ (expr->source expr))
+(define (source->expression source)
+ (define (list->expression l)
+ (cond ((pair? l)
+ (cons (source->expression (car l)) (list->expression (cdr l))))
+ ((null? l) '())
+ (else (source->expression l))))
+ (define (vector->expression v)
+ (let* ((len (vector-length v)) (x (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! x i (source->expression (vector-ref v i)))
+ (loop (- i 1)))))
+ x))
+ (let ((code (source-code source)))
+ (cond ((pair? code) (list->expression code))
+ ((vector? code) (vector->expression code))
+ (else code))))
+(define (file->sources filename info-port)
+ (if info-port
+ (begin
+ (display "(reading \"" info-port)
+ (display filename info-port)
+ (display "\"" info-port)))
+ (let ((sf (open-sf filename)))
+ (define (read-sources)
+ (let ((source (read-source sf)))
+ (if (not (eof-object? source))
+ (begin
+ (if info-port (display "." info-port))
+ (cons source (read-sources)))
+ '())))
+ (let ((sources (read-sources)))
+ (if info-port (display ")" info-port))
+ (close-sf sf)
+ sources)))
+(define (file->sources* filename info-port loc)
+ (file->sources
+ (if (path-absolute? filename)
+ filename
+ (string-append (file-path (locat-filename loc)) filename))
+ info-port))
+(define (read-source sf)
+ (define (read-char*)
+ (let ((c (sf-read-char sf)))
+ (if (eof-object? c)
+ (sf-read-error sf "Premature end of file encountered")
+ c)))
+ (define (read-non-whitespace-char)
+ (let ((c (read-char*)))
+ (cond ((< 0 (vector-ref read-table (char->integer c)))
+ (read-non-whitespace-char))
+ ((char=? c #\;)
+ (let loop ()
+ (if (not (char=? (read-char*) char-newline))
+ (loop)
+ (read-non-whitespace-char))))
+ (else c))))
+ (define (delimiter? c)
+ (or (eof-object? c) (not (= (vector-ref read-table (char->integer c)) 0))))
+ (define (read-list first)
+ (let ((result (cons first '())))
+ (let loop ((end result))
+ (let ((c (read-non-whitespace-char)))
+ (cond ((char=? c #\)))
+ ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
+ (let ((x (read-source sf)))
+ (if (char=? (read-non-whitespace-char) #\))
+ (set-cdr! end x)
+ (sf-read-error sf "')' expected"))))
+ (else
+ (let ((tail (cons (rd* c) '())))
+ (set-cdr! end tail)
+ (loop tail))))))
+ result))
+ (define (read-vector)
+ (define (loop i)
+ (let ((c (read-non-whitespace-char)))
+ (if (char=? c #\))
+ (make-vector i '())
+ (let* ((x (rd* c)) (v (loop (+ i 1)))) (vector-set! v i x) v))))
+ (loop 0))
+ (define (read-string)
+ (define (loop i)
+ (let ((c (read-char*)))
+ (cond ((char=? c #\") (make-string i #\space))
+ ((char=? c #\\)
+ (let* ((c (read-char*)) (s (loop (+ i 1))))
+ (string-set! s i c)
+ s))
+ (else (let ((s (loop (+ i 1)))) (string-set! s i c) s)))))
+ (loop 0))
+ (define (read-symbol/number-string i)
+ (if (delimiter? (sf-peek-char sf))
+ (make-string i #\space)
+ (let* ((c (sf-read-char sf)) (s (read-symbol/number-string (+ i 1))))
+ (string-set! s i (char-downcase c))
+ s)))
+ (define (read-symbol/number c)
+ (let ((s (read-symbol/number-string 1)))
+ (string-set! s 0 (char-downcase c))
+ (or (string->number s 10) (string->canonical-symbol s))))
+ (define (read-prefixed-number c)
+ (let ((s (read-symbol/number-string 2)))
+ (string-set! s 0 #\#)
+ (string-set! s 1 c)
+ (string->number s 10)))
+ (define (read-special-symbol)
+ (let ((s (read-symbol/number-string 2)))
+ (string-set! s 0 #\#)
+ (string-set! s 1 #\#)
+ (string->canonical-symbol s)))
+ (define (rd c)
+ (cond ((eof-object? c) c)
+ ((< 0 (vector-ref read-table (char->integer c)))
+ (rd (sf-read-char sf)))
+ ((char=? c #\;)
+ (let loop ()
+ (let ((c (sf-read-char sf)))
+ (cond ((eof-object? c) c)
+ ((char=? c char-newline) (rd (sf-read-char sf)))
+ (else (loop))))))
+ (else (rd* c))))
+ (define (rd* c)
+ (let ((source (make-source #f (sf->locat sf))))
+ (source-code-set!
+ source
+ (cond ((char=? c #\()
+ (let ((x (read-non-whitespace-char)))
+ (if (char=? x #\)) '() (read-list (rd* x)))))
+ ((char=? c #\#)
+ (let ((c (char-downcase (sf-read-char sf))))
+ (cond ((char=? c #\() (read-vector))
+ ((char=? c #\f) false-object)
+ ((char=? c #\t) #t)
+ ((char=? c #\\)
+ (let ((c (read-char*)))
+ (if (or (not (char-alphabetic? c))
+ (delimiter? (sf-peek-char sf)))
+ c
+ (let ((name (read-symbol/number c)))
+ (let ((x (assq name named-char-table)))
+ (if x
+ (cdr x)
+ (sf-read-error
+ sf
+ "Unknown character name"
+ name)))))))
+ ((char=? c #\#) (read-special-symbol))
+ (else
+ (let ((num (read-prefixed-number c)))
+ (or num
+ (sf-read-error
+ sf
+ "Unknown '#' read macro"
+ c)))))))
+ ((char=? c #\") (read-string))
+ ((char=? c #\')
+ (list (make-source quote-sym (sf->locat sf)) (read-source sf)))
+ ((char=? c #\`)
+ (list (make-source quasiquote-sym (sf->locat sf))
+ (read-source sf)))
+ ((char=? c #\,)
+ (if (char=? (sf-peek-char sf) #\@)
+ (let ((x (make-source unquote-splicing-sym (sf->locat sf))))
+ (sf-read-char sf)
+ (list x (read-source sf)))
+ (list (make-source unquote-sym (sf->locat sf))
+ (read-source sf))))
+ ((char=? c #\)) (sf-read-error sf "Misplaced ')'"))
+ ((or (char=? c #\[) (char=? c #\]) (char=? c #\{) (char=? c #\}))
+ (sf-read-error sf "Illegal character" c))
+ (else
+ (if (char=? c #\.)
+ (if (delimiter? (sf-peek-char sf))
+ (sf-read-error sf "Misplaced '.'")))
+ (read-symbol/number c))))))
+ (rd (sf-read-char sf)))
+(define named-char-table
+ (list (cons (string->canonical-symbol "NUL") char-nul)
+ (cons (string->canonical-symbol "TAB") char-tab)
+ (cons (string->canonical-symbol "NEWLINE") char-newline)
+ (cons (string->canonical-symbol "SPACE") #\space)))
+(define read-table
+ (let ((rt (make-vector (+ max-character-encoding 1) 0)))
+ (vector-set! rt (char->integer char-tab) 1)
+ (vector-set! rt (char->integer char-newline) 1)
+ (vector-set! rt (char->integer #\space) 1)
+ (vector-set! rt (char->integer #\;) -1)
+ (vector-set! rt (char->integer #\() -1)
+ (vector-set! rt (char->integer #\)) -1)
+ (vector-set! rt (char->integer #\") -1)
+ (vector-set! rt (char->integer #\') -1)
+ (vector-set! rt (char->integer #\`) -1)
+ rt))
+(define (make-var name bound refs sets source)
+ (vector var-tag name bound refs sets source #f))
+(define (var? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) var-tag)))
+(define (var-name x) (vector-ref x 1))
+(define (var-bound x) (vector-ref x 2))
+(define (var-refs x) (vector-ref x 3))
+(define (var-sets x) (vector-ref x 4))
+(define (var-source x) (vector-ref x 5))
+(define (var-info x) (vector-ref x 6))
+(define (var-name-set! x y) (vector-set! x 1 y))
+(define (var-bound-set! x y) (vector-set! x 2 y))
+(define (var-refs-set! x y) (vector-set! x 3 y))
+(define (var-sets-set! x y) (vector-set! x 4 y))
+(define (var-source-set! x y) (vector-set! x 5 y))
+(define (var-info-set! x y) (vector-set! x 6 y))
+(define var-tag (list 'var-tag))
+(define (var-copy var)
+ (make-var (var-name var) #t (set-empty) (set-empty) (var-source var)))
+(define (make-temp-var name) (make-var name #t (set-empty) (set-empty) #f))
+(define (temp-var? var) (eq? (var-bound var) #t))
+(define ret-var (make-temp-var 'ret))
+(define ret-var-set (set-singleton ret-var))
+(define closure-env-var (make-temp-var 'closure-env))
+(define empty-var (make-temp-var #f))
+(define make-global-environment #f)
+(set! make-global-environment (lambda () (env-frame #f '())))
+(define (env-frame env vars) (vector (cons vars #f) '() '() env))
+(define (env-new-var! env name source)
+ (let* ((glob (not (env-parent-ref env)))
+ (var (make-var name (not glob) (set-empty) (set-empty) source)))
+ (env-vars-set! env (cons var (env-vars-ref env)))
+ var))
+(define (env-macro env name def)
+ (let ((name* (if (full-name? name)
+ name
+ (let ((prefix (env-namespace-prefix env name)))
+ (if prefix (make-full-name prefix name) name)))))
+ (vector (vector-ref env 0)
+ (cons (cons name* def) (env-macros-ref env))
+ (env-decls-ref env)
+ (env-parent-ref env))))
+(define (env-declare env decl)
+ (vector (vector-ref env 0)
+ (env-macros-ref env)
+ (cons decl (env-decls-ref env))
+ (env-parent-ref env)))
+(define (env-vars-ref env) (car (vector-ref env 0)))
+(define (env-vars-set! env vars) (set-car! (vector-ref env 0) vars))
+(define (env-macros-ref env) (vector-ref env 1))
+(define (env-decls-ref env) (vector-ref env 2))
+(define (env-parent-ref env) (vector-ref env 3))
+(define (env-namespace-prefix env name)
+ (let loop ((decls (env-decls-ref env)))
+ (if (pair? decls)
+ (let ((decl (car decls)))
+ (if (eq? (car decl) namespace-sym)
+ (let ((syms (cddr decl)))
+ (if (or (null? syms) (memq name syms))
+ (cadr decl)
+ (loop (cdr decls))))
+ (loop (cdr decls))))
+ #f)))
+(define (env-lookup env name stop-at-first-frame? proc)
+ (define (search env name full?)
+ (if full?
+ (search* env name full?)
+ (let ((prefix (env-namespace-prefix env name)))
+ (if prefix
+ (search* env (make-full-name prefix name) #t)
+ (search* env name full?)))))
+ (define (search* env name full?)
+ (define (search-macros macros)
+ (if (pair? macros)
+ (let ((m (car macros)))
+ (if (eq? (car m) name)
+ (proc env name (cdr m))
+ (search-macros (cdr macros))))
+ (search-vars (env-vars-ref env))))
+ (define (search-vars vars)
+ (if (pair? vars)
+ (let ((v (car vars)))
+ (if (eq? (var-name v) name)
+ (proc env name v)
+ (search-vars (cdr vars))))
+ (let ((env* (env-parent-ref env)))
+ (if (or stop-at-first-frame? (not env*))
+ (proc env name #f)
+ (search env* name full?)))))
+ (search-macros (env-macros-ref env)))
+ (search env name (full-name? name)))
+(define (valid-prefix? str)
+ (let ((l (string-length str)))
+ (or (= l 0) (and (>= l 2) (char=? (string-ref str (- l 1)) #\#)))))
+(define (full-name? sym)
+ (let ((str (symbol->string sym)))
+ (let loop ((i (- (string-length str) 1)))
+ (if (< i 0) #f (if (char=? (string-ref str i) #\#) #t (loop (- i 1)))))))
+(define (make-full-name prefix sym)
+ (if (= (string-length prefix) 0)
+ sym
+ (string->canonical-symbol (string-append prefix (symbol->string sym)))))
+(define (env-lookup-var env name source)
+ (env-lookup
+ env
+ name
+ #f
+ (lambda (env name x)
+ (if x
+ (if (var? x)
+ x
+ (compiler-internal-error
+ "env-lookup-var, name is that of a macro"
+ name))
+ (env-new-var! env name source)))))
+(define (env-define-var env name source)
+ (env-lookup
+ env
+ name
+ #t
+ (lambda (env name x)
+ (if x
+ (if (var? x)
+ (pt-syntax-error source "Duplicate definition of a variable")
+ (compiler-internal-error
+ "env-define-var, name is that of a macro"
+ name))
+ (env-new-var! env name source)))))
+(define (env-lookup-global-var env name)
+ (let ((env* (env-global-env env)))
+ (define (search-vars vars)
+ (if (pair? vars)
+ (let ((v (car vars)))
+ (if (eq? (var-name v) name) v (search-vars (cdr vars))))
+ (env-new-var! env* name #f)))
+ (search-vars (env-vars-ref env*))))
+(define (env-global-variables env) (env-vars-ref (env-global-env env)))
+(define (env-global-env env)
+ (let loop ((env env))
+ (let ((env* (env-parent-ref env))) (if env* (loop env*) env))))
+(define (env-lookup-macro env name)
+ (env-lookup
+ env
+ name
+ #f
+ (lambda (env name x) (if (or (not x) (var? x)) #f x))))
+(define (env-declarations env) env)
+(define flag-declarations '())
+(define parameterized-declarations '())
+(define boolean-declarations '())
+(define namable-declarations '())
+(define namable-boolean-declarations '())
+(define namable-string-declarations '())
+(define (define-flag-decl name type)
+ (set! flag-declarations (cons (cons name type) flag-declarations))
+ '())
+(define (define-parameterized-decl name)
+ (set! parameterized-declarations (cons name parameterized-declarations))
+ '())
+(define (define-boolean-decl name)
+ (set! boolean-declarations (cons name boolean-declarations))
+ '())
+(define (define-namable-decl name type)
+ (set! namable-declarations (cons (cons name type) namable-declarations))
+ '())
+(define (define-namable-boolean-decl name)
+ (set! namable-boolean-declarations (cons name namable-boolean-declarations))
+ '())
+(define (define-namable-string-decl name)
+ (set! namable-string-declarations (cons name namable-string-declarations))
+ '())
+(define (flag-decl source type val) (list type val))
+(define (parameterized-decl source id parm) (list id parm))
+(define (boolean-decl source id pos) (list id pos))
+(define (namable-decl source type val names) (cons type (cons val names)))
+(define (namable-boolean-decl source id pos names) (cons id (cons pos names)))
+(define (namable-string-decl source id str names)
+ (if (and (eq? id namespace-sym) (not (valid-prefix? str)))
+ (pt-syntax-error source "Illegal namespace"))
+ (cons id (cons str names)))
+(define (declaration-value name element default decls)
+ (if (not decls)
+ default
+ (let loop ((l (env-decls-ref decls)))
+ (if (pair? l)
+ (let ((d (car l)))
+ (if (and (eq? (car d) name)
+ (or (null? (cddr d)) (memq element (cddr d))))
+ (cadr d)
+ (loop (cdr l))))
+ (declaration-value name element default (env-parent-ref decls))))))
+(define namespace-sym (string->canonical-symbol "NAMESPACE"))
+(define-namable-string-decl namespace-sym)
+(define (node-parent x) (vector-ref x 1))
+(define (node-children x) (vector-ref x 2))
+(define (node-fv x) (vector-ref x 3))
+(define (node-decl x) (vector-ref x 4))
+(define (node-source x) (vector-ref x 5))
+(define (node-parent-set! x y) (vector-set! x 1 y))
+(define (node-fv-set! x y) (vector-set! x 3 y))
+(define (node-decl-set! x y) (vector-set! x 4 y))
+(define (node-source-set! x y) (vector-set! x 5 y))
+(define (node-children-set! x y)
+ (vector-set! x 2 y)
+ (for-each (lambda (child) (node-parent-set! child x)) y)
+ (node-fv-invalidate! x))
+(define (node-fv-invalidate! x)
+ (let loop ((node x))
+ (if node (begin (node-fv-set! node #t) (loop (node-parent node))))))
+(define (make-cst parent children fv decl source val)
+ (vector cst-tag parent children fv decl source val))
+(define (cst? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) cst-tag)))
+(define (cst-val x) (vector-ref x 6))
+(define (cst-val-set! x y) (vector-set! x 6 y))
+(define cst-tag (list 'cst-tag))
+(define (make-ref parent children fv decl source var)
+ (vector ref-tag parent children fv decl source var))
+(define (ref? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) ref-tag)))
+(define (ref-var x) (vector-ref x 6))
+(define (ref-var-set! x y) (vector-set! x 6 y))
+(define ref-tag (list 'ref-tag))
+(define (make-set parent children fv decl source var)
+ (vector set-tag parent children fv decl source var))
+(define (set? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) set-tag)))
+(define (set-var x) (vector-ref x 6))
+(define (set-var-set! x y) (vector-set! x 6 y))
+(define set-tag (list 'set-tag))
+(define (make-def parent children fv decl source var)
+ (vector def-tag parent children fv decl source var))
+(define (def? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) def-tag)))
+(define (def-var x) (vector-ref x 6))
+(define (def-var-set! x y) (vector-set! x 6 y))
+(define def-tag (list 'def-tag))
+(define (make-tst parent children fv decl source)
+ (vector tst-tag parent children fv decl source))
+(define (tst? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) tst-tag)))
+(define tst-tag (list 'tst-tag))
+(define (make-conj parent children fv decl source)
+ (vector conj-tag parent children fv decl source))
+(define (conj? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) conj-tag)))
+(define conj-tag (list 'conj-tag))
+(define (make-disj parent children fv decl source)
+ (vector disj-tag parent children fv decl source))
+(define (disj? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) disj-tag)))
+(define disj-tag (list 'disj-tag))
+(define (make-prc parent children fv decl source name min rest parms)
+ (vector prc-tag parent children fv decl source name min rest parms))
+(define (prc? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) prc-tag)))
+(define (prc-name x) (vector-ref x 6))
+(define (prc-min x) (vector-ref x 7))
+(define (prc-rest x) (vector-ref x 8))
+(define (prc-parms x) (vector-ref x 9))
+(define (prc-name-set! x y) (vector-set! x 6 y))
+(define (prc-min-set! x y) (vector-set! x 7 y))
+(define (prc-rest-set! x y) (vector-set! x 8 y))
+(define (prc-parms-set! x y) (vector-set! x 9 y))
+(define prc-tag (list 'prc-tag))
+(define (make-app parent children fv decl source)
+ (vector app-tag parent children fv decl source))
+(define (app? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) app-tag)))
+(define app-tag (list 'app-tag))
+(define (make-fut parent children fv decl source)
+ (vector fut-tag parent children fv decl source))
+(define (fut? x)
+ (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) fut-tag)))
+(define fut-tag (list 'fut-tag))
+(define (new-cst source decl val) (make-cst #f '() #t decl source val))
+(define (new-ref source decl var)
+ (let ((node (make-ref #f '() #t decl source var)))
+ (var-refs-set! var (set-adjoin (var-refs var) node))
+ node))
+(define (new-ref-extended-bindings source name env)
+ (new-ref source
+ (add-extended-bindings (env-declarations env))
+ (env-lookup-global-var env name)))
+(define (new-set source decl var val)
+ (let ((node (make-set #f (list val) #t decl source var)))
+ (var-sets-set! var (set-adjoin (var-sets var) node))
+ (node-parent-set! val node)
+ node))
+(define (set-val x)
+ (if (set? x)
+ (car (node-children x))
+ (compiler-internal-error "set-val, 'set' node expected" x)))
+(define (new-def source decl var val)
+ (let ((node (make-def #f (list val) #t decl source var)))
+ (var-sets-set! var (set-adjoin (var-sets var) node))
+ (node-parent-set! val node)
+ node))
+(define (def-val x)
+ (if (def? x)
+ (car (node-children x))
+ (compiler-internal-error "def-val, 'def' node expected" x)))
+(define (new-tst source decl pre con alt)
+ (let ((node (make-tst #f (list pre con alt) #t decl source)))
+ (node-parent-set! pre node)
+ (node-parent-set! con node)
+ (node-parent-set! alt node)
+ node))
+(define (tst-pre x)
+ (if (tst? x)
+ (car (node-children x))
+ (compiler-internal-error "tst-pre, 'tst' node expected" x)))
+(define (tst-con x)
+ (if (tst? x)
+ (cadr (node-children x))
+ (compiler-internal-error "tst-con, 'tst' node expected" x)))
+(define (tst-alt x)
+ (if (tst? x)
+ (caddr (node-children x))
+ (compiler-internal-error "tst-alt, 'tst' node expected" x)))
+(define (new-conj source decl pre alt)
+ (let ((node (make-conj #f (list pre alt) #t decl source)))
+ (node-parent-set! pre node)
+ (node-parent-set! alt node)
+ node))
+(define (conj-pre x)
+ (if (conj? x)
+ (car (node-children x))
+ (compiler-internal-error "conj-pre, 'conj' node expected" x)))
+(define (conj-alt x)
+ (if (conj? x)
+ (cadr (node-children x))
+ (compiler-internal-error "conj-alt, 'conj' node expected" x)))
+(define (new-disj source decl pre alt)
+ (let ((node (make-disj #f (list pre alt) #t decl source)))
+ (node-parent-set! pre node)
+ (node-parent-set! alt node)
+ node))
+(define (disj-pre x)
+ (if (disj? x)
+ (car (node-children x))
+ (compiler-internal-error "disj-pre, 'disj' node expected" x)))
+(define (disj-alt x)
+ (if (disj? x)
+ (cadr (node-children x))
+ (compiler-internal-error "disj-alt, 'disj' node expected" x)))
+(define (new-prc source decl name min rest parms body)
+ (let ((node (make-prc #f (list body) #t decl source name min rest parms)))
+ (for-each (lambda (x) (var-bound-set! x node)) parms)
+ (node-parent-set! body node)
+ node))
+(define (prc-body x)
+ (if (prc? x)
+ (car (node-children x))
+ (compiler-internal-error "prc-body, 'proc' node expected" x)))
+(define (new-call source decl oper args)
+ (let ((node (make-app #f (cons oper args) #t decl source)))
+ (node-parent-set! oper node)
+ (for-each (lambda (x) (node-parent-set! x node)) args)
+ node))
+(define (new-call* source decl oper args)
+ (if *ptree-port*
+ (if (ref? oper)
+ (let ((var (ref-var oper)))
+ (if (global? var)
+ (let ((proc (standard-procedure
+ (var-name var)
+ (node-decl oper))))
+ (if (and proc
+ (not (nb-args-conforms?
+ (length args)
+ (standard-procedure-call-pattern proc))))
+ (begin
+ (display "*** WARNING -- \"" *ptree-port*)
+ (display (var-name var) *ptree-port*)
+ (display "\" is called with " *ptree-port*)
+ (display (length args) *ptree-port*)
+ (display " argument(s)." *ptree-port*)
+ (newline *ptree-port*))))))))
+ (new-call source decl oper args))
+(define (app-oper x)
+ (if (app? x)
+ (car (node-children x))
+ (compiler-internal-error "app-oper, 'call' node expected" x)))
+(define (app-args x)
+ (if (app? x)
+ (cdr (node-children x))
+ (compiler-internal-error "app-args, 'call' node expected" x)))
+(define (oper-pos? node)
+ (let ((parent (node-parent node)))
+ (if parent (and (app? parent) (eq? (app-oper parent) node)) #f)))
+(define (new-fut source decl val)
+ (let ((node (make-fut #f (list val) #t decl source)))
+ (node-parent-set! val node)
+ node))
+(define (fut-val x)
+ (if (fut? x)
+ (car (node-children x))
+ (compiler-internal-error "fut-val, 'fut' node expected" x)))
+(define (new-disj-call source decl pre oper alt)
+ (new-call*
+ source
+ decl
+ (let* ((parms (new-temps source '(temp))) (temp (car parms)))
+ (new-prc source
+ decl
+ #f
+ 1
+ #f
+ parms
+ (new-tst source
+ decl
+ (new-ref source decl temp)
+ (new-call*
+ source
+ decl
+ oper
+ (list (new-ref source decl temp)))
+ alt)))
+ (list pre)))
+(define (new-seq source decl before after)
+ (new-call*
+ source
+ decl
+ (new-prc source decl #f 1 #f (new-temps source '(temp)) after)
+ (list before)))
+(define (new-let ptree proc vars vals body)
+ (if (pair? vars)
+ (new-call
+ (node-source ptree)
+ (node-decl ptree)
+ (new-prc (node-source proc)
+ (node-decl proc)
+ (prc-name proc)
+ (length vars)
+ #f
+ (reverse vars)
+ body)
+ (reverse vals))
+ body))
+(define (new-temps source names)
+ (if (null? names)
+ '()
+ (cons (make-var (car names) #t (set-empty) (set-empty) source)
+ (new-temps source (cdr names)))))
+(define (new-variables vars)
+ (if (null? vars)
+ '()
+ (cons (make-var
+ (source-code (car vars))
+ #t
+ (set-empty)
+ (set-empty)
+ (car vars))
+ (new-variables (cdr vars)))))
+(define (set-prc-names! vars vals)
+ (let loop ((vars vars) (vals vals))
+ (if (not (null? vars))
+ (let ((var (car vars)) (val (car vals)))
+ (if (prc? val) (prc-name-set! val (symbol->string (var-name var))))
+ (loop (cdr vars) (cdr vals))))))
+(define (free-variables node)
+ (if (eq? (node-fv node) #t)
+ (let ((x (apply set-union (map free-variables (node-children node)))))
+ (node-fv-set!
+ node
+ (cond ((ref? node)
+ (if (global? (ref-var node)) x (set-adjoin x (ref-var node))))
+ ((set? node)
+ (if (global? (set-var node)) x (set-adjoin x (set-var node))))
+ ((prc? node) (set-difference x (list->set (prc-parms node))))
+ ((and (app? node) (prc? (app-oper node)))
+ (set-difference x (list->set (prc-parms (app-oper node)))))
+ (else x)))))
+ (node-fv node))
+(define (bound-variables node) (list->set (prc-parms node)))
+(define (not-mutable? var) (set-empty? (var-sets var)))
+(define (mutable? var) (not (not-mutable? var)))
+(define (bound? var) (var-bound var))
+(define (global? var) (not (bound? var)))
+(define (global-val var)
+ (and (global? var)
+ (let ((sets (set->list (var-sets var))))
+ (and (pair? sets)
+ (null? (cdr sets))
+ (def? (car sets))
+ (eq? (compilation-strategy (node-decl (car sets))) block-sym)
+ (def-val (car sets))))))
+(define **not-sym (string->canonical-symbol "##NOT"))
+(define **quasi-append-sym (string->canonical-symbol "##QUASI-APPEND"))
+(define **quasi-list-sym (string->canonical-symbol "##QUASI-LIST"))
+(define **quasi-cons-sym (string->canonical-symbol "##QUASI-CONS"))
+(define **quasi-list->vector-sym
+ (string->canonical-symbol "##QUASI-LIST->VECTOR"))
+(define **case-memv-sym (string->canonical-symbol "##CASE-MEMV"))
+(define **unassigned?-sym (string->canonical-symbol "##UNASSIGNED?"))
+(define **make-cell-sym (string->canonical-symbol "##MAKE-CELL"))
+(define **cell-ref-sym (string->canonical-symbol "##CELL-REF"))
+(define **cell-set!-sym (string->canonical-symbol "##CELL-SET!"))
+(define **make-placeholder-sym (string->canonical-symbol "##MAKE-PLACEHOLDER"))
+(define ieee-scheme-sym (string->canonical-symbol "IEEE-SCHEME"))
+(define r4rs-scheme-sym (string->canonical-symbol "R4RS-SCHEME"))
+(define multilisp-sym (string->canonical-symbol "MULTILISP"))
+(define lambda-lift-sym (string->canonical-symbol "LAMBDA-LIFT"))
+(define block-sym (string->canonical-symbol "BLOCK"))
+(define separate-sym (string->canonical-symbol "SEPARATE"))
+(define standard-bindings-sym (string->canonical-symbol "STANDARD-BINDINGS"))
+(define extended-bindings-sym (string->canonical-symbol "EXTENDED-BINDINGS"))
+(define safe-sym (string->canonical-symbol "SAFE"))
+(define interrupts-enabled-sym (string->canonical-symbol "INTERRUPTS-ENABLED"))
+(define-flag-decl ieee-scheme-sym 'dialect)
+(define-flag-decl r4rs-scheme-sym 'dialect)
+(define-flag-decl multilisp-sym 'dialect)
+(define-boolean-decl lambda-lift-sym)
+(define-flag-decl block-sym 'compilation-strategy)
+(define-flag-decl separate-sym 'compilation-strategy)
+(define-namable-boolean-decl standard-bindings-sym)
+(define-namable-boolean-decl extended-bindings-sym)
+(define-boolean-decl safe-sym)
+(define-boolean-decl interrupts-enabled-sym)
+(define (scheme-dialect decl)
+ (declaration-value 'dialect #f ieee-scheme-sym decl))
+(define (lambda-lift? decl) (declaration-value lambda-lift-sym #f #t decl))
+(define (compilation-strategy decl)
+ (declaration-value 'compilation-strategy #f separate-sym decl))
+(define (standard-binding? name decl)
+ (declaration-value standard-bindings-sym name #f decl))
+(define (extended-binding? name decl)
+ (declaration-value extended-bindings-sym name #f decl))
+(define (add-extended-bindings decl)
+ (add-decl (list extended-bindings-sym #t) decl))
+(define (intrs-enabled? decl)
+ (declaration-value interrupts-enabled-sym #f #t decl))
+(define (add-not-interrupts-enabled decl)
+ (add-decl (list interrupts-enabled-sym #f) decl))
+(define (safe? decl) (declaration-value safe-sym #f #f decl))
+(define (add-not-safe decl) (add-decl (list safe-sym #f) decl))
+(define (dialect-specific-keywords dialect)
+ (cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-keywords)
+ ((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-keywords)
+ ((eq? dialect multilisp-sym) multilisp-specific-keywords)
+ (else
+ (compiler-internal-error
+ "dialect-specific-keywords, unknown dialect"
+ dialect))))
+(define (dialect-specific-procedures dialect)
+ (cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-procedures)
+ ((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-procedures)
+ ((eq? dialect multilisp-sym) multilisp-specific-procedures)
+ (else
+ (compiler-internal-error
+ "dialect-specific-procedures, unknown dialect"
+ dialect))))
+(define (make-standard-procedure x)
+ (cons (string->canonical-symbol (car x)) (cdr x)))
+(define (standard-procedure name decl)
+ (or (assq name (dialect-specific-procedures (scheme-dialect decl)))
+ (assq name common-procedures)))
+(define (standard-procedure-call-pattern proc) (cdr proc))
+(define ieee-scheme-specific-keywords '())
+(define ieee-scheme-specific-procedures (map make-standard-procedure '()))
+(define r4rs-scheme-specific-keywords (list delay-sym))
+(define r4rs-scheme-specific-procedures
+ (map make-standard-procedure
+ '(("LIST-TAIL" 2)
+ ("-" . 1)
+ ("/" . 1)
+ ("STRING->LIST" 1)
+ ("LIST->STRING" 1)
+ ("STRING-COPY" 1)
+ ("STRING-FILL!" 2)
+ ("VECTOR->LIST" 1)
+ ("LIST->VECTOR" 1)
+ ("VECTOR-FILL!" 2)
+ ("FORCE" 1)
+ ("WITH-INPUT-FROM-FILE" 2)
+ ("WITH-OUTPUT-TO-FILE" 2)
+ ("CHAR-READY?" 0 1)
+ ("LOAD" 1)
+ ("TRANSCRIPT-ON" 1)
+ ("TRANSCRIPT-OFF" 0))))
+(define multilisp-specific-keywords (list delay-sym future-sym))
+(define multilisp-specific-procedures
+ (map make-standard-procedure '(("FORCE" 1) ("TOUCH" 1))))
+(define common-keywords
+ (list quote-sym
+ quasiquote-sym
+ unquote-sym
+ unquote-splicing-sym
+ lambda-sym
+ if-sym
+ set!-sym
+ cond-sym
+ =>-sym
+ else-sym
+ and-sym
+ or-sym
+ case-sym
+ let-sym
+ let*-sym
+ letrec-sym
+ begin-sym
+ do-sym
+ define-sym
+ **define-macro-sym
+ **declare-sym
+ **include-sym))
+(define common-procedures
+ (map make-standard-procedure
+ '(("NOT" 1)
+ ("BOOLEAN?" 1)
+ ("EQV?" 2)
+ ("EQ?" 2)
+ ("EQUAL?" 2)
+ ("PAIR?" 1)
+ ("CONS" 2)
+ ("CAR" 1)
+ ("CDR" 1)
+ ("SET-CAR!" 2)
+ ("SET-CDR!" 2)
+ ("CAAR" 1)
+ ("CADR" 1)
+ ("CDAR" 1)
+ ("CDDR" 1)
+ ("CAAAR" 1)
+ ("CAADR" 1)
+ ("CADAR" 1)
+ ("CADDR" 1)
+ ("CDAAR" 1)
+ ("CDADR" 1)
+ ("CDDAR" 1)
+ ("CDDDR" 1)
+ ("CAAAAR" 1)
+ ("CAAADR" 1)
+ ("CAADAR" 1)
+ ("CAADDR" 1)
+ ("CADAAR" 1)
+ ("CADADR" 1)
+ ("CADDAR" 1)
+ ("CADDDR" 1)
+ ("CDAAAR" 1)
+ ("CDAADR" 1)
+ ("CDADAR" 1)
+ ("CDADDR" 1)
+ ("CDDAAR" 1)
+ ("CDDADR" 1)
+ ("CDDDAR" 1)
+ ("CDDDDR" 1)
+ ("NULL?" 1)
+ ("LIST?" 1)
+ ("LIST" . 0)
+ ("LENGTH" 1)
+ ("APPEND" . 0)
+ ("REVERSE" 1)
+ ("LIST-REF" 2)
+ ("MEMQ" 2)
+ ("MEMV" 2)
+ ("MEMBER" 2)
+ ("ASSQ" 2)
+ ("ASSV" 2)
+ ("ASSOC" 2)
+ ("SYMBOL?" 1)
+ ("SYMBOL->STRING" 1)
+ ("STRING->SYMBOL" 1)
+ ("NUMBER?" 1)
+ ("COMPLEX?" 1)
+ ("REAL?" 1)
+ ("RATIONAL?" 1)
+ ("INTEGER?" 1)
+ ("EXACT?" 1)
+ ("INEXACT?" 1)
+ ("=" . 2)
+ ("<" . 2)
+ (">" . 2)
+ ("<=" . 2)
+ (">=" . 2)
+ ("ZERO?" 1)
+ ("POSITIVE?" 1)
+ ("NEGATIVE?" 1)
+ ("ODD?" 1)
+ ("EVEN?" 1)
+ ("MAX" . 1)
+ ("MIN" . 1)
+ ("+" . 0)
+ ("*" . 0)
+ ("-" 1 2)
+ ("/" 1 2)
+ ("ABS" 1)
+ ("QUOTIENT" 2)
+ ("REMAINDER" 2)
+ ("MODULO" 2)
+ ("GCD" . 0)
+ ("LCM" . 0)
+ ("NUMERATOR" 1)
+ ("DENOMINATOR" 1)
+ ("FLOOR" 1)
+ ("CEILING" 1)
+ ("TRUNCATE" 1)
+ ("ROUND" 1)
+ ("RATIONALIZE" 2)
+ ("EXP" 1)
+ ("LOG" 1)
+ ("SIN" 1)
+ ("COS" 1)
+ ("TAN" 1)
+ ("ASIN" 1)
+ ("ACOS" 1)
+ ("ATAN" 1 2)
+ ("SQRT" 1)
+ ("EXPT" 2)
+ ("MAKE-RECTANGULAR" 2)
+ ("MAKE-POLAR" 2)
+ ("REAL-PART" 1)
+ ("IMAG-PART" 1)
+ ("MAGNITUDE" 1)
+ ("ANGLE" 1)
+ ("EXACT->INEXACT" 1)
+ ("INEXACT->EXACT" 1)
+ ("NUMBER->STRING" 1 2)
+ ("STRING->NUMBER" 1 2)
+ ("CHAR?" 1)
+ ("CHAR=?" 2)
+ ("CHAR<?" 2)
+ ("CHAR>?" 2)
+ ("CHAR<=?" 2)
+ ("CHAR>=?" 2)
+ ("CHAR-CI=?" 2)
+ ("CHAR-CI<?" 2)
+ ("CHAR-CI>?" 2)
+ ("CHAR-CI<=?" 2)
+ ("CHAR-CI>=?" 2)
+ ("CHAR-ALPHABETIC?" 1)
+ ("CHAR-NUMERIC?" 1)
+ ("CHAR-WHITESPACE?" 1)
+ ("CHAR-UPPER-CASE?" 1)
+ ("CHAR-LOWER-CASE?" 1)
+ ("CHAR->INTEGER" 1)
+ ("INTEGER->CHAR" 1)
+ ("CHAR-UPCASE" 1)
+ ("CHAR-DOWNCASE" 1)
+ ("STRING?" 1)
+ ("MAKE-STRING" 1 2)
+ ("STRING" . 0)
+ ("STRING-LENGTH" 1)
+ ("STRING-REF" 2)
+ ("STRING-SET!" 3)
+ ("STRING=?" 2)
+ ("STRING<?" 2)
+ ("STRING>?" 2)
+ ("STRING<=?" 2)
+ ("STRING>=?" 2)
+ ("STRING-CI=?" 2)
+ ("STRING-CI<?" 2)
+ ("STRING-CI>?" 2)
+ ("STRING-CI<=?" 2)
+ ("STRING-CI>=?" 2)
+ ("SUBSTRING" 3)
+ ("STRING-APPEND" . 0)
+ ("VECTOR?" 1)
+ ("MAKE-VECTOR" 1 2)
+ ("VECTOR" . 0)
+ ("VECTOR-LENGTH" 1)
+ ("VECTOR-REF" 2)
+ ("VECTOR-SET!" 3)
+ ("PROCEDURE?" 1)
+ ("APPLY" . 2)
+ ("MAP" . 2)
+ ("FOR-EACH" . 2)
+ ("CALL-WITH-CURRENT-CONTINUATION" 1)
+ ("CALL-WITH-INPUT-FILE" 2)
+ ("CALL-WITH-OUTPUT-FILE" 2)
+ ("INPUT-PORT?" 1)
+ ("OUTPUT-PORT?" 1)
+ ("CURRENT-INPUT-PORT" 0)
+ ("CURRENT-OUTPUT-PORT" 0)
+ ("OPEN-INPUT-FILE" 1)
+ ("OPEN-OUTPUT-FILE" 1)
+ ("CLOSE-INPUT-PORT" 1)
+ ("CLOSE-OUTPUT-PORT" 1)
+ ("EOF-OBJECT?" 1)
+ ("READ" 0 1)
+ ("READ-CHAR" 0 1)
+ ("PEEK-CHAR" 0 1)
+ ("WRITE" 1 2)
+ ("DISPLAY" 1 2)
+ ("NEWLINE" 0 1)
+ ("WRITE-CHAR" 1 2))))
+(define (parse-program program env module-name proc)
+ (define (parse-prog program env lst proc)
+ (if (null? program)
+ (proc (reverse lst) env)
+ (let ((source (car program)))
+ (cond ((macro-expr? source env)
+ (parse-prog
+ (cons (macro-expand source env) (cdr program))
+ env
+ lst
+ proc))
+ ((begin-defs-expr? source)
+ (parse-prog
+ (append (begin-defs-body source) (cdr program))
+ env
+ lst
+ proc))
+ ((include-expr? source)
+ (if *ptree-port* (display " " *ptree-port*))
+ (let ((x (file->sources*
+ (include-filename source)
+ *ptree-port*
+ (source-locat source))))
+ (if *ptree-port* (newline *ptree-port*))
+ (parse-prog (append x (cdr program)) env lst proc)))
+ ((define-macro-expr? source env)
+ (if *ptree-port*
+ (begin
+ (display " \"macro\"" *ptree-port*)
+ (newline *ptree-port*)))
+ (parse-prog (cdr program) (add-macro source env) lst proc))
+ ((declare-expr? source)
+ (if *ptree-port*
+ (begin
+ (display " \"decl\"" *ptree-port*)
+ (newline *ptree-port*)))
+ (parse-prog
+ (cdr program)
+ (add-declarations source env)
+ lst
+ proc))
+ ((define-expr? source env)
+ (let* ((var** (definition-variable source))
+ (var* (source-code var**))
+ (var (env-lookup-var env var* var**)))
+ (if *ptree-port*
+ (begin
+ (display " " *ptree-port*)
+ (display (var-name var) *ptree-port*)
+ (newline *ptree-port*)))
+ (let ((node (pt (definition-value source) env 'true)))
+ (set-prc-names! (list var) (list node))
+ (parse-prog
+ (cdr program)
+ env
+ (cons (cons (new-def source
+ (env-declarations env)
+ var
+ node)
+ env)
+ lst)
+ proc))))
+ ((c-declaration-expr? source)
+ (if *ptree-port*
+ (begin
+ (display " \"c-decl\"" *ptree-port*)
+ (newline *ptree-port*)))
+ (add-c-declaration (source-code (cadr (source-code source))))
+ (parse-prog (cdr program) env lst proc))
+ ((c-init-expr? source)
+ (if *ptree-port*
+ (begin
+ (display " \"c-init\"" *ptree-port*)
+ (newline *ptree-port*)))
+ (add-c-init (source-code (cadr (source-code source))))
+ (parse-prog (cdr program) env lst proc))
+ (else
+ (if *ptree-port*
+ (begin
+ (display " \"expr\"" *ptree-port*)
+ (newline *ptree-port*)))
+ (parse-prog
+ (cdr program)
+ env
+ (cons (cons (pt source env 'true) env) lst)
+ proc))))))
+ (if *ptree-port*
+ (begin (display "Parsing:" *ptree-port*) (newline *ptree-port*)))
+ (c-interface-begin module-name)
+ (parse-prog
+ program
+ env
+ '()
+ (lambda (lst env)
+ (if *ptree-port* (newline *ptree-port*))
+ (proc lst env (c-interface-end)))))
+(define (c-interface-begin module-name)
+ (set! c-interface-module-name module-name)
+ (set! c-interface-proc-count 0)
+ (set! c-interface-decls '())
+ (set! c-interface-procs '())
+ (set! c-interface-inits '())
+ #f)
+(define (c-interface-end)
+ (let ((i (make-c-intf
+ (reverse c-interface-decls)
+ (reverse c-interface-procs)
+ (reverse c-interface-inits))))
+ (set! c-interface-module-name #f)
+ (set! c-interface-proc-count #f)
+ (set! c-interface-decls #f)
+ (set! c-interface-procs #f)
+ (set! c-interface-inits #f)
+ i))
+(define c-interface-module-name #f)
+(define c-interface-proc-count #f)
+(define c-interface-decls #f)
+(define c-interface-procs #f)
+(define c-interface-inits #f)
+(define (make-c-intf decls procs inits) (vector decls procs inits))
+(define (c-intf-decls c-intf) (vector-ref c-intf 0))
+(define (c-intf-decls-set! c-intf x) (vector-set! c-intf 0 x))
+(define (c-intf-procs c-intf) (vector-ref c-intf 1))
+(define (c-intf-procs-set! c-intf x) (vector-set! c-intf 1 x))
+(define (c-intf-inits c-intf) (vector-ref c-intf 2))
+(define (c-intf-inits-set! c-intf x) (vector-set! c-intf 2 x))
+(define (c-declaration-expr? source)
+ (and (mymatch **c-declaration-sym 1 source)
+ (let ((code (source-code source)))
+ (or (string? (source-code (cadr code)))
+ (pt-syntax-error
+ source
+ "Argument to '##c-declaration' must be a string")))))
+(define (c-init-expr? source)
+ (and (mymatch **c-init-sym 1 source)
+ (let ((code (source-code source)))
+ (or (string? (source-code (cadr code)))
+ (pt-syntax-error
+ source
+ "Argument to '##c-init' must be a string")))))
+(define (c-procedure-expr? source)
+ (and (mymatch **c-procedure-sym 3 source)
+ (let ((code (source-code source)))
+ (if (not (string? (source-code (cadddr code))))
+ (pt-syntax-error
+ source
+ "Last argument to '##c-procedure' must be a string")
+ (check-arg-and-result-types source (cadr code) (caddr code))))))
+(define scheme-to-c-notation
+ (list (list void-sym "VOID" "void")
+ (list char-sym "CHAR" "char")
+ (list signed-char-sym "SCHAR" "signed char")
+ (list unsigned-char-sym "UCHAR" "unsigned char")
+ (list short-sym "SHORT" "short")
+ (list unsigned-short-sym "USHORT" "unsigned short")
+ (list int-sym "INT" "int")
+ (list unsigned-int-sym "UINT" "unsigned int")
+ (list long-sym "LONG" "long")
+ (list unsigned-long-sym "ULONG" "unsigned long")
+ (list float-sym "FLOAT" "float")
+ (list double-sym "DOUBLE" "double")
+ (list pointer-sym "POINTER" "void*")
+ (list boolean-sym "BOOLEAN" "int")
+ (list string-sym "STRING" "char*")
+ (list scheme-object-sym "SCMOBJ" "long")))
+(define (convert-type typ) (if (assq typ scheme-to-c-notation) typ #f))
+(define (check-arg-and-result-types source arg-typs-source res-typ-source)
+ (let ((arg-typs (source-code arg-typs-source))
+ (res-typ (source-code res-typ-source)))
+ (let ((res-type (convert-type res-typ)))
+ (if (not res-type)
+ (pt-syntax-error res-typ-source "Invalid result type")
+ (if (not (proper-length arg-typs))
+ (pt-syntax-error
+ arg-typs-source
+ "Ill-terminated argument type list")
+ (let loop ((lst arg-typs))
+ (if (pair? lst)
+ (let* ((arg-typ (source-code (car lst)))
+ (arg-type (convert-type arg-typ)))
+ (if (or (not arg-type) (eq? arg-type void-sym))
+ (pt-syntax-error (car lst) "Invalid argument type")
+ (loop (cdr lst))))
+ #t)))))))
+(define (add-c-declaration declaration-string)
+ (set! c-interface-decls (cons declaration-string c-interface-decls))
+ #f)
+(define (add-c-init initialization-code-string)
+ (set! c-interface-inits (cons initialization-code-string c-interface-inits))
+ #f)
+(define (add-c-proc scheme-name c-name arity def)
+ (set! c-interface-procs
+ (cons (vector scheme-name c-name arity def) c-interface-procs))
+ #f)
+(define (pt-c-procedure source env use)
+ (let* ((code (source-code source))
+ (name (build-c-procedure
+ (map source-code (source-code (cadr code)))
+ (source-code (caddr code))
+ (source-code (cadddr code))))
+ (decl (env-declarations env)))
+ (new-ref source decl (env-lookup-global-var env (string->symbol name)))))
+(define (build-c-procedure argument-types result-type proc-name-or-code)
+ (define proc-name?
+ (let loop ((i (- (string-length proc-name-or-code) 1)))
+ (if (>= i 0)
+ (let ((c (string-ref proc-name-or-code i)))
+ (if (or (char-alphabetic? c) (char=? c #\_)) (loop (- i 1)) #f))
+ #t)))
+ (define nl (string #\newline))
+ (define undefined-value "UND")
+ (define scheme-arg-prefix "ARG")
+ (define scheme-result-name "RESULT")
+ (define c-arg-prefix "arg")
+ (define c-result-name "result")
+ (define scheme-to-c-prefix "SCMOBJ_TO_")
+ (define c-to-scheme-suffix "_TO_SCMOBJ")
+ (define (c-type-name typ) (cadr (assq typ scheme-to-c-notation)))
+ (define (c-type-decl typ) (caddr (assq typ scheme-to-c-notation)))
+ (define (listify strings)
+ (if (null? strings)
+ ""
+ (string-append
+ (car strings)
+ (apply string-append
+ (map (lambda (s) (string-append "," s)) (cdr strings))))))
+ (define (scheme-arg-var t)
+ (string-append c-id-prefix scheme-arg-prefix (number->string (cdr t))))
+ (define (c-arg-var t)
+ (string-append c-id-prefix c-arg-prefix (number->string (cdr t))))
+ (define (make-c-procedure arg-types res-type)
+ (define (make-arg-decl)
+ (apply string-append
+ (map (lambda (t)
+ (string-append
+ (c-type-decl (car t))
+ " "
+ (c-arg-var t)
+ ";"
+ nl))
+ arg-types)))
+ (define (make-conversions)
+ (if (not (null? arg-types))
+ (let loop ((lst arg-types) (str (string-append "if (" nl)))
+ (if (null? lst)
+ (string-append str " )" nl)
+ (let ((t (car lst)) (rest (cdr lst)))
+ (loop rest
+ (string-append
+ str
+ " "
+ c-id-prefix
+ scheme-to-c-prefix
+ (c-type-name (car t))
+ "("
+ (scheme-arg-var t)
+ ","
+ (c-arg-var t)
+ ")"
+ (if (null? rest) "" " &&")
+ nl)))))
+ ""))
+ (define (make-body)
+ (if proc-name?
+ (let* ((param-list (listify (map c-arg-var arg-types)))
+ (call (string-append proc-name-or-code "(" param-list ")")))
+ (if (eq? res-type void-sym)
+ (string-append
+ "{"
+ nl
+ call
+ ";"
+ nl
+ c-id-prefix
+ scheme-result-name
+ " = "
+ c-id-prefix
+ undefined-value
+ ";"
+ nl
+ "}"
+ nl)
+ (string-append
+ c-id-prefix
+ (c-type-name res-type)
+ c-to-scheme-suffix
+ "("
+ call
+ ","
+ c-id-prefix
+ scheme-result-name
+ ");"
+ nl)))
+ (if (eq? res-type void-sym)
+ (string-append
+ "{"
+ nl
+ proc-name-or-code
+ nl
+ c-id-prefix
+ scheme-result-name
+ " = "
+ c-id-prefix
+ undefined-value
+ ";"
+ nl
+ "}"
+ nl)
+ (string-append
+ "{"
+ nl
+ proc-name-or-code
+ nl
+ c-id-prefix
+ (c-type-name res-type)
+ c-to-scheme-suffix
+ "("
+ c-id-prefix
+ c-result-name
+ ","
+ c-id-prefix
+ scheme-result-name
+ ");"
+ nl
+ "}"
+ nl))))
+ (let* ((index (number->string c-interface-proc-count))
+ (scheme-name (string-append "#!" c-interface-module-name "#" index))
+ (c-name (string-append c-id-prefix (scheme-id->c-id scheme-name)))
+ (arity (length argument-types))
+ (def (string-append
+ (if (or proc-name? (eq? res-type void-sym))
+ ""
+ (string-append
+ (c-type-decl res-type)
+ " "
+ c-id-prefix
+ c-result-name
+ ";"
+ nl))
+ (make-arg-decl)
+ (make-conversions)
+ (make-body))))
+ (set! c-interface-proc-count (+ c-interface-proc-count 1))
+ (add-c-proc scheme-name c-name arity def)
+ scheme-name))
+ (let loop ((i 1) (lst1 argument-types) (lst2 '()))
+ (if (pair? lst1)
+ (loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))
+ (make-c-procedure (reverse lst2) result-type))))
+(define (scheme-id->c-id s)
+ (define (hex->char i) (string-ref "0123456789abcdef" i))
+ (let loop ((i (- (string-length s) 1)) (l '()))
+ (if (>= i 0)
+ (let ((c (string-ref s i)))
+ (cond ((or (char-alphabetic? c) (char-numeric? c))
+ (loop (- i 1) (cons c l)))
+ ((char=? c #\_) (loop (- i 1) (cons c (cons c l))))
+ (else
+ (let ((n (character-encoding c)))
+ (loop (- i 1)
+ (cons #\_
+ (cons (hex->char (quotient n 16))
+ (cons (hex->char (modulo n 16)) l))))))))
+ (lst->string l))))
+(define (pt-syntax-error source msg . args)
+ (apply compiler-user-error
+ (cons (source-locat source)
+ (cons (string-append "Syntax error -- " msg) args))))
+(define (pt source env use)
+ (cond ((macro-expr? source env) (pt (macro-expand source env) env use))
+ ((self-eval-expr? source) (pt-self-eval source env use))
+ ((quote-expr? source) (pt-quote source env use))
+ ((quasiquote-expr? source) (pt-quasiquote source env use))
+ ((unquote-expr? source)
+ (pt-syntax-error source "Ill-placed 'unquote'"))
+ ((unquote-splicing-expr? source)
+ (pt-syntax-error source "Ill-placed 'unquote-splicing'"))
+ ((var-expr? source env) (pt-var source env use))
+ ((set!-expr? source env) (pt-set! source env use))
+ ((lambda-expr? source env) (pt-lambda source env use))
+ ((if-expr? source) (pt-if source env use))
+ ((cond-expr? source) (pt-cond source env use))
+ ((and-expr? source) (pt-and source env use))
+ ((or-expr? source) (pt-or source env use))
+ ((case-expr? source) (pt-case source env use))
+ ((let-expr? source env) (pt-let source env use))
+ ((let*-expr? source env) (pt-let* source env use))
+ ((letrec-expr? source env) (pt-letrec source env use))
+ ((begin-expr? source) (pt-begin source env use))
+ ((do-expr? source env) (pt-do source env use))
+ ((define-expr? source env)
+ (pt-syntax-error source "Ill-placed 'define'"))
+ ((delay-expr? source env) (pt-delay source env use))
+ ((future-expr? source env) (pt-future source env use))
+ ((define-macro-expr? source env)
+ (pt-syntax-error source "Ill-placed '##define-macro'"))
+ ((begin-defs-expr? source)
+ (pt-syntax-error source "Ill-placed 'begin' style definitions"))
+ ((declare-expr? source)
+ (pt-syntax-error source "Ill-placed '##declare'"))
+ ((c-declaration-expr? source)
+ (pt-syntax-error source "Ill-placed '##c-declaration'"))
+ ((c-init-expr? source)
+ (pt-syntax-error source "Ill-placed '##c-init'"))
+ ((c-procedure-expr? source) (pt-c-procedure source env use))
+ ((combination-expr? source) (pt-combination source env use))
+ (else (compiler-internal-error "pt, unknown expression type" source))))
+(define (macro-expand source env)
+ (let ((code (source-code source)))
+ (expression->source
+ (apply (cdr (env-lookup-macro env (source-code (car code))))
+ (cdr (source->expression source)))
+ source)))
+(define (pt-self-eval source env use)
+ (let ((val (source->expression source)))
+ (if (eq? use 'none)
+ (new-cst source (env-declarations env) undef-object)
+ (new-cst source (env-declarations env) val))))
+(define (pt-quote source env use)
+ (let ((code (source-code source)))
+ (if (eq? use 'none)
+ (new-cst source (env-declarations env) undef-object)
+ (new-cst source
+ (env-declarations env)
+ (source->expression (cadr code))))))
+(define (pt-quasiquote source env use)
+ (let ((code (source-code source))) (pt-quasiquotation (cadr code) 1 env)))
+(define (pt-quasiquotation form level env)
+ (cond ((= level 0) (pt form env 'true))
+ ((quasiquote-expr? form)
+ (pt-quasiquotation-list form (source-code form) (+ level 1) env))
+ ((unquote-expr? form)
+ (if (= level 1)
+ (pt (cadr (source-code form)) env 'true)
+ (pt-quasiquotation-list form (source-code form) (- level 1) env)))
+ ((unquote-splicing-expr? form)
+ (if (= level 1)
+ (pt-syntax-error form "Ill-placed 'unquote-splicing'")
+ (pt-quasiquotation-list form (source-code form) (- level 1) env)))
+ ((pair? (source-code form))
+ (pt-quasiquotation-list form (source-code form) level env))
+ ((vector? (source-code form))
+ (vector-form
+ form
+ (pt-quasiquotation-list
+ form
+ (vector->lst (source-code form))
+ level
+ env)
+ env))
+ (else
+ (new-cst form (env-declarations env) (source->expression form)))))
+(define (pt-quasiquotation-list form l level env)
+ (cond ((pair? l)
+ (if (and (unquote-splicing-expr? (car l)) (= level 1))
+ (let ((x (pt (cadr (source-code (car l))) env 'true)))
+ (if (null? (cdr l))
+ x
+ (append-form
+ (car l)
+ x
+ (pt-quasiquotation-list form (cdr l) 1 env)
+ env)))
+ (cons-form
+ form
+ (pt-quasiquotation (car l) level env)
+ (pt-quasiquotation-list form (cdr l) level env)
+ env)))
+ ((null? l) (new-cst form (env-declarations env) '()))
+ (else (pt-quasiquotation l level env))))
+(define (append-form source ptree1 ptree2 env)
+ (cond ((and (cst? ptree1) (cst? ptree2))
+ (new-cst source
+ (env-declarations env)
+ (append (cst-val ptree1) (cst-val ptree2))))
+ ((and (cst? ptree2) (null? (cst-val ptree2))) ptree1)
+ (else
+ (new-call*
+ source
+ (add-not-safe (env-declarations env))
+ (new-ref-extended-bindings source **quasi-append-sym env)
+ (list ptree1 ptree2)))))
+(define (cons-form source ptree1 ptree2 env)
+ (cond ((and (cst? ptree1) (cst? ptree2))
+ (new-cst source
+ (env-declarations env)
+ (cons (cst-val ptree1) (cst-val ptree2))))
+ ((and (cst? ptree2) (null? (cst-val ptree2)))
+ (new-call*
+ source
+ (add-not-safe (env-declarations env))
+ (new-ref-extended-bindings source **quasi-list-sym env)
+ (list ptree1)))
+ (else
+ (new-call*
+ source
+ (add-not-safe (env-declarations env))
+ (new-ref-extended-bindings source **quasi-cons-sym env)
+ (list ptree1 ptree2)))))
+(define (vector-form source ptree env)
+ (if (cst? ptree)
+ (new-cst source (env-declarations env) (lst->vector (cst-val ptree)))
+ (new-call*
+ source
+ (add-not-safe (env-declarations env))
+ (new-ref-extended-bindings source **quasi-list->vector-sym env)
+ (list ptree))))
+(define (pt-var source env use)
+ (if (eq? use 'none)
+ (new-cst source (env-declarations env) undef-object)
+ (new-ref source
+ (env-declarations env)
+ (env-lookup-var env (source-code source) source))))
+(define (pt-set! source env use)
+ (let ((code (source-code source)))
+ (new-set source
+ (env-declarations env)
+ (env-lookup-var env (source-code (cadr code)) (cadr code))
+ (pt (caddr code) env 'true))))
+(define (pt-lambda source env use)
+ (let ((code (source-code source)))
+ (define (new-params parms)
+ (cond ((pair? parms)
+ (let* ((parm* (car parms))
+ (parm (source-code parm*))
+ (p* (if (pair? parm) (car parm) parm*)))
+ (cons (make-var (source-code p*) #t (set-empty) (set-empty) p*)
+ (new-params (cdr parms)))))
+ ((null? parms) '())
+ (else
+ (list (make-var
+ (source-code parms)
+ #t
+ (set-empty)
+ (set-empty)
+ parms)))))
+ (define (min-params parms)
+ (let loop ((l parms) (n 0))
+ (if (pair? l)
+ (if (pair? (source-code (car l))) n (loop (cdr l) (+ n 1)))
+ n)))
+ (define (rest-param? parms)
+ (if (pair? parms) (rest-param? (cdr parms)) (not (null? parms))))
+ (define (optionals parms source body env)
+ (if (pair? parms)
+ (let* ((parm* (car parms)) (parm (source-code parm*)))
+ (if (and (pair? parm) (length? parm 2))
+ (let* ((var (car parm))
+ (vars (new-variables (list var)))
+ (decl (env-declarations env)))
+ (new-call*
+ parm*
+ decl
+ (new-prc parm*
+ decl
+ #f
+ 1
+ #f
+ vars
+ (optionals
+ (cdr parms)
+ source
+ body
+ (env-frame env vars)))
+ (list (new-tst parm*
+ decl
+ (new-call*
+ parm*
+ decl
+ (new-ref-extended-bindings
+ parm*
+ **unassigned?-sym
+ env)
+ (list (new-ref parm*
+ decl
+ (env-lookup-var
+ env
+ (source-code var)
+ var))))
+ (pt (cadr parm) env 'true)
+ (new-ref parm*
+ decl
+ (env-lookup-var
+ env
+ (source-code var)
+ var))))))
+ (optionals (cdr parms) source body env)))
+ (pt-body source body env 'true)))
+ (if (eq? use 'none)
+ (new-cst source (env-declarations env) undef-object)
+ (let* ((parms (source->parms (cadr code))) (frame (new-params parms)))
+ (new-prc source
+ (env-declarations env)
+ #f
+ (min-params parms)
+ (rest-param? parms)
+ frame
+ (optionals
+ parms
+ source
+ (cddr code)
+ (env-frame env frame)))))))
+(define (source->parms source)
+ (let ((x (source-code source))) (if (or (pair? x) (null? x)) x source)))
+(define (pt-body source body env use)
+ (define (letrec-defines vars vals envs body env)
+ (cond ((null? body)
+ (pt-syntax-error
+ source
+ "Body must contain at least one evaluable expression"))
+ ((macro-expr? (car body) env)
+ (letrec-defines
+ vars
+ vals
+ envs
+ (cons (macro-expand (car body) env) (cdr body))
+ env))
+ ((begin-defs-expr? (car body))
+ (letrec-defines
+ vars
+ vals
+ envs
+ (append (begin-defs-body (car body)) (cdr body))
+ env))
+ ((include-expr? (car body))
+ (if *ptree-port* (display " " *ptree-port*))
+ (let ((x (file->sources*
+ (include-filename (car body))
+ *ptree-port*
+ (source-locat (car body)))))
+ (if *ptree-port* (newline *ptree-port*))
+ (letrec-defines vars vals envs (append x (cdr body)) env)))
+ ((define-expr? (car body) env)
+ (let* ((var** (definition-variable (car body)))
+ (var* (source-code var**))
+ (var (env-define-var env var* var**)))
+ (letrec-defines
+ (cons var vars)
+ (cons (definition-value (car body)) vals)
+ (cons env envs)
+ (cdr body)
+ env)))
+ ((declare-expr? (car body))
+ (letrec-defines
+ vars
+ vals
+ envs
+ (cdr body)
+ (add-declarations (car body) env)))
+ ((define-macro-expr? (car body) env)
+ (letrec-defines
+ vars
+ vals
+ envs
+ (cdr body)
+ (add-macro (car body) env)))
+ ((c-declaration-expr? (car body))
+ (add-c-declaration (source-code (cadr (source-code (car body)))))
+ (letrec-defines vars vals envs (cdr body) env))
+ ((c-init-expr? (car body))
+ (add-c-init (source-code (cadr (source-code (car body)))))
+ (letrec-defines vars vals envs (cdr body) env))
+ ((null? vars) (pt-sequence source body env use))
+ (else
+ (let ((vars* (reverse vars)))
+ (let loop ((vals* '()) (l1 vals) (l2 envs))
+ (if (not (null? l1))
+ (loop (cons (pt (car l1) (car l2) 'true) vals*)
+ (cdr l1)
+ (cdr l2))
+ (pt-recursive-let source vars* vals* body env use)))))))
+ (letrec-defines '() '() '() body (env-frame env '())))
+(define (pt-sequence source seq env use)
+ (if (length? seq 1)
+ (pt (car seq) env use)
+ (new-seq source
+ (env-declarations env)
+ (pt (car seq) env 'none)
+ (pt-sequence source (cdr seq) env use))))
+(define (pt-if source env use)
+ (let ((code (source-code source)))
+ (new-tst source
+ (env-declarations env)
+ (pt (cadr code) env 'pred)
+ (pt (caddr code) env use)
+ (if (length? code 3)
+ (new-cst source (env-declarations env) undef-object)
+ (pt (cadddr code) env use)))))
+(define (pt-cond source env use)
+ (define (pt-clauses clauses)
+ (if (length? clauses 0)
+ (new-cst source (env-declarations env) undef-object)
+ (let* ((clause* (car clauses)) (clause (source-code clause*)))
+ (cond ((eq? (source-code (car clause)) else-sym)
+ (pt-sequence clause* (cdr clause) env use))
+ ((length? clause 1)
+ (new-disj
+ clause*
+ (env-declarations env)
+ (pt (car clause) env (if (eq? use 'true) 'true 'pred))
+ (pt-clauses (cdr clauses))))
+ ((eq? (source-code (cadr clause)) =>-sym)
+ (new-disj-call
+ clause*
+ (env-declarations env)
+ (pt (car clause) env 'true)
+ (pt (caddr clause) env 'true)
+ (pt-clauses (cdr clauses))))
+ (else
+ (new-tst clause*
+ (env-declarations env)
+ (pt (car clause) env 'pred)
+ (pt-sequence clause* (cdr clause) env use)
+ (pt-clauses (cdr clauses))))))))
+ (pt-clauses (cdr (source-code source))))
+(define (pt-and source env use)
+ (define (pt-exprs exprs)
+ (cond ((length? exprs 0) (new-cst source (env-declarations env) #t))
+ ((length? exprs 1) (pt (car exprs) env use))
+ (else
+ (new-conj
+ (car exprs)
+ (env-declarations env)
+ (pt (car exprs) env (if (eq? use 'true) 'true 'pred))
+ (pt-exprs (cdr exprs))))))
+ (pt-exprs (cdr (source-code source))))
+(define (pt-or source env use)
+ (define (pt-exprs exprs)
+ (cond ((length? exprs 0)
+ (new-cst source (env-declarations env) false-object))
+ ((length? exprs 1) (pt (car exprs) env use))
+ (else
+ (new-disj
+ (car exprs)
+ (env-declarations env)
+ (pt (car exprs) env (if (eq? use 'true) 'true 'pred))
+ (pt-exprs (cdr exprs))))))
+ (pt-exprs (cdr (source-code source))))
+(define (pt-case source env use)
+ (let ((code (source-code source)) (temp (new-temps source '(temp))))
+ (define (pt-clauses clauses)
+ (if (length? clauses 0)
+ (new-cst source (env-declarations env) undef-object)
+ (let* ((clause* (car clauses)) (clause (source-code clause*)))
+ (if (eq? (source-code (car clause)) else-sym)
+ (pt-sequence clause* (cdr clause) env use)
+ (new-tst clause*
+ (env-declarations env)
+ (new-call*
+ clause*
+ (add-not-safe (env-declarations env))
+ (new-ref-extended-bindings
+ clause*
+ **case-memv-sym
+ env)
+ (list (new-ref clause*
+ (env-declarations env)
+ (car temp))
+ (new-cst (car clause)
+ (env-declarations env)
+ (source->expression (car clause)))))
+ (pt-sequence clause* (cdr clause) env use)
+ (pt-clauses (cdr clauses)))))))
+ (new-call*
+ source
+ (env-declarations env)
+ (new-prc source
+ (env-declarations env)
+ #f
+ 1
+ #f
+ temp
+ (pt-clauses (cddr code)))
+ (list (pt (cadr code) env 'true)))))
+(define (pt-let source env use)
+ (let ((code (source-code source)))
+ (if (bindable-var? (cadr code) env)
+ (let* ((self (new-variables (list (cadr code))))
+ (bindings (map source-code (source-code (caddr code))))
+ (vars (new-variables (map car bindings)))
+ (vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))
+ (env (env-frame (env-frame env vars) self))
+ (self-proc
+ (list (new-prc source
+ (env-declarations env)
+ #f
+ (length vars)
+ #f
+ vars
+ (pt-body source (cdddr code) env use)))))
+ (set-prc-names! self self-proc)
+ (set-prc-names! vars vals)
+ (new-call*
+ source
+ (env-declarations env)
+ (new-prc source
+ (env-declarations env)
+ #f
+ 1
+ #f
+ self
+ (new-call*
+ source
+ (env-declarations env)
+ (new-ref source (env-declarations env) (car self))
+ vals))
+ self-proc))
+ (if (null? (source-code (cadr code)))
+ (pt-body source (cddr code) env use)
+ (let* ((bindings (map source-code (source-code (cadr code))))
+ (vars (new-variables (map car bindings)))
+ (vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))
+ (env (env-frame env vars)))
+ (set-prc-names! vars vals)
+ (new-call*
+ source
+ (env-declarations env)
+ (new-prc source
+ (env-declarations env)
+ #f
+ (length vars)
+ #f
+ vars
+ (pt-body source (cddr code) env use))
+ vals))))))
+(define (pt-let* source env use)
+ (let ((code (source-code source)))
+ (define (pt-bindings bindings env use)
+ (if (null? bindings)
+ (pt-body source (cddr code) env use)
+ (let* ((binding* (car bindings))
+ (binding (source-code binding*))
+ (vars (new-variables (list (car binding))))
+ (vals (list (pt (cadr binding) env 'true)))
+ (env (env-frame env vars)))
+ (set-prc-names! vars vals)
+ (new-call*
+ binding*
+ (env-declarations env)
+ (new-prc binding*
+ (env-declarations env)
+ #f
+ 1
+ #f
+ vars
+ (pt-bindings (cdr bindings) env use))
+ vals))))
+ (pt-bindings (source-code (cadr code)) env use)))
+(define (pt-letrec source env use)
+ (let* ((code (source-code source))
+ (bindings (map source-code (source-code (cadr code))))
+ (vars* (new-variables (map car bindings)))
+ (env* (env-frame env vars*)))
+ (pt-recursive-let
+ source
+ vars*
+ (map (lambda (x) (pt (cadr x) env* 'true)) bindings)
+ (cddr code)
+ env*
+ use)))
+(define (pt-recursive-let source vars vals body env use)
+ (define (dependency-graph vars vals)
+ (define (dgraph vars* vals*)
+ (if (null? vars*)
+ (set-empty)
+ (let ((var (car vars*)) (val (car vals*)))
+ (set-adjoin
+ (dgraph (cdr vars*) (cdr vals*))
+ (make-gnode
+ var
+ (set-intersection (list->set vars) (free-variables val)))))))
+ (dgraph vars vals))
+ (define (val-of var)
+ (list-ref vals (- (length vars) (length (memq var vars)))))
+ (define (bind-in-order order)
+ (if (null? order)
+ (pt-body source body env use)
+ (let* ((vars-set (car order)) (vars (set->list vars-set)))
+ (let loop1 ((l (reverse vars))
+ (vars-b '())
+ (vals-b '())
+ (vars-a '()))
+ (if (not (null? l))
+ (let* ((var (car l)) (val (val-of var)))
+ (if (or (prc? val)
+ (set-empty?
+ (set-intersection (free-variables val) vars-set)))
+ (loop1 (cdr l)
+ (cons var vars-b)
+ (cons val vals-b)
+ vars-a)
+ (loop1 (cdr l) vars-b vals-b (cons var vars-a))))
+ (let* ((result1 (let loop2 ((l vars-a))
+ (if (not (null? l))
+ (let* ((var (car l)) (val (val-of var)))
+ (new-seq source
+ (env-declarations env)
+ (new-set source
+ (env-declarations
+ env)
+ var
+ val)
+ (loop2 (cdr l))))
+ (bind-in-order (cdr order)))))
+ (result2 (if (null? vars-b)
+ result1
+ (new-call*
+ source
+ (env-declarations env)
+ (new-prc source
+ (env-declarations env)
+ #f
+ (length vars-b)
+ #f
+ vars-b
+ result1)
+ vals-b)))
+ (result3 (if (null? vars-a)
+ result2
+ (new-call*
+ source
+ (env-declarations env)
+ (new-prc source
+ (env-declarations env)
+ #f
+ (length vars-a)
+ #f
+ vars-a
+ result2)
+ (map (lambda (var)
+ (new-cst source
+ (env-declarations env)
+ undef-object))
+ vars-a)))))
+ result3))))))
+ (set-prc-names! vars vals)
+ (bind-in-order
+ (topological-sort (transitive-closure (dependency-graph vars vals)))))
+(define (pt-begin source env use)
+ (pt-sequence source (cdr (source-code source)) env use))
+(define (pt-do source env use)
+ (let* ((code (source-code source))
+ (loop (new-temps source '(loop)))
+ (bindings (map source-code (source-code (cadr code))))
+ (vars (new-variables (map car bindings)))
+ (init (map (lambda (x) (pt (cadr x) env 'true)) bindings))
+ (env (env-frame env vars))
+ (step (map (lambda (x)
+ (pt (if (length? x 2) (car x) (caddr x)) env 'true))
+ bindings))
+ (exit (source-code (caddr code))))
+ (set-prc-names! vars init)
+ (new-call*
+ source
+ (env-declarations env)
+ (new-prc source
+ (env-declarations env)
+ #f
+ 1
+ #f
+ loop
+ (new-call*
+ source
+ (env-declarations env)
+ (new-ref source (env-declarations env) (car loop))
+ init))
+ (list (new-prc source
+ (env-declarations env)
+ #f
+ (length vars)
+ #f
+ vars
+ (new-tst source
+ (env-declarations env)
+ (pt (car exit) env 'pred)
+ (if (length? exit 1)
+ (new-cst (caddr code)
+ (env-declarations env)
+ undef-object)
+ (pt-sequence (caddr code) (cdr exit) env use))
+ (if (length? code 3)
+ (new-call*
+ source
+ (env-declarations env)
+ (new-ref source
+ (env-declarations env)
+ (car loop))
+ step)
+ (new-seq source
+ (env-declarations env)
+ (pt-sequence
+ source
+ (cdddr code)
+ env
+ 'none)
+ (new-call*
+ source
+ (env-declarations env)
+ (new-ref source
+ (env-declarations env)
+ (car loop))
+ step)))))))))
+(define (pt-combination source env use)
+ (let* ((code (source-code source))
+ (oper (pt (car code) env 'true))
+ (decl (node-decl oper)))
+ (new-call*
+ source
+ (env-declarations env)
+ oper
+ (map (lambda (x) (pt x env 'true)) (cdr code)))))
+(define (pt-delay source env use)
+ (let ((code (source-code source)))
+ (new-call*
+ source
+ (add-not-safe (env-declarations env))
+ (new-ref-extended-bindings source **make-placeholder-sym env)
+ (list (new-prc source
+ (env-declarations env)
+ #f
+ 0
+ #f
+ '()
+ (pt (cadr code) env 'true))))))
+(define (pt-future source env use)
+ (let ((decl (env-declarations env)) (code (source-code source)))
+ (new-fut source decl (pt (cadr code) env 'true))))
+(define (self-eval-expr? source)
+ (let ((code (source-code source)))
+ (and (not (pair? code)) (not (symbol-object? code)))))
+(define (quote-expr? source) (mymatch quote-sym 1 source))
+(define (quasiquote-expr? source) (mymatch quasiquote-sym 1 source))
+(define (unquote-expr? source) (mymatch unquote-sym 1 source))
+(define (unquote-splicing-expr? source)
+ (mymatch unquote-splicing-sym 1 source))
+(define (var-expr? source env)
+ (let ((code (source-code source)))
+ (and (symbol-object? code)
+ (not-keyword source env code)
+ (not-macro source env code))))
+(define (not-macro source env name)
+ (if (env-lookup-macro env name)
+ (pt-syntax-error source "Macro name can't be used as a variable:" name)
+ #t))
+(define (bindable-var? source env)
+ (let ((code (source-code source)))
+ (and (symbol-object? code) (not-keyword source env code))))
+(define (not-keyword source env name)
+ (if (or (memq name common-keywords)
+ (memq name
+ (dialect-specific-keywords
+ (scheme-dialect (env-declarations env)))))
+ (pt-syntax-error
+ source
+ "Predefined keyword can't be used as a variable:"
+ name)
+ #t))
+(define (set!-expr? source env)
+ (and (mymatch set!-sym 2 source)
+ (var-expr? (cadr (source-code source)) env)))
+(define (lambda-expr? source env)
+ (and (mymatch lambda-sym -2 source)
+ (proper-parms? (source->parms (cadr (source-code source))) env)))
+(define (if-expr? source)
+ (and (mymatch if-sym -2 source)
+ (or (<= (length (source-code source)) 4)
+ (pt-syntax-error source "Ill-formed special form" if-sym))))
+(define (cond-expr? source)
+ (and (mymatch cond-sym -1 source) (proper-clauses? source)))
+(define (and-expr? source) (mymatch and-sym 0 source))
+(define (or-expr? source) (mymatch or-sym 0 source))
+(define (case-expr? source)
+ (and (mymatch case-sym -2 source) (proper-case-clauses? source)))
+(define (let-expr? source env)
+ (and (mymatch let-sym -2 source)
+ (let ((code (source-code source)))
+ (if (bindable-var? (cadr code) env)
+ (and (proper-bindings? (caddr code) #t env)
+ (or (> (length code) 3)
+ (pt-syntax-error source "Ill-formed named 'let'")))
+ (proper-bindings? (cadr code) #t env)))))
+(define (let*-expr? source env)
+ (and (mymatch let*-sym -2 source)
+ (proper-bindings? (cadr (source-code source)) #f env)))
+(define (letrec-expr? source env)
+ (and (mymatch letrec-sym -2 source)
+ (proper-bindings? (cadr (source-code source)) #t env)))
+(define (begin-expr? source) (mymatch begin-sym -1 source))
+(define (do-expr? source env)
+ (and (mymatch do-sym -2 source)
+ (proper-do-bindings? source env)
+ (proper-do-exit? source)))
+(define (define-expr? source env)
+ (and (mymatch define-sym -1 source)
+ (proper-definition? source env)
+ (let ((v (definition-variable source)))
+ (not-macro v env (source-code v)))))
+(define (combination-expr? source)
+ (let ((length (proper-length (source-code source))))
+ (if length
+ (or (> length 0) (pt-syntax-error source "Ill-formed procedure call"))
+ (pt-syntax-error source "Ill-terminated procedure call"))))
+(define (delay-expr? source env)
+ (and (not (eq? (scheme-dialect (env-declarations env)) ieee-scheme-sym))
+ (mymatch delay-sym 1 source)))
+(define (future-expr? source env)
+ (and (eq? (scheme-dialect (env-declarations env)) multilisp-sym)
+ (mymatch future-sym 1 source)))
+(define (macro-expr? source env)
+ (let ((code (source-code source)))
+ (and (pair? code)
+ (symbol-object? (source-code (car code)))
+ (let ((macr (env-lookup-macro env (source-code (car code)))))
+ (and macr
+ (let ((len (proper-length (cdr code))))
+ (if len
+ (let ((len* (+ len 1)) (size (car macr)))
+ (or (if (> size 0) (= len* size) (>= len* (- size)))
+ (pt-syntax-error source "Ill-formed macro form")))
+ (pt-syntax-error
+ source
+ "Ill-terminated macro form"))))))))
+(define (define-macro-expr? source env)
+ (and (mymatch **define-macro-sym -1 source) (proper-definition? source env)))
+(define (declare-expr? source) (mymatch **declare-sym -1 source))
+(define (include-expr? source) (mymatch **include-sym 1 source))
+(define (begin-defs-expr? source) (mymatch begin-sym 0 source))
+(define (mymatch keyword size source)
+ (let ((code (source-code source)))
+ (and (pair? code)
+ (eq? (source-code (car code)) keyword)
+ (let ((length (proper-length (cdr code))))
+ (if length
+ (or (if (> size 0) (= length size) (>= length (- size)))
+ (pt-syntax-error source "Ill-formed special form" keyword))
+ (pt-syntax-error
+ source
+ "Ill-terminated special form"
+ keyword))))))
+(define (proper-length l)
+ (define (length l n)
+ (cond ((pair? l) (length (cdr l) (+ n 1))) ((null? l) n) (else #f)))
+ (length l 0))
+(define (proper-definition? source env)
+ (let* ((code (source-code source))
+ (pattern* (cadr code))
+ (pattern (source-code pattern*))
+ (body (cddr code)))
+ (cond ((bindable-var? pattern* env)
+ (cond ((length? body 0) #t)
+ ((length? body 1) #t)
+ (else (pt-syntax-error source "Ill-formed definition body"))))
+ ((pair? pattern)
+ (if (length? body 0)
+ (pt-syntax-error
+ source
+ "Body of a definition must have at least one expression"))
+ (if (bindable-var? (car pattern) env)
+ (proper-parms? (cdr pattern) env)
+ (pt-syntax-error
+ (car pattern)
+ "Procedure name must be an identifier")))
+ (else (pt-syntax-error pattern* "Ill-formed definition pattern")))))
+(define (definition-variable def)
+ (let* ((code (source-code def)) (pattern (cadr code)))
+ (if (pair? (source-code pattern)) (car (source-code pattern)) pattern)))
+(define (definition-value def)
+ (let ((code (source-code def)) (loc (source-locat def)))
+ (cond ((pair? (source-code (cadr code)))
+ (make-source
+ (cons (make-source lambda-sym loc)
+ (cons (parms->source (cdr (source-code (cadr code))) loc)
+ (cddr code)))
+ loc))
+ ((null? (cddr code))
+ (make-source
+ (list (make-source quote-sym loc) (make-source undef-object loc))
+ loc))
+ (else (caddr code)))))
+(define (parms->source parms loc)
+ (if (or (pair? parms) (null? parms)) (make-source parms loc) parms))
+(define (proper-parms? parms env)
+ (define (proper-parms parms seen optional-seen)
+ (cond ((pair? parms)
+ (let* ((parm* (car parms)) (parm (source-code parm*)))
+ (cond ((pair? parm)
+ (if (eq? (scheme-dialect (env-declarations env))
+ multilisp-sym)
+ (let ((length (proper-length parm)))
+ (if (or (eqv? length 1) (eqv? length 2))
+ (let ((var (car parm)))
+ (if (bindable-var? var env)
+ (if (memq (source-code var) seen)
+ (pt-syntax-error
+ var
+ "Duplicate parameter in parameter list")
+ (proper-parms
+ (cdr parms)
+ (cons (source-code var) seen)
+ #t))
+ (pt-syntax-error
+ var
+ "Parameter must be an identifier")))
+ (pt-syntax-error
+ parm*
+ "Ill-formed optional parameter")))
+ (pt-syntax-error
+ parm*
+ "optional parameters illegal in this dialect")))
+ (optional-seen
+ (pt-syntax-error parm* "Optional parameter expected"))
+ ((bindable-var? parm* env)
+ (if (memq parm seen)
+ (pt-syntax-error
+ parm*
+ "Duplicate parameter in parameter list"))
+ (proper-parms (cdr parms) (cons parm seen) #f))
+ (else
+ (pt-syntax-error
+ parm*
+ "Parameter must be an identifier")))))
+ ((null? parms) #t)
+ ((bindable-var? parms env)
+ (if (memq (source-code parms) seen)
+ (pt-syntax-error parms "Duplicate parameter in parameter list")
+ #t))
+ (else
+ (pt-syntax-error parms "Rest parameter must be an identifier"))))
+ (proper-parms parms '() #f))
+(define (proper-clauses? source)
+ (define (proper-clauses clauses)
+ (or (null? clauses)
+ (let* ((clause* (car clauses))
+ (clause (source-code clause*))
+ (length (proper-length clause)))
+ (if length
+ (if (>= length 1)
+ (if (eq? (source-code (car clause)) else-sym)
+ (cond ((= length 1)
+ (pt-syntax-error
+ clause*
+ "Else clause must have a body"))
+ ((not (null? (cdr clauses)))
+ (pt-syntax-error
+ clause*
+ "Else clause must be the last clause"))
+ (else (proper-clauses (cdr clauses))))
+ (if (and (>= length 2)
+ (eq? (source-code (cadr clause)) =>-sym)
+ (not (= length 3)))
+ (pt-syntax-error
+ (cadr clause)
+ "'=>' must be followed by a single expression")
+ (proper-clauses (cdr clauses))))
+ (pt-syntax-error clause* "Ill-formed 'cond' clause"))
+ (pt-syntax-error clause* "Ill-terminated 'cond' clause")))))
+ (proper-clauses (cdr (source-code source))))
+(define (proper-case-clauses? source)
+ (define (proper-case-clauses clauses)
+ (or (null? clauses)
+ (let* ((clause* (car clauses))
+ (clause (source-code clause*))
+ (length (proper-length clause)))
+ (if length
+ (if (>= length 2)
+ (if (eq? (source-code (car clause)) else-sym)
+ (if (not (null? (cdr clauses)))
+ (pt-syntax-error
+ clause*
+ "Else clause must be the last clause")
+ (proper-case-clauses (cdr clauses)))
+ (begin
+ (proper-selector-list? (car clause))
+ (proper-case-clauses (cdr clauses))))
+ (pt-syntax-error
+ clause*
+ "A 'case' clause must have a selector list and a body"))
+ (pt-syntax-error clause* "Ill-terminated 'case' clause")))))
+ (proper-case-clauses (cddr (source-code source))))
+(define (proper-selector-list? source)
+ (let* ((code (source-code source)) (length (proper-length code)))
+ (if length
+ (or (>= length 1)
+ (pt-syntax-error
+ source
+ "Selector list must contain at least one element"))
+ (pt-syntax-error source "Ill-terminated selector list"))))
+(define (proper-bindings? bindings check-dupl? env)
+ (define (proper-bindings l seen)
+ (cond ((pair? l)
+ (let* ((binding* (car l)) (binding (source-code binding*)))
+ (if (eqv? (proper-length binding) 2)
+ (let ((var (car binding)))
+ (if (bindable-var? var env)
+ (if (and check-dupl? (memq (source-code var) seen))
+ (pt-syntax-error
+ var
+ "Duplicate variable in bindings")
+ (proper-bindings
+ (cdr l)
+ (cons (source-code var) seen)))
+ (pt-syntax-error
+ var
+ "Binding variable must be an identifier")))
+ (pt-syntax-error binding* "Ill-formed binding"))))
+ ((null? l) #t)
+ (else (pt-syntax-error bindings "Ill-terminated binding list"))))
+ (proper-bindings (source-code bindings) '()))
+(define (proper-do-bindings? source env)
+ (let ((bindings (cadr (source-code source))))
+ (define (proper-bindings l seen)
+ (cond ((pair? l)
+ (let* ((binding* (car l))
+ (binding (source-code binding*))
+ (length (proper-length binding)))
+ (if (or (eqv? length 2) (eqv? length 3))
+ (let ((var (car binding)))
+ (if (bindable-var? var env)
+ (if (memq (source-code var) seen)
+ (pt-syntax-error
+ var
+ "Duplicate variable in bindings")
+ (proper-bindings
+ (cdr l)
+ (cons (source-code var) seen)))
+ (pt-syntax-error
+ var
+ "Binding variable must be an identifier")))
+ (pt-syntax-error binding* "Ill-formed binding"))))
+ ((null? l) #t)
+ (else (pt-syntax-error bindings "Ill-terminated binding list"))))
+ (proper-bindings (source-code bindings) '())))
+(define (proper-do-exit? source)
+ (let* ((code (source-code (caddr (source-code source))))
+ (length (proper-length code)))
+ (if length
+ (or (> length 0) (pt-syntax-error source "Ill-formed exit clause"))
+ (pt-syntax-error source "Ill-terminated exit clause"))))
+(define (include-filename source) (source-code (cadr (source-code source))))
+(define (begin-defs-body source) (cdr (source-code source)))
+(define (length? l n)
+ (cond ((null? l) (= n 0)) ((> n 0) (length? (cdr l) (- n 1))) (else #f)))
+(define (transform-declaration source)
+ (let ((code (source-code source)))
+ (if (not (pair? code))
+ (pt-syntax-error source "Ill-formed declaration")
+ (let* ((pos (not (eq? (source-code (car code)) not-sym)))
+ (x (if pos code (cdr code))))
+ (if (not (pair? x))
+ (pt-syntax-error source "Ill-formed declaration")
+ (let* ((id* (car x)) (id (source-code id*)))
+ (cond ((not (symbol-object? id))
+ (pt-syntax-error
+ id*
+ "Declaration name must be an identifier"))
+ ((assq id flag-declarations)
+ (cond ((not pos)
+ (pt-syntax-error
+ id*
+ "Declaration can't be negated"))
+ ((null? (cdr x))
+ (flag-decl
+ source
+ (cdr (assq id flag-declarations))
+ id))
+ (else
+ (pt-syntax-error
+ source
+ "Ill-formed declaration"))))
+ ((memq id parameterized-declarations)
+ (cond ((not pos)
+ (pt-syntax-error
+ id*
+ "Declaration can't be negated"))
+ ((eqv? (proper-length x) 2)
+ (parameterized-decl
+ source
+ id
+ (source->expression (cadr x))))
+ (else
+ (pt-syntax-error
+ source
+ "Ill-formed declaration"))))
+ ((memq id boolean-declarations)
+ (if (null? (cdr x))
+ (boolean-decl source id pos)
+ (pt-syntax-error source "Ill-formed declaration")))
+ ((assq id namable-declarations)
+ (cond ((not pos)
+ (pt-syntax-error
+ id*
+ "Declaration can't be negated"))
+ (else
+ (namable-decl
+ source
+ (cdr (assq id namable-declarations))
+ id
+ (map source->expression (cdr x))))))
+ ((memq id namable-boolean-declarations)
+ (namable-boolean-decl
+ source
+ id
+ pos
+ (map source->expression (cdr x))))
+ ((memq id namable-string-declarations)
+ (if (not (pair? (cdr x)))
+ (pt-syntax-error source "Ill-formed declaration")
+ (let* ((str* (cadr x)) (str (source-code str*)))
+ (cond ((not pos)
+ (pt-syntax-error
+ id*
+ "Declaration can't be negated"))
+ ((not (string? str))
+ (pt-syntax-error str* "String expected"))
+ (else
+ (namable-string-decl
+ source
+ id
+ str
+ (map source->expression (cddr x))))))))
+ (else (pt-syntax-error id* "Unknown declaration")))))))))
+(define (add-declarations source env)
+ (let loop ((l (cdr (source-code source))) (env env))
+ (if (pair? l)
+ (loop (cdr l) (env-declare env (transform-declaration (car l))))
+ env)))
+(define (add-decl d decl) (env-declare decl d))
+(define (add-macro source env)
+ (define (form-size parms)
+ (let loop ((l parms) (n 1))
+ (if (pair? l) (loop (cdr l) (+ n 1)) (if (null? l) n (- n)))))
+ (define (error-proc . msgs)
+ (apply compiler-user-error
+ (cons (source-locat source) (cons "(in macro body)" msgs))))
+ (let ((var (definition-variable source)) (proc (definition-value source)))
+ (if (lambda-expr? proc env)
+ (env-macro
+ env
+ (source-code var)
+ (cons (form-size (source->parms (cadr (source-code proc))))
+ (scheme-global-eval (source->expression proc) error-proc)))
+ (pt-syntax-error source "Macro value must be a lambda expression"))))
+(define (ptree.begin! info-port) (set! *ptree-port* info-port) '())
+(define (ptree.end!) '())
+(define *ptree-port* '())
+(define (normalize-parse-tree ptree env)
+ (define (normalize ptree)
+ (let ((tree (assignment-convert (partial-evaluate ptree) env)))
+ (lambda-lift! tree)
+ tree))
+ (if (def? ptree)
+ (begin
+ (node-children-set! ptree (list (normalize (def-val ptree))))
+ ptree)
+ (normalize ptree)))
+(define (partial-evaluate ptree) (pe ptree '()))
+(define (pe ptree consts)
+ (cond ((cst? ptree)
+ (new-cst (node-source ptree) (node-decl ptree) (cst-val ptree)))
+ ((ref? ptree)
+ (let ((var (ref-var ptree)))
+ (var-refs-set! var (set-remove (var-refs var) ptree))
+ (let ((x (assq var consts)))
+ (if x
+ (new-cst (node-source ptree) (node-decl ptree) (cdr x))
+ (let ((y (global-val var)))
+ (if (and y (cst? y))
+ (new-cst (node-source ptree)
+ (node-decl ptree)
+ (cst-val y))
+ (new-ref (node-source ptree)
+ (node-decl ptree)
+ var)))))))
+ ((set? ptree)
+ (let ((var (set-var ptree)) (val (pe (set-val ptree) consts)))
+ (var-sets-set! var (set-remove (var-sets var) ptree))
+ (new-set (node-source ptree) (node-decl ptree) var val)))
+ ((tst? ptree)
+ (let ((pre (pe (tst-pre ptree) consts)))
+ (if (cst? pre)
+ (let ((val (cst-val pre)))
+ (if (false-object? val)
+ (pe (tst-alt ptree) consts)
+ (pe (tst-con ptree) consts)))
+ (new-tst (node-source ptree)
+ (node-decl ptree)
+ pre
+ (pe (tst-con ptree) consts)
+ (pe (tst-alt ptree) consts)))))
+ ((conj? ptree)
+ (let ((pre (pe (conj-pre ptree) consts)))
+ (if (cst? pre)
+ (let ((val (cst-val pre)))
+ (if (false-object? val) pre (pe (conj-alt ptree) consts)))
+ (new-conj
+ (node-source ptree)
+ (node-decl ptree)
+ pre
+ (pe (conj-alt ptree) consts)))))
+ ((disj? ptree)
+ (let ((pre (pe (disj-pre ptree) consts)))
+ (if (cst? pre)
+ (let ((val (cst-val pre)))
+ (if (false-object? val) (pe (disj-alt ptree) consts) pre))
+ (new-disj
+ (node-source ptree)
+ (node-decl ptree)
+ pre
+ (pe (disj-alt ptree) consts)))))
+ ((prc? ptree)
+ (new-prc (node-source ptree)
+ (node-decl ptree)
+ (prc-name ptree)
+ (prc-min ptree)
+ (prc-rest ptree)
+ (prc-parms ptree)
+ (pe (prc-body ptree) consts)))
+ ((app? ptree)
+ (let ((oper (app-oper ptree)) (args (app-args ptree)))
+ (if (and (prc? oper)
+ (not (prc-rest oper))
+ (= (length (prc-parms oper)) (length args)))
+ (pe-let ptree consts)
+ (new-call
+ (node-source ptree)
+ (node-decl ptree)
+ (pe oper consts)
+ (map (lambda (x) (pe x consts)) args)))))
+ ((fut? ptree)
+ (new-fut (node-source ptree)
+ (node-decl ptree)
+ (pe (fut-val ptree) consts)))
+ (else (compiler-internal-error "pe, unknown parse tree node type"))))
+(define (pe-let ptree consts)
+ (let* ((proc (app-oper ptree))
+ (vals (app-args ptree))
+ (vars (prc-parms proc))
+ (non-mut-vars (set-keep not-mutable? (list->set vars))))
+ (for-each
+ (lambda (var)
+ (var-refs-set! var (set-empty))
+ (var-sets-set! var (set-empty)))
+ vars)
+ (let loop ((l vars)
+ (v vals)
+ (new-vars '())
+ (new-vals '())
+ (new-consts consts))
+ (if (null? l)
+ (if (null? new-vars)
+ (pe (prc-body proc) new-consts)
+ (new-call
+ (node-source ptree)
+ (node-decl ptree)
+ (new-prc (node-source proc)
+ (node-decl proc)
+ #f
+ (length new-vars)
+ #f
+ (reverse new-vars)
+ (pe (prc-body proc) new-consts))
+ (reverse new-vals)))
+ (let ((var (car l)) (val (pe (car v) consts)))
+ (if (and (set-member? var non-mut-vars) (cst? val))
+ (loop (cdr l)
+ (cdr v)
+ new-vars
+ new-vals
+ (cons (cons var (cst-val val)) new-consts))
+ (loop (cdr l)
+ (cdr v)
+ (cons var new-vars)
+ (cons val new-vals)
+ new-consts)))))))
+(define (assignment-convert ptree env)
+ (ac ptree (env-declare env (list safe-sym #f)) '()))
+(define (ac ptree env mut)
+ (cond ((cst? ptree) ptree)
+ ((ref? ptree)
+ (let ((var (ref-var ptree)))
+ (if (global? var)
+ ptree
+ (let ((x (assq var mut)))
+ (if x
+ (let ((source (node-source ptree)))
+ (var-refs-set! var (set-remove (var-refs var) ptree))
+ (new-call
+ source
+ (node-decl ptree)
+ (new-ref-extended-bindings source **cell-ref-sym env)
+ (list (new-ref source (node-decl ptree) (cdr x)))))
+ ptree)))))
+ ((set? ptree)
+ (let ((var (set-var ptree))
+ (source (node-source ptree))
+ (val (ac (set-val ptree) env mut)))
+ (var-sets-set! var (set-remove (var-sets var) ptree))
+ (if (global? var)
+ (new-set source (node-decl ptree) var val)
+ (new-call
+ source
+ (node-decl ptree)
+ (new-ref-extended-bindings source **cell-set!-sym env)
+ (list (new-ref source (node-decl ptree) (cdr (assq var mut)))
+ val)))))
+ ((tst? ptree)
+ (new-tst (node-source ptree)
+ (node-decl ptree)
+ (ac (tst-pre ptree) env mut)
+ (ac (tst-con ptree) env mut)
+ (ac (tst-alt ptree) env mut)))
+ ((conj? ptree)
+ (new-conj
+ (node-source ptree)
+ (node-decl ptree)
+ (ac (conj-pre ptree) env mut)
+ (ac (conj-alt ptree) env mut)))
+ ((disj? ptree)
+ (new-disj
+ (node-source ptree)
+ (node-decl ptree)
+ (ac (disj-pre ptree) env mut)
+ (ac (disj-alt ptree) env mut)))
+ ((prc? ptree) (ac-proc ptree env mut))
+ ((app? ptree)
+ (let ((oper (app-oper ptree)) (args (app-args ptree)))
+ (if (and (prc? oper)
+ (not (prc-rest oper))
+ (= (length (prc-parms oper)) (length args)))
+ (ac-let ptree env mut)
+ (new-call
+ (node-source ptree)
+ (node-decl ptree)
+ (ac oper env mut)
+ (map (lambda (x) (ac x env mut)) args)))))
+ ((fut? ptree)
+ (new-fut (node-source ptree)
+ (node-decl ptree)
+ (ac (fut-val ptree) env mut)))
+ (else (compiler-internal-error "ac, unknown parse tree node type"))))
+(define (ac-proc ptree env mut)
+ (let* ((mut-parms (ac-mutables (prc-parms ptree)))
+ (mut-parms-copies (map var-copy mut-parms))
+ (mut (append (pair-up mut-parms mut-parms-copies) mut))
+ (new-body (ac (prc-body ptree) env mut)))
+ (new-prc (node-source ptree)
+ (node-decl ptree)
+ (prc-name ptree)
+ (prc-min ptree)
+ (prc-rest ptree)
+ (prc-parms ptree)
+ (if (null? mut-parms)
+ new-body
+ (new-call
+ (node-source ptree)
+ (node-decl ptree)
+ (new-prc (node-source ptree)
+ (node-decl ptree)
+ #f
+ (length mut-parms-copies)
+ #f
+ mut-parms-copies
+ new-body)
+ (map (lambda (var)
+ (new-call
+ (var-source var)
+ (node-decl ptree)
+ (new-ref-extended-bindings
+ (var-source var)
+ **make-cell-sym
+ env)
+ (list (new-ref (var-source var)
+ (node-decl ptree)
+ var))))
+ mut-parms))))))
+(define (ac-let ptree env mut)
+ (let* ((proc (app-oper ptree))
+ (vals (app-args ptree))
+ (vars (prc-parms proc))
+ (vals-fv (apply set-union (map free-variables vals)))
+ (mut-parms (ac-mutables vars))
+ (mut-parms-copies (map var-copy mut-parms))
+ (mut (append (pair-up mut-parms mut-parms-copies) mut)))
+ (let loop ((l vars)
+ (v vals)
+ (new-vars '())
+ (new-vals '())
+ (new-body (ac (prc-body proc) env mut)))
+ (if (null? l)
+ (new-let ptree proc new-vars new-vals new-body)
+ (let ((var (car l)) (val (car v)))
+ (if (memq var mut-parms)
+ (let ((src (node-source val))
+ (decl (node-decl val))
+ (var* (cdr (assq var mut))))
+ (if (set-member? var vals-fv)
+ (loop (cdr l)
+ (cdr v)
+ (cons var* new-vars)
+ (cons (new-call
+ src
+ decl
+ (new-ref-extended-bindings
+ src
+ **make-cell-sym
+ env)
+ (list (new-cst src decl undef-object)))
+ new-vals)
+ (new-seq src
+ decl
+ (new-call
+ src
+ decl
+ (new-ref-extended-bindings
+ src
+ **cell-set!-sym
+ env)
+ (list (new-ref src decl var*)
+ (ac val env mut)))
+ new-body))
+ (loop (cdr l)
+ (cdr v)
+ (cons var* new-vars)
+ (cons (new-call
+ src
+ decl
+ (new-ref-extended-bindings
+ src
+ **make-cell-sym
+ env)
+ (list (ac val env mut)))
+ new-vals)
+ new-body)))
+ (loop (cdr l)
+ (cdr v)
+ (cons var new-vars)
+ (cons (ac val env mut) new-vals)
+ new-body)))))))
+(define (ac-mutables l)
+ (if (pair? l)
+ (let ((var (car l)) (rest (ac-mutables (cdr l))))
+ (if (mutable? var) (cons var rest) rest))
+ '()))
+(define (lambda-lift! ptree) (ll! ptree (set-empty) '()))
+(define (ll! ptree cst-procs env)
+ (define (new-env env vars)
+ (define (loop i l)
+ (if (pair? l)
+ (let ((var (car l)))
+ (cons (cons var (cons (length (set->list (var-refs var))) i))
+ (loop (+ i 1) (cdr l))))
+ env))
+ (loop (length env) vars))
+ (cond ((or (cst? ptree)
+ (ref? ptree)
+ (set? ptree)
+ (tst? ptree)
+ (conj? ptree)
+ (disj? ptree)
+ (fut? ptree))
+ (for-each
+ (lambda (child) (ll! child cst-procs env))
+ (node-children ptree)))
+ ((prc? ptree)
+ (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))
+ ((app? ptree)
+ (let ((oper (app-oper ptree)) (args (app-args ptree)))
+ (if (and (prc? oper)
+ (not (prc-rest oper))
+ (= (length (prc-parms oper)) (length args)))
+ (ll!-let ptree cst-procs (new-env env (prc-parms oper)))
+ (for-each
+ (lambda (child) (ll! child cst-procs env))
+ (node-children ptree)))))
+ (else (compiler-internal-error "ll!, unknown parse tree node type"))))
+(define (ll!-let ptree cst-procs env)
+ (let* ((proc (app-oper ptree))
+ (vals (app-args ptree))
+ (vars (prc-parms proc))
+ (var-val-map (pair-up vars vals)))
+ (define (var->val var) (cdr (assq var var-val-map)))
+ (define (liftable-proc-vars vars)
+ (let loop ((cst-proc-vars
+ (set-keep
+ (lambda (var)
+ (let ((val (var->val var)))
+ (and (prc? val)
+ (lambda-lift? (node-decl val))
+ (set-every? oper-pos? (var-refs var)))))
+ (list->set vars))))
+ (let* ((non-cst-proc-vars
+ (set-keep
+ (lambda (var)
+ (let ((val (var->val var)))
+ (and (prc? val) (not (set-member? var cst-proc-vars)))))
+ (list->set vars)))
+ (cst-proc-vars*
+ (set-keep
+ (lambda (var)
+ (let ((val (var->val var)))
+ (set-empty?
+ (set-intersection
+ (free-variables val)
+ non-cst-proc-vars))))
+ cst-proc-vars)))
+ (if (set-equal? cst-proc-vars cst-proc-vars*)
+ cst-proc-vars
+ (loop cst-proc-vars*)))))
+ (define (transitively-closed-free-variables vars)
+ (let ((tcfv-map
+ (map (lambda (var) (cons var (free-variables (var->val var))))
+ vars)))
+ (let loop ((changed? #f))
+ (for-each
+ (lambda (var-tcfv)
+ (let loop2 ((l (set->list (cdr var-tcfv))) (fv (cdr var-tcfv)))
+ (if (null? l)
+ (if (not (set-equal? fv (cdr var-tcfv)))
+ (begin (set-cdr! var-tcfv fv) (set! changed? #t)))
+ (let ((x (assq (car l) tcfv-map)))
+ (loop2 (cdr l) (if x (set-union fv (cdr x)) fv))))))
+ tcfv-map)
+ (if changed? (loop #f) tcfv-map))))
+ (let* ((tcfv-map
+ (transitively-closed-free-variables (liftable-proc-vars vars)))
+ (cst-proc-vars-list (map car tcfv-map))
+ (cst-procs* (set-union (list->set cst-proc-vars-list) cst-procs)))
+ (define (var->tcfv var) (cdr (assq var tcfv-map)))
+ (define (order-vars vars)
+ (map car
+ (sort-list
+ (map (lambda (var) (assq var env)) vars)
+ (lambda (x y)
+ (if (= (cadr x) (cadr y))
+ (< (cddr x) (cddr y))
+ (< (cadr x) (cadr y)))))))
+ (define (lifted-vars var)
+ (order-vars (set->list (set-difference (var->tcfv var) cst-procs*))))
+ (define (lift-app! var)
+ (let* ((val (var->val var)) (vars (lifted-vars var)))
+ (define (new-ref* var)
+ (new-ref (var-source var) (node-decl val) var))
+ (if (not (null? vars))
+ (for-each
+ (lambda (oper)
+ (let ((node (node-parent oper)))
+ (node-children-set!
+ node
+ (cons (app-oper node)
+ (append (map new-ref* vars) (app-args node))))))
+ (set->list (var-refs var))))))
+ (define (lift-prc! var)
+ (let* ((val (var->val var)) (vars (lifted-vars var)))
+ (if (not (null? vars))
+ (let ((var-copies (map var-copy vars)))
+ (prc-parms-set! val (append var-copies (prc-parms val)))
+ (for-each (lambda (x) (var-bound-set! x val)) var-copies)
+ (node-fv-invalidate! val)
+ (prc-min-set! val (+ (prc-min val) (length vars)))
+ (ll-rename! val (pair-up vars var-copies))))))
+ (for-each lift-app! cst-proc-vars-list)
+ (for-each lift-prc! cst-proc-vars-list)
+ (for-each (lambda (node) (ll! node cst-procs* env)) vals)
+ (ll! (prc-body proc) cst-procs* env))))
+(define (ll-rename! ptree var-map)
+ (cond ((ref? ptree)
+ (let* ((var (ref-var ptree)) (x (assq var var-map)))
+ (if x
+ (begin
+ (var-refs-set! var (set-remove (var-refs var) ptree))
+ (var-refs-set! (cdr x) (set-adjoin (var-refs (cdr x)) ptree))
+ (ref-var-set! ptree (cdr x))))))
+ ((set? ptree)
+ (let* ((var (set-var ptree)) (x (assq var var-map)))
+ (if x
+ (begin
+ (var-sets-set! var (set-remove (var-sets var) ptree))
+ (var-sets-set! (cdr x) (set-adjoin (var-sets (cdr x)) ptree))
+ (set-var-set! ptree (cdr x)))))))
+ (node-fv-set! ptree #t)
+ (for-each (lambda (child) (ll-rename! child var-map)) (node-children ptree)))
+(define (parse-tree->expression ptree) (se ptree '() (list 0)))
+(define (se ptree env num)
+ (cond ((cst? ptree) (list quote-sym (cst-val ptree)))
+ ((ref? ptree)
+ (let ((x (assq (ref-var ptree) env)))
+ (if x (cdr x) (var-name (ref-var ptree)))))
+ ((set? ptree)
+ (list set!-sym
+ (let ((x (assq (set-var ptree) env)))
+ (if x (cdr x) (var-name (set-var ptree))))
+ (se (set-val ptree) env num)))
+ ((def? ptree)
+ (list define-sym
+ (let ((x (assq (def-var ptree) env)))
+ (if x (cdr x) (var-name (def-var ptree))))
+ (se (def-val ptree) env num)))
+ ((tst? ptree)
+ (list if-sym
+ (se (tst-pre ptree) env num)
+ (se (tst-con ptree) env num)
+ (se (tst-alt ptree) env num)))
+ ((conj? ptree)
+ (list and-sym
+ (se (conj-pre ptree) env num)
+ (se (conj-alt ptree) env num)))
+ ((disj? ptree)
+ (list or-sym
+ (se (disj-pre ptree) env num)
+ (se (disj-alt ptree) env num)))
+ ((prc? ptree)
+ (let ((new-env (se-rename (prc-parms ptree) env num)))
+ (list lambda-sym
+ (se-parameters
+ (prc-parms ptree)
+ (prc-rest ptree)
+ (prc-min ptree)
+ new-env)
+ (se (prc-body ptree) new-env num))))
+ ((app? ptree)
+ (let ((oper (app-oper ptree)) (args (app-args ptree)))
+ (if (and (prc? oper)
+ (not (prc-rest oper))
+ (= (length (prc-parms oper)) (length args)))
+ (let ((new-env (se-rename (prc-parms oper) env num)))
+ (list (if (set-empty?
+ (set-intersection
+ (list->set (prc-parms oper))
+ (apply set-union (map free-variables args))))
+ let-sym
+ letrec-sym)
+ (se-bindings (prc-parms oper) args new-env num)
+ (se (prc-body oper) new-env num)))
+ (map (lambda (x) (se x env num)) (cons oper args)))))
+ ((fut? ptree) (list future-sym (se (fut-val ptree) env num)))
+ (else (compiler-internal-error "se, unknown parse tree node type"))))
+(define (se-parameters parms rest min env)
+ (define (se-parms parms rest n env)
+ (cond ((null? parms) '())
+ ((and rest (null? (cdr parms))) (cdr (assq (car parms) env)))
+ (else
+ (let ((parm (cdr (assq (car parms) env))))
+ (cons (if (> n 0) parm (list parm))
+ (se-parms (cdr parms) rest (- n 1) env))))))
+ (se-parms parms rest min env))
+(define (se-bindings vars vals env num)
+ (if (null? vars)
+ '()
+ (cons (list (cdr (assq (car vars) env)) (se (car vals) env num))
+ (se-bindings (cdr vars) (cdr vals) env num))))
+(define (se-rename vars env num)
+ (define (rename vars)
+ (if (null? vars)
+ env
+ (cons (cons (car vars)
+ (string->canonical-symbol
+ (string-append
+ (symbol->string (var-name (car vars)))
+ "#"
+ (number->string (car num)))))
+ (rename (cdr vars)))))
+ (set-car! num (+ (car num) 1))
+ (rename vars))
+(define *opnd-table* '())
+(define *opnd-table-alloc* '())
+(define opnd-table-size 10000)
+(define (enter-opnd arg1 arg2)
+ (let loop ((i 0))
+ (if (< i *opnd-table-alloc*)
+ (let ((x (vector-ref *opnd-table* i)))
+ (if (and (eqv? (car x) arg1) (eqv? (cdr x) arg2)) i (loop (+ i 1))))
+ (if (< *opnd-table-alloc* opnd-table-size)
+ (begin
+ (set! *opnd-table-alloc* (+ *opnd-table-alloc* 1))
+ (vector-set! *opnd-table* i (cons arg1 arg2))
+ i)
+ (compiler-limitation-error
+ "program is too long [virtual machine operand table overflow]")))))
+(define (contains-opnd? opnd1 opnd2)
+ (cond ((eqv? opnd1 opnd2) #t)
+ ((clo? opnd2) (contains-opnd? opnd1 (clo-base opnd2)))
+ (else #f)))
+(define (any-contains-opnd? opnd opnds)
+ (if (null? opnds)
+ #f
+ (or (contains-opnd? opnd (car opnds))
+ (any-contains-opnd? opnd (cdr opnds)))))
+(define (make-reg num) num)
+(define (reg? x) (< x 10000))
+(define (reg-num x) (modulo x 10000))
+(define (make-stk num) (+ num 10000))
+(define (stk? x) (= (quotient x 10000) 1))
+(define (stk-num x) (modulo x 10000))
+(define (make-glo name) (+ (enter-opnd name #t) 30000))
+(define (glo? x) (= (quotient x 10000) 3))
+(define (glo-name x) (car (vector-ref *opnd-table* (modulo x 10000))))
+(define (make-clo base index) (+ (enter-opnd base index) 40000))
+(define (clo? x) (= (quotient x 10000) 4))
+(define (clo-base x) (car (vector-ref *opnd-table* (modulo x 10000))))
+(define (clo-index x) (cdr (vector-ref *opnd-table* (modulo x 10000))))
+(define (make-lbl num) (+ num 20000))
+(define (lbl? x) (= (quotient x 10000) 2))
+(define (lbl-num x) (modulo x 10000))
+(define label-limit 9999)
+(define (make-obj val) (+ (enter-opnd val #f) 50000))
+(define (obj? x) (= (quotient x 10000) 5))
+(define (obj-val x) (car (vector-ref *opnd-table* (modulo x 10000))))
+(define (make-pcontext fs map) (vector fs map))
+(define (pcontext-fs x) (vector-ref x 0))
+(define (pcontext-map x) (vector-ref x 1))
+(define (make-frame size slots regs closed live)
+ (vector size slots regs closed live))
+(define (frame-size x) (vector-ref x 0))
+(define (frame-slots x) (vector-ref x 1))
+(define (frame-regs x) (vector-ref x 2))
+(define (frame-closed x) (vector-ref x 3))
+(define (frame-live x) (vector-ref x 4))
+(define (frame-eq? x y) (= (frame-size x) (frame-size y)))
+(define (frame-truncate frame nb-slots)
+ (let ((fs (frame-size frame)))
+ (make-frame
+ nb-slots
+ (nth-after (frame-slots frame) (- fs nb-slots))
+ (frame-regs frame)
+ (frame-closed frame)
+ (frame-live frame))))
+(define (frame-live? var frame)
+ (let ((live (frame-live frame)))
+ (if (eq? var closure-env-var)
+ (let ((closed (frame-closed frame)))
+ (if (or (set-member? var live)
+ (not (set-empty?
+ (set-intersection live (list->set closed)))))
+ closed
+ #f))
+ (if (set-member? var live) var #f))))
+(define (frame-first-empty-slot frame)
+ (let loop ((i 1) (s (reverse (frame-slots frame))))
+ (if (pair? s)
+ (if (frame-live? (car s) frame) (loop (+ i 1) (cdr s)) i)
+ i)))
+(define (make-proc-obj
+ name
+ primitive?
+ code
+ call-pat
+ side-effects?
+ strict-pat
+ type)
+ (let ((proc-obj
+ (vector proc-obj-tag
+ name
+ primitive?
+ code
+ call-pat
+ #f
+ #f
+ #f
+ side-effects?
+ strict-pat
+ type)))
+ (proc-obj-specialize-set! proc-obj (lambda (decls) proc-obj))
+ proc-obj))
+(define proc-obj-tag (list 'proc-obj))
+(define (proc-obj? x)
+ (and (vector? x)
+ (> (vector-length x) 0)
+ (eq? (vector-ref x 0) proc-obj-tag)))
+(define (proc-obj-name obj) (vector-ref obj 1))
+(define (proc-obj-primitive? obj) (vector-ref obj 2))
+(define (proc-obj-code obj) (vector-ref obj 3))
+(define (proc-obj-call-pat obj) (vector-ref obj 4))
+(define (proc-obj-test obj) (vector-ref obj 5))
+(define (proc-obj-inlinable obj) (vector-ref obj 6))
+(define (proc-obj-specialize obj) (vector-ref obj 7))
+(define (proc-obj-side-effects? obj) (vector-ref obj 8))
+(define (proc-obj-strict-pat obj) (vector-ref obj 9))
+(define (proc-obj-type obj) (vector-ref obj 10))
+(define (proc-obj-code-set! obj x) (vector-set! obj 3 x))
+(define (proc-obj-test-set! obj x) (vector-set! obj 5 x))
+(define (proc-obj-inlinable-set! obj x) (vector-set! obj 6 x))
+(define (proc-obj-specialize-set! obj x) (vector-set! obj 7 x))
+(define (make-pattern min-args nb-parms rest?)
+ (let loop ((x (if rest? (- nb-parms 1) (list nb-parms)))
+ (y (if rest? (- nb-parms 1) nb-parms)))
+ (let ((z (- y 1))) (if (< z min-args) x (loop (cons z x) z)))))
+(define (pattern-member? n pat)
+ (cond ((pair? pat) (if (= (car pat) n) #t (pattern-member? n (cdr pat))))
+ ((null? pat) #f)
+ (else (<= pat n))))
+(define (type-name type) (if (pair? type) (car type) type))
+(define (type-pot-fut? type) (pair? type))
+(define (make-bbs)
+ (vector (make-counter 1 label-limit bbs-limit-err) (queue-empty) '()))
+(define (bbs-limit-err)
+ (compiler-limitation-error "procedure is too long [too many labels]"))
+(define (bbs-lbl-counter bbs) (vector-ref bbs 0))
+(define (bbs-lbl-counter-set! bbs cntr) (vector-set! bbs 0 cntr))
+(define (bbs-bb-queue bbs) (vector-ref bbs 1))
+(define (bbs-bb-queue-set! bbs bbq) (vector-set! bbs 1 bbq))
+(define (bbs-entry-lbl-num bbs) (vector-ref bbs 2))
+(define (bbs-entry-lbl-num-set! bbs lbl-num) (vector-set! bbs 2 lbl-num))
+(define (bbs-new-lbl! bbs) ((bbs-lbl-counter bbs)))
+(define (lbl-num->bb lbl-num bbs)
+ (let loop ((bb-list (queue->list (bbs-bb-queue bbs))))
+ (if (= (bb-lbl-num (car bb-list)) lbl-num)
+ (car bb-list)
+ (loop (cdr bb-list)))))
+(define (make-bb label-instr bbs)
+ (let ((bb (vector label-instr (queue-empty) '() '() '())))
+ (queue-put! (vector-ref bbs 1) bb)
+ bb))
+(define (bb-lbl-num bb) (label-lbl-num (vector-ref bb 0)))
+(define (bb-label-type bb) (label-type (vector-ref bb 0)))
+(define (bb-label-instr bb) (vector-ref bb 0))
+(define (bb-label-instr-set! bb l) (vector-set! bb 0 l))
+(define (bb-non-branch-instrs bb) (queue->list (vector-ref bb 1)))
+(define (bb-non-branch-instrs-set! bb l) (vector-set! bb 1 (list->queue l)))
+(define (bb-branch-instr bb) (vector-ref bb 2))
+(define (bb-branch-instr-set! bb b) (vector-set! bb 2 b))
+(define (bb-references bb) (vector-ref bb 3))
+(define (bb-references-set! bb l) (vector-set! bb 3 l))
+(define (bb-precedents bb) (vector-ref bb 4))
+(define (bb-precedents-set! bb l) (vector-set! bb 4 l))
+(define (bb-entry-frame-size bb)
+ (frame-size (gvm-instr-frame (bb-label-instr bb))))
+(define (bb-exit-frame-size bb)
+ (frame-size (gvm-instr-frame (bb-branch-instr bb))))
+(define (bb-slots-gained bb)
+ (- (bb-exit-frame-size bb) (bb-entry-frame-size bb)))
+(define (bb-put-non-branch! bb gvm-instr)
+ (queue-put! (vector-ref bb 1) gvm-instr))
+(define (bb-put-branch! bb gvm-instr) (vector-set! bb 2 gvm-instr))
+(define (bb-add-reference! bb ref)
+ (if (not (memq ref (vector-ref bb 3)))
+ (vector-set! bb 3 (cons ref (vector-ref bb 3)))))
+(define (bb-add-precedent! bb prec)
+ (if (not (memq prec (vector-ref bb 4)))
+ (vector-set! bb 4 (cons prec (vector-ref bb 4)))))
+(define (bb-last-non-branch-instr bb)
+ (let ((non-branch-instrs (bb-non-branch-instrs bb)))
+ (if (null? non-branch-instrs)
+ (bb-label-instr bb)
+ (let loop ((l non-branch-instrs))
+ (if (pair? (cdr l)) (loop (cdr l)) (car l))))))
+(define (gvm-instr-type gvm-instr) (vector-ref gvm-instr 0))
+(define (gvm-instr-frame gvm-instr) (vector-ref gvm-instr 1))
+(define (gvm-instr-comment gvm-instr) (vector-ref gvm-instr 2))
+(define (make-label-simple lbl-num frame comment)
+ (vector 'label frame comment lbl-num 'simple))
+(define (make-label-entry lbl-num nb-parms min rest? closed? frame comment)
+ (vector 'label frame comment lbl-num 'entry nb-parms min rest? closed?))
+(define (make-label-return lbl-num frame comment)
+ (vector 'label frame comment lbl-num 'return))
+(define (make-label-task-entry lbl-num frame comment)
+ (vector 'label frame comment lbl-num 'task-entry))
+(define (make-label-task-return lbl-num frame comment)
+ (vector 'label frame comment lbl-num 'task-return))
+(define (label-lbl-num gvm-instr) (vector-ref gvm-instr 3))
+(define (label-lbl-num-set! gvm-instr n) (vector-set! gvm-instr 3 n))
+(define (label-type gvm-instr) (vector-ref gvm-instr 4))
+(define (label-entry-nb-parms gvm-instr) (vector-ref gvm-instr 5))
+(define (label-entry-min gvm-instr) (vector-ref gvm-instr 6))
+(define (label-entry-rest? gvm-instr) (vector-ref gvm-instr 7))
+(define (label-entry-closed? gvm-instr) (vector-ref gvm-instr 8))
+(define (make-apply prim opnds loc frame comment)
+ (vector 'apply frame comment prim opnds loc))
+(define (apply-prim gvm-instr) (vector-ref gvm-instr 3))
+(define (apply-opnds gvm-instr) (vector-ref gvm-instr 4))
+(define (apply-loc gvm-instr) (vector-ref gvm-instr 5))
+(define (make-copy opnd loc frame comment)
+ (vector 'copy frame comment opnd loc))
+(define (copy-opnd gvm-instr) (vector-ref gvm-instr 3))
+(define (copy-loc gvm-instr) (vector-ref gvm-instr 4))
+(define (make-close parms frame comment) (vector 'close frame comment parms))
+(define (close-parms gvm-instr) (vector-ref gvm-instr 3))
+(define (make-closure-parms loc lbl opnds) (vector loc lbl opnds))
+(define (closure-parms-loc x) (vector-ref x 0))
+(define (closure-parms-lbl x) (vector-ref x 1))
+(define (closure-parms-opnds x) (vector-ref x 2))
+(define (make-ifjump test opnds true false poll? frame comment)
+ (vector 'ifjump frame comment test opnds true false poll?))
+(define (ifjump-test gvm-instr) (vector-ref gvm-instr 3))
+(define (ifjump-opnds gvm-instr) (vector-ref gvm-instr 4))
+(define (ifjump-true gvm-instr) (vector-ref gvm-instr 5))
+(define (ifjump-false gvm-instr) (vector-ref gvm-instr 6))
+(define (ifjump-poll? gvm-instr) (vector-ref gvm-instr 7))
+(define (make-jump opnd nb-args poll? frame comment)
+ (vector 'jump frame comment opnd nb-args poll?))
+(define (jump-opnd gvm-instr) (vector-ref gvm-instr 3))
+(define (jump-nb-args gvm-instr) (vector-ref gvm-instr 4))
+(define (jump-poll? gvm-instr) (vector-ref gvm-instr 5))
+(define (first-class-jump? gvm-instr) (jump-nb-args gvm-instr))
+(define (make-comment) (cons 'comment '()))
+(define (comment-put! comment name val)
+ (set-cdr! comment (cons (cons name val) (cdr comment))))
+(define (comment-get comment name)
+ (and comment (let ((x (assq name (cdr comment)))) (if x (cdr x) #f))))
+(define (bbs-purify! bbs)
+ (let loop ()
+ (bbs-remove-jump-cascades! bbs)
+ (bbs-remove-dead-code! bbs)
+ (let* ((changed1? (bbs-remove-common-code! bbs))
+ (changed2? (bbs-remove-useless-jumps! bbs)))
+ (if (or changed1? changed2?) (loop) (bbs-order! bbs)))))
+(define (bbs-remove-jump-cascades! bbs)
+ (define (empty-bb? bb)
+ (and (eq? (bb-label-type bb) 'simple) (null? (bb-non-branch-instrs bb))))
+ (define (jump-to-non-entry-lbl? branch)
+ (and (eq? (gvm-instr-type branch) 'jump)
+ (not (first-class-jump? branch))
+ (jump-lbl? branch)))
+ (define (jump-cascade-to lbl-num fs poll? seen thunk)
+ (if (memq lbl-num seen)
+ (thunk lbl-num fs poll?)
+ (let ((bb (lbl-num->bb lbl-num bbs)))
+ (if (and (empty-bb? bb) (<= (bb-slots-gained bb) 0))
+ (let ((jump-lbl-num
+ (jump-to-non-entry-lbl? (bb-branch-instr bb))))
+ (if jump-lbl-num
+ (jump-cascade-to
+ jump-lbl-num
+ (+ fs (bb-slots-gained bb))
+ (or poll? (jump-poll? (bb-branch-instr bb)))
+ (cons lbl-num seen)
+ thunk)
+ (thunk lbl-num fs poll?)))
+ (thunk lbl-num fs poll?)))))
+ (define (equiv-lbl lbl-num seen)
+ (if (memq lbl-num seen)
+ lbl-num
+ (let ((bb (lbl-num->bb lbl-num bbs)))
+ (if (empty-bb? bb)
+ (let ((jump-lbl-num
+ (jump-to-non-entry-lbl? (bb-branch-instr bb))))
+ (if (and jump-lbl-num
+ (not (jump-poll? (bb-branch-instr bb)))
+ (= (bb-slots-gained bb) 0))
+ (equiv-lbl jump-lbl-num (cons lbl-num seen))
+ lbl-num))
+ lbl-num))))
+ (define (remove-cascade! bb)
+ (let ((branch (bb-branch-instr bb)))
+ (case (gvm-instr-type branch)
+ ((ifjump)
+ (bb-put-branch!
+ bb
+ (make-ifjump
+ (ifjump-test branch)
+ (ifjump-opnds branch)
+ (equiv-lbl (ifjump-true branch) '())
+ (equiv-lbl (ifjump-false branch) '())
+ (ifjump-poll? branch)
+ (gvm-instr-frame branch)
+ (gvm-instr-comment branch))))
+ ((jump)
+ (if (not (first-class-jump? branch))
+ (let ((dest-lbl-num (jump-lbl? branch)))
+ (if dest-lbl-num
+ (jump-cascade-to
+ dest-lbl-num
+ (frame-size (gvm-instr-frame branch))
+ (jump-poll? branch)
+ '()
+ (lambda (lbl-num fs poll?)
+ (let* ((dest-bb (lbl-num->bb lbl-num bbs))
+ (last-branch (bb-branch-instr dest-bb)))
+ (if (and (empty-bb? dest-bb)
+ (or (not poll?)
+ put-poll-on-ifjump?
+ (not (eq? (gvm-instr-type last-branch)
+ 'ifjump))))
+ (let* ((new-fs (+ fs (bb-slots-gained dest-bb)))
+ (new-frame
+ (frame-truncate
+ (gvm-instr-frame branch)
+ new-fs)))
+ (define (adjust-opnd opnd)
+ (cond ((stk? opnd)
+ (make-stk
+ (+ (- fs (bb-entry-frame-size dest-bb))
+ (stk-num opnd))))
+ ((clo? opnd)
+ (make-clo
+ (adjust-opnd (clo-base opnd))
+ (clo-index opnd)))
+ (else opnd)))
+ (case (gvm-instr-type last-branch)
+ ((ifjump)
+ (bb-put-branch!
+ bb
+ (make-ifjump
+ (ifjump-test last-branch)
+ (map adjust-opnd (ifjump-opnds last-branch))
+ (equiv-lbl (ifjump-true last-branch) '())
+ (equiv-lbl (ifjump-false last-branch) '())
+ (or poll? (ifjump-poll? last-branch))
+ new-frame
+ (gvm-instr-comment last-branch))))
+ ((jump)
+ (bb-put-branch!
+ bb
+ (make-jump
+ (adjust-opnd (jump-opnd last-branch))
+ (jump-nb-args last-branch)
+ (or poll? (jump-poll? last-branch))
+ new-frame
+ (gvm-instr-comment last-branch))))
+ (else
+ (compiler-internal-error
+ "bbs-remove-jump-cascades!, unknown branch type"))))
+ (bb-put-branch!
+ bb
+ (make-jump
+ (make-lbl lbl-num)
+ (jump-nb-args branch)
+ (or poll? (jump-poll? branch))
+ (frame-truncate (gvm-instr-frame branch) fs)
+ (gvm-instr-comment branch)))))))))))
+ (else
+ (compiler-internal-error
+ "bbs-remove-jump-cascades!, unknown branch type")))))
+ (for-each remove-cascade! (queue->list (bbs-bb-queue bbs))))
+(define (jump-lbl? branch)
+ (let ((opnd (jump-opnd branch))) (if (lbl? opnd) (lbl-num opnd) #f)))
+(define put-poll-on-ifjump? #f)
+(set! put-poll-on-ifjump? #t)
+(define (bbs-remove-dead-code! bbs)
+ (let ((new-bb-queue (queue-empty)) (scan-queue (queue-empty)))
+ (define (reachable ref bb)
+ (if bb (bb-add-reference! bb ref))
+ (if (not (memq ref (queue->list new-bb-queue)))
+ (begin
+ (bb-references-set! ref '())
+ (bb-precedents-set! ref '())
+ (queue-put! new-bb-queue ref)
+ (queue-put! scan-queue ref))))
+ (define (direct-jump to-bb from-bb)
+ (reachable to-bb from-bb)
+ (bb-add-precedent! to-bb from-bb))
+ (define (scan-instr gvm-instr bb)
+ (define (scan-opnd gvm-opnd)
+ (cond ((lbl? gvm-opnd)
+ (reachable (lbl-num->bb (lbl-num gvm-opnd) bbs) bb))
+ ((clo? gvm-opnd) (scan-opnd (clo-base gvm-opnd)))))
+ (case (gvm-instr-type gvm-instr)
+ ((label) '())
+ ((apply)
+ (for-each scan-opnd (apply-opnds gvm-instr))
+ (if (apply-loc gvm-instr) (scan-opnd (apply-loc gvm-instr))))
+ ((copy)
+ (scan-opnd (copy-opnd gvm-instr))
+ (scan-opnd (copy-loc gvm-instr)))
+ ((close)
+ (for-each
+ (lambda (parm)
+ (reachable (lbl-num->bb (closure-parms-lbl parm) bbs) bb)
+ (scan-opnd (closure-parms-loc parm))
+ (for-each scan-opnd (closure-parms-opnds parm)))
+ (close-parms gvm-instr)))
+ ((ifjump)
+ (for-each scan-opnd (ifjump-opnds gvm-instr))
+ (direct-jump (lbl-num->bb (ifjump-true gvm-instr) bbs) bb)
+ (direct-jump (lbl-num->bb (ifjump-false gvm-instr) bbs) bb))
+ ((jump)
+ (let ((opnd (jump-opnd gvm-instr)))
+ (if (lbl? opnd)
+ (direct-jump (lbl-num->bb (lbl-num opnd) bbs) bb)
+ (scan-opnd (jump-opnd gvm-instr)))))
+ (else
+ (compiler-internal-error
+ "bbs-remove-dead-code!, unknown GVM instruction type"))))
+ (reachable (lbl-num->bb (bbs-entry-lbl-num bbs) bbs) #f)
+ (let loop ()
+ (if (not (queue-empty? scan-queue))
+ (let ((bb (queue-get! scan-queue)))
+ (begin
+ (scan-instr (bb-label-instr bb) bb)
+ (for-each
+ (lambda (gvm-instr) (scan-instr gvm-instr bb))
+ (bb-non-branch-instrs bb))
+ (scan-instr (bb-branch-instr bb) bb)
+ (loop)))))
+ (bbs-bb-queue-set! bbs new-bb-queue)))
+(define (bbs-remove-useless-jumps! bbs)
+ (let ((changed? #f))
+ (define (remove-useless-jump bb)
+ (let ((branch (bb-branch-instr bb)))
+ (if (and (eq? (gvm-instr-type branch) 'jump)
+ (not (first-class-jump? branch))
+ (not (jump-poll? branch))
+ (jump-lbl? branch))
+ (let* ((dest-bb (lbl-num->bb (jump-lbl? branch) bbs))
+ (frame1 (gvm-instr-frame (bb-last-non-branch-instr bb)))
+ (frame2 (gvm-instr-frame (bb-label-instr dest-bb))))
+ (if (and (eq? (bb-label-type dest-bb) 'simple)
+ (frame-eq? frame1 frame2)
+ (= (length (bb-precedents dest-bb)) 1))
+ (begin
+ (set! changed? #t)
+ (bb-non-branch-instrs-set!
+ bb
+ (append (bb-non-branch-instrs bb)
+ (bb-non-branch-instrs dest-bb)
+ '()))
+ (bb-branch-instr-set! bb (bb-branch-instr dest-bb))
+ (remove-useless-jump bb)))))))
+ (for-each remove-useless-jump (queue->list (bbs-bb-queue bbs)))
+ changed?))
+(define (bbs-remove-common-code! bbs)
+ (let* ((bb-list (queue->list (bbs-bb-queue bbs)))
+ (n (length bb-list))
+ (hash-table-length (cond ((< n 50) 43) ((< n 500) 403) (else 4003)))
+ (hash-table (make-vector hash-table-length '()))
+ (prim-table '())
+ (block-map '())
+ (changed? #f))
+ (define (hash-prim prim)
+ (let ((n (length prim-table)) (i (pos-in-list prim prim-table)))
+ (if i
+ (- n i)
+ (begin (set! prim-table (cons prim prim-table)) (+ n 1)))))
+ (define (hash-opnds l)
+ (let loop ((l l) (n 0))
+ (if (pair? l)
+ (loop (cdr l)
+ (let ((x (car l)))
+ (if (lbl? x)
+ n
+ (modulo (+ (* n 10000) x) hash-table-length))))
+ n)))
+ (define (hash-bb bb)
+ (let ((branch (bb-branch-instr bb)))
+ (modulo (case (gvm-instr-type branch)
+ ((ifjump)
+ (+ (hash-opnds (ifjump-opnds branch))
+ (* 10 (hash-prim (ifjump-test branch)))
+ (* 100 (frame-size (gvm-instr-frame branch)))))
+ ((jump)
+ (+ (hash-opnds (list (jump-opnd branch)))
+ (* 10 (or (jump-nb-args branch) -1))
+ (* 100 (frame-size (gvm-instr-frame branch)))))
+ (else 0))
+ hash-table-length)))
+ (define (replacement-lbl-num lbl)
+ (let ((x (assv lbl block-map))) (if x (cdr x) lbl)))
+ (define (fix-map! bb1 bb2)
+ (let loop ((l block-map))
+ (if (pair? l)
+ (let ((x (car l)))
+ (if (= bb1 (cdr x)) (set-cdr! x bb2))
+ (loop (cdr l))))))
+ (define (enter-bb! bb)
+ (let ((h (hash-bb bb)))
+ (vector-set! hash-table h (add-bb bb (vector-ref hash-table h)))))
+ (define (add-bb bb l)
+ (if (pair? l)
+ (let ((bb* (car l)))
+ (set! block-map
+ (cons (cons (bb-lbl-num bb) (bb-lbl-num bb*)) block-map))
+ (if (eqv-bb? bb bb*)
+ (begin
+ (fix-map! (bb-lbl-num bb) (bb-lbl-num bb*))
+ (set! changed? #t)
+ l)
+ (begin
+ (set! block-map (cdr block-map))
+ (if (eqv-gvm-instr?
+ (bb-branch-instr bb)
+ (bb-branch-instr bb*))
+ (extract-common-tail
+ bb
+ bb*
+ (lambda (head head* tail)
+ (if (null? tail)
+ (cons bb* (add-bb bb (cdr l)))
+ (let* ((lbl (bbs-new-lbl! bbs))
+ (branch (bb-branch-instr bb))
+ (fs** (need-gvm-instrs tail branch))
+ (frame (frame-truncate
+ (gvm-instr-frame
+ (if (null? head)
+ (bb-label-instr bb)
+ (car head)))
+ fs**))
+ (bb** (make-bb (make-label-simple
+ lbl
+ frame
+ #f)
+ bbs)))
+ (bb-non-branch-instrs-set! bb** tail)
+ (bb-branch-instr-set! bb** branch)
+ (bb-non-branch-instrs-set! bb* (reverse head*))
+ (bb-branch-instr-set!
+ bb*
+ (make-jump (make-lbl lbl) #f #f frame #f))
+ (bb-non-branch-instrs-set! bb (reverse head))
+ (bb-branch-instr-set!
+ bb
+ (make-jump (make-lbl lbl) #f #f frame #f))
+ (set! changed? #t)
+ (cons bb (cons bb* (add-bb bb** (cdr l))))))))
+ (cons bb* (add-bb bb (cdr l)))))))
+ (list bb)))
+ (define (extract-common-tail bb1 bb2 cont)
+ (let loop ((l1 (reverse (bb-non-branch-instrs bb1)))
+ (l2 (reverse (bb-non-branch-instrs bb2)))
+ (tail '()))
+ (if (and (pair? l1) (pair? l2))
+ (let ((i1 (car l1)) (i2 (car l2)))
+ (if (eqv-gvm-instr? i1 i2)
+ (loop (cdr l1) (cdr l2) (cons i1 tail))
+ (cont l1 l2 tail)))
+ (cont l1 l2 tail))))
+ (define (eqv-bb? bb1 bb2)
+ (let ((bb1-non-branch (bb-non-branch-instrs bb1))
+ (bb2-non-branch (bb-non-branch-instrs bb2)))
+ (and (= (length bb1-non-branch) (length bb2-non-branch))
+ (eqv-gvm-instr? (bb-label-instr bb1) (bb-label-instr bb2))
+ (eqv-gvm-instr? (bb-branch-instr bb1) (bb-branch-instr bb2))
+ (eqv-list? eqv-gvm-instr? bb1-non-branch bb2-non-branch))))
+ (define (eqv-list? pred? l1 l2)
+ (if (pair? l1)
+ (and (pair? l2)
+ (pred? (car l1) (car l2))
+ (eqv-list? pred? (cdr l1) (cdr l2)))
+ (not (pair? l2))))
+ (define (eqv-lbl-num? lbl1 lbl2)
+ (= (replacement-lbl-num lbl1) (replacement-lbl-num lbl2)))
+ (define (eqv-gvm-opnd? opnd1 opnd2)
+ (if (not opnd1)
+ (not opnd2)
+ (and opnd2
+ (cond ((lbl? opnd1)
+ (and (lbl? opnd2)
+ (eqv-lbl-num? (lbl-num opnd1) (lbl-num opnd2))))
+ ((clo? opnd1)
+ (and (clo? opnd2)
+ (= (clo-index opnd1) (clo-index opnd2))
+ (eqv-gvm-opnd? (clo-base opnd1) (clo-base opnd2))))
+ (else (eqv? opnd1 opnd2))))))
+ (define (eqv-gvm-instr? instr1 instr2)
+ (define (eqv-closure-parms? p1 p2)
+ (and (eqv-gvm-opnd? (closure-parms-loc p1) (closure-parms-loc p2))
+ (eqv-lbl-num? (closure-parms-lbl p1) (closure-parms-lbl p2))
+ (eqv-list?
+ eqv-gvm-opnd?
+ (closure-parms-opnds p1)
+ (closure-parms-opnds p2))))
+ (let ((type1 (gvm-instr-type instr1)) (type2 (gvm-instr-type instr2)))
+ (and (eq? type1 type2)
+ (frame-eq? (gvm-instr-frame instr1) (gvm-instr-frame instr2))
+ (case type1
+ ((label)
+ (let ((ltype1 (label-type instr1))
+ (ltype2 (label-type instr2)))
+ (and (eq? ltype1 ltype2)
+ (case ltype1
+ ((simple return task-entry task-return) #t)
+ ((entry)
+ (and (= (label-entry-min instr1)
+ (label-entry-min instr2))
+ (= (label-entry-nb-parms instr1)
+ (label-entry-nb-parms instr2))
+ (eq? (label-entry-rest? instr1)
+ (label-entry-rest? instr2))
+ (eq? (label-entry-closed? instr1)
+ (label-entry-closed? instr2))))
+ (else
+ (compiler-internal-error
+ "eqv-gvm-instr?, unknown label type"))))))
+ ((apply)
+ (and (eq? (apply-prim instr1) (apply-prim instr2))
+ (eqv-list?
+ eqv-gvm-opnd?
+ (apply-opnds instr1)
+ (apply-opnds instr2))
+ (eqv-gvm-opnd? (apply-loc instr1) (apply-loc instr2))))
+ ((copy)
+ (and (eqv-gvm-opnd? (copy-opnd instr1) (copy-opnd instr2))
+ (eqv-gvm-opnd? (copy-loc instr1) (copy-loc instr2))))
+ ((close)
+ (eqv-list?
+ eqv-closure-parms?
+ (close-parms instr1)
+ (close-parms instr2)))
+ ((ifjump)
+ (and (eq? (ifjump-test instr1) (ifjump-test instr2))
+ (eqv-list?
+ eqv-gvm-opnd?
+ (ifjump-opnds instr1)
+ (ifjump-opnds instr2))
+ (eqv-lbl-num? (ifjump-true instr1) (ifjump-true instr2))
+ (eqv-lbl-num? (ifjump-false instr1) (ifjump-false instr2))
+ (eq? (ifjump-poll? instr1) (ifjump-poll? instr2))))
+ ((jump)
+ (and (eqv-gvm-opnd? (jump-opnd instr1) (jump-opnd instr2))
+ (eqv? (jump-nb-args instr1) (jump-nb-args instr2))
+ (eq? (jump-poll? instr1) (jump-poll? instr2))))
+ (else
+ (compiler-internal-error
+ "eqv-gvm-instr?, unknown 'gvm-instr':"
+ instr1))))))
+ (define (update-bb! bb) (replace-label-references! bb replacement-lbl-num))
+ (for-each enter-bb! bb-list)
+ (bbs-entry-lbl-num-set! bbs (replacement-lbl-num (bbs-entry-lbl-num bbs)))
+ (let loop ((i 0) (result '()))
+ (if (< i hash-table-length)
+ (let ((bb-kept (vector-ref hash-table i)))
+ (for-each update-bb! bb-kept)
+ (loop (+ i 1) (append bb-kept result)))
+ (bbs-bb-queue-set! bbs (list->queue result))))
+ changed?))
+(define (replace-label-references! bb replacement-lbl-num)
+ (define (update-gvm-opnd opnd)
+ (if opnd
+ (cond ((lbl? opnd) (make-lbl (replacement-lbl-num (lbl-num opnd))))
+ ((clo? opnd)
+ (make-clo (update-gvm-opnd (clo-base opnd)) (clo-index opnd)))
+ (else opnd))
+ opnd))
+ (define (update-gvm-instr instr)
+ (define (update-closure-parms p)
+ (make-closure-parms
+ (update-gvm-opnd (closure-parms-loc p))
+ (replacement-lbl-num (closure-parms-lbl p))
+ (map update-gvm-opnd (closure-parms-opnds p))))
+ (case (gvm-instr-type instr)
+ ((apply)
+ (make-apply
+ (apply-prim instr)
+ (map update-gvm-opnd (apply-opnds instr))
+ (update-gvm-opnd (apply-loc instr))
+ (gvm-instr-frame instr)
+ (gvm-instr-comment instr)))
+ ((copy)
+ (make-copy
+ (update-gvm-opnd (copy-opnd instr))
+ (update-gvm-opnd (copy-loc instr))
+ (gvm-instr-frame instr)
+ (gvm-instr-comment instr)))
+ ((close)
+ (make-close
+ (map update-closure-parms (close-parms instr))
+ (gvm-instr-frame instr)
+ (gvm-instr-comment instr)))
+ ((ifjump)
+ (make-ifjump
+ (ifjump-test instr)
+ (map update-gvm-opnd (ifjump-opnds instr))
+ (replacement-lbl-num (ifjump-true instr))
+ (replacement-lbl-num (ifjump-false instr))
+ (ifjump-poll? instr)
+ (gvm-instr-frame instr)
+ (gvm-instr-comment instr)))
+ ((jump)
+ (make-jump
+ (update-gvm-opnd (jump-opnd instr))
+ (jump-nb-args instr)
+ (jump-poll? instr)
+ (gvm-instr-frame instr)
+ (gvm-instr-comment instr)))
+ (else
+ (compiler-internal-error "update-gvm-instr, unknown 'instr':" instr))))
+ (bb-non-branch-instrs-set!
+ bb
+ (map update-gvm-instr (bb-non-branch-instrs bb)))
+ (bb-branch-instr-set! bb (update-gvm-instr (bb-branch-instr bb))))
+(define (bbs-order! bbs)
+ (let ((new-bb-queue (queue-empty))
+ (left-to-schedule (queue->list (bbs-bb-queue bbs))))
+ (define (remove x l)
+ (if (eq? (car l) x) (cdr l) (cons (car l) (remove x (cdr l)))))
+ (define (remove-bb! bb)
+ (set! left-to-schedule (remove bb left-to-schedule))
+ bb)
+ (define (prec-bb bb)
+ (let loop ((l (bb-precedents bb)) (best #f) (best-fs #f))
+ (if (null? l)
+ best
+ (let* ((x (car l)) (x-fs (bb-exit-frame-size x)))
+ (if (and (memq x left-to-schedule)
+ (or (not best) (< x-fs best-fs)))
+ (loop (cdr l) x x-fs)
+ (loop (cdr l) best best-fs))))))
+ (define (succ-bb bb)
+ (define (branches-to-lbl? bb)
+ (let ((branch (bb-branch-instr bb)))
+ (case (gvm-instr-type branch)
+ ((ifjump) #t)
+ ((jump) (lbl? (jump-opnd branch)))
+ (else
+ (compiler-internal-error "bbs-order!, unknown branch type")))))
+ (define (best-succ bb1 bb2)
+ (if (branches-to-lbl? bb1)
+ bb1
+ (if (branches-to-lbl? bb2)
+ bb2
+ (if (< (bb-exit-frame-size bb1) (bb-exit-frame-size bb2))
+ bb2
+ bb1))))
+ (let ((branch (bb-branch-instr bb)))
+ (case (gvm-instr-type branch)
+ ((ifjump)
+ (let* ((true-bb (lbl-num->bb (ifjump-true branch) bbs))
+ (true-bb* (and (memq true-bb left-to-schedule) true-bb))
+ (false-bb (lbl-num->bb (ifjump-false branch) bbs))
+ (false-bb* (and (memq false-bb left-to-schedule) false-bb)))
+ (if (and true-bb* false-bb*)
+ (best-succ true-bb* false-bb*)
+ (or true-bb* false-bb*))))
+ ((jump)
+ (let ((opnd (jump-opnd branch)))
+ (and (lbl? opnd)
+ (let ((bb (lbl-num->bb (lbl-num opnd) bbs)))
+ (and (memq bb left-to-schedule) bb)))))
+ (else (compiler-internal-error "bbs-order!, unknown branch type")))))
+ (define (schedule-from bb)
+ (queue-put! new-bb-queue bb)
+ (let ((x (succ-bb bb)))
+ (if x
+ (begin
+ (schedule-around (remove-bb! x))
+ (let ((y (succ-bb bb)))
+ (if y (schedule-around (remove-bb! y)))))))
+ (schedule-refs bb))
+ (define (schedule-around bb)
+ (let ((x (prec-bb bb)))
+ (if x
+ (let ((bb-list (schedule-back (remove-bb! x) '())))
+ (queue-put! new-bb-queue x)
+ (schedule-forw bb)
+ (for-each schedule-refs bb-list))
+ (schedule-from bb))))
+ (define (schedule-back bb bb-list)
+ (let ((bb-list* (cons bb bb-list)) (x (prec-bb bb)))
+ (if x
+ (let ((bb-list (schedule-back (remove-bb! x) bb-list*)))
+ (queue-put! new-bb-queue x)
+ bb-list)
+ bb-list*)))
+ (define (schedule-forw bb)
+ (queue-put! new-bb-queue bb)
+ (let ((x (succ-bb bb)))
+ (if x
+ (begin
+ (schedule-forw (remove-bb! x))
+ (let ((y (succ-bb bb)))
+ (if y (schedule-around (remove-bb! y)))))))
+ (schedule-refs bb))
+ (define (schedule-refs bb)
+ (for-each
+ (lambda (x)
+ (if (memq x left-to-schedule) (schedule-around (remove-bb! x))))
+ (bb-references bb)))
+ (schedule-from (remove-bb! (lbl-num->bb (bbs-entry-lbl-num bbs) bbs)))
+ (bbs-bb-queue-set! bbs new-bb-queue)
+ (let ((bb-list (queue->list new-bb-queue)))
+ (let loop ((l bb-list) (i 1) (lbl-map '()))
+ (if (pair? l)
+ (let* ((label-instr (bb-label-instr (car l)))
+ (old-lbl-num (label-lbl-num label-instr)))
+ (label-lbl-num-set! label-instr i)
+ (loop (cdr l) (+ i 1) (cons (cons old-lbl-num i) lbl-map)))
+ (let ()
+ (define (replacement-lbl-num x) (cdr (assv x lbl-map)))
+ (define (update-bb! bb)
+ (replace-label-references! bb replacement-lbl-num))
+ (for-each update-bb! bb-list)
+ (bbs-lbl-counter-set!
+ bbs
+ (make-counter
+ (* (+ 1 (quotient (bbs-new-lbl! bbs) 1000)) 1000)
+ label-limit
+ bbs-limit-err))))))))
+(define (make-code bb gvm-instr sn) (vector bb gvm-instr sn))
+(define (code-bb code) (vector-ref code 0))
+(define (code-gvm-instr code) (vector-ref code 1))
+(define (code-slots-needed code) (vector-ref code 2))
+(define (code-slots-needed-set! code n) (vector-set! code 2 n))
+(define (bbs->code-list bbs)
+ (let ((code-list (linearize bbs)))
+ (setup-slots-needed! code-list)
+ code-list))
+(define (linearize bbs)
+ (let ((code-queue (queue-empty)))
+ (define (put-bb bb)
+ (define (put-instr gvm-instr)
+ (queue-put! code-queue (make-code bb gvm-instr #f)))
+ (put-instr (bb-label-instr bb))
+ (for-each put-instr (bb-non-branch-instrs bb))
+ (put-instr (bb-branch-instr bb)))
+ (for-each put-bb (queue->list (bbs-bb-queue bbs)))
+ (queue->list code-queue)))
+(define (setup-slots-needed! code-list)
+ (if (null? code-list)
+ #f
+ (let* ((code (car code-list))
+ (gvm-instr (code-gvm-instr code))
+ (sn-rest (setup-slots-needed! (cdr code-list))))
+ (case (gvm-instr-type gvm-instr)
+ ((label)
+ (if (> sn-rest (frame-size (gvm-instr-frame gvm-instr)))
+ (compiler-internal-error
+ "setup-slots-needed!, incoherent slots needed for LABEL"))
+ (code-slots-needed-set! code sn-rest)
+ #f)
+ ((ifjump jump)
+ (let ((sn (frame-size (gvm-instr-frame gvm-instr))))
+ (code-slots-needed-set! code sn)
+ (need-gvm-instr gvm-instr sn)))
+ (else
+ (code-slots-needed-set! code sn-rest)
+ (need-gvm-instr gvm-instr sn-rest))))))
+(define (need-gvm-instrs non-branch branch)
+ (if (pair? non-branch)
+ (need-gvm-instr
+ (car non-branch)
+ (need-gvm-instrs (cdr non-branch) branch))
+ (need-gvm-instr branch (frame-size (gvm-instr-frame branch)))))
+(define (need-gvm-instr gvm-instr sn-rest)
+ (case (gvm-instr-type gvm-instr)
+ ((label) sn-rest)
+ ((apply)
+ (let ((loc (apply-loc gvm-instr)))
+ (need-gvm-opnds
+ (apply-opnds gvm-instr)
+ (need-gvm-loc-opnd loc (need-gvm-loc loc sn-rest)))))
+ ((copy)
+ (let ((loc (copy-loc gvm-instr)))
+ (need-gvm-opnd
+ (copy-opnd gvm-instr)
+ (need-gvm-loc-opnd loc (need-gvm-loc loc sn-rest)))))
+ ((close)
+ (let ((parms (close-parms gvm-instr)))
+ (define (need-parms-opnds p)
+ (if (null? p)
+ sn-rest
+ (need-gvm-opnds
+ (closure-parms-opnds (car p))
+ (need-parms-opnds (cdr p)))))
+ (define (need-parms-loc p)
+ (if (null? p)
+ (need-parms-opnds parms)
+ (let ((loc (closure-parms-loc (car p))))
+ (need-gvm-loc-opnd
+ loc
+ (need-gvm-loc loc (need-parms-loc (cdr p)))))))
+ (need-parms-loc parms)))
+ ((ifjump) (need-gvm-opnds (ifjump-opnds gvm-instr) sn-rest))
+ ((jump) (need-gvm-opnd (jump-opnd gvm-instr) sn-rest))
+ (else
+ (compiler-internal-error
+ "need-gvm-instr, unknown 'gvm-instr':"
+ gvm-instr))))
+(define (need-gvm-loc loc sn-rest)
+ (if (and loc (stk? loc) (>= (stk-num loc) sn-rest))
+ (- (stk-num loc) 1)
+ sn-rest))
+(define (need-gvm-loc-opnd gvm-loc slots-needed)
+ (if (and gvm-loc (clo? gvm-loc))
+ (need-gvm-opnd (clo-base gvm-loc) slots-needed)
+ slots-needed))
+(define (need-gvm-opnd gvm-opnd slots-needed)
+ (cond ((stk? gvm-opnd) (max (stk-num gvm-opnd) slots-needed))
+ ((clo? gvm-opnd) (need-gvm-opnd (clo-base gvm-opnd) slots-needed))
+ (else slots-needed)))
+(define (need-gvm-opnds gvm-opnds slots-needed)
+ (if (null? gvm-opnds)
+ slots-needed
+ (need-gvm-opnd
+ (car gvm-opnds)
+ (need-gvm-opnds (cdr gvm-opnds) slots-needed))))
+(define (write-bb bb port)
+ (write-gvm-instr (bb-label-instr bb) port)
+ (display " [precedents=" port)
+ (write (map bb-lbl-num (bb-precedents bb)) port)
+ (display "]" port)
+ (newline port)
+ (for-each
+ (lambda (x) (write-gvm-instr x port) (newline port))
+ (bb-non-branch-instrs bb))
+ (write-gvm-instr (bb-branch-instr bb) port))
+(define (write-bbs bbs port)
+ (for-each
+ (lambda (bb)
+ (if (= (bb-lbl-num bb) (bbs-entry-lbl-num bbs))
+ (begin (display "**** Entry block:" port) (newline port)))
+ (write-bb bb port)
+ (newline port))
+ (queue->list (bbs-bb-queue bbs))))
+(define (virtual.dump proc port)
+ (let ((proc-seen (queue-empty)) (proc-left (queue-empty)))
+ (define (scan-opnd gvm-opnd)
+ (cond ((obj? gvm-opnd)
+ (let ((val (obj-val gvm-opnd)))
+ (if (and (proc-obj? val)
+ (proc-obj-code val)
+ (not (memq val (queue->list proc-seen))))
+ (begin
+ (queue-put! proc-seen val)
+ (queue-put! proc-left val)))))
+ ((clo? gvm-opnd) (scan-opnd (clo-base gvm-opnd)))))
+ (define (dump-proc p)
+ (define (scan-code code)
+ (let ((gvm-instr (code-gvm-instr code)))
+ (write-gvm-instr gvm-instr port)
+ (newline port)
+ (case (gvm-instr-type gvm-instr)
+ ((apply)
+ (for-each scan-opnd (apply-opnds gvm-instr))
+ (if (apply-loc gvm-instr) (scan-opnd (apply-loc gvm-instr))))
+ ((copy)
+ (scan-opnd (copy-opnd gvm-instr))
+ (scan-opnd (copy-loc gvm-instr)))
+ ((close)
+ (for-each
+ (lambda (parms)
+ (scan-opnd (closure-parms-loc parms))
+ (for-each scan-opnd (closure-parms-opnds parms)))
+ (close-parms gvm-instr)))
+ ((ifjump) (for-each scan-opnd (ifjump-opnds gvm-instr)))
+ ((jump) (scan-opnd (jump-opnd gvm-instr)))
+ (else '()))))
+ (if (proc-obj-primitive? p)
+ (display "**** #[primitive " port)
+ (display "**** #[procedure " port))
+ (display (proc-obj-name p) port)
+ (display "] =" port)
+ (newline port)
+ (let loop ((l (bbs->code-list (proc-obj-code p)))
+ (prev-filename "")
+ (prev-line 0))
+ (if (pair? l)
+ (let* ((code (car l))
+ (instr (code-gvm-instr code))
+ (src (comment-get (gvm-instr-comment instr) 'source))
+ (loc (and src (source-locat src)))
+ (filename
+ (if (and loc (eq? (vector-ref loc 0) 'file))
+ (vector-ref loc 1)
+ prev-filename))
+ (line (if (and loc (eq? (vector-ref loc 0) 'file))
+ (vector-ref loc 3)
+ prev-line)))
+ (if (or (not (string=? filename prev-filename))
+ (not (= line prev-line)))
+ (begin
+ (display "#line " port)
+ (display line port)
+ (if (not (string=? filename prev-filename))
+ (begin (display " " port) (write filename port)))
+ (newline port)))
+ (scan-code code)
+ (loop (cdr l) filename line))
+ (newline port))))
+ (scan-opnd (make-obj proc))
+ (let loop ()
+ (if (not (queue-empty? proc-left))
+ (begin (dump-proc (queue-get! proc-left)) (loop))))))
+(define (write-gvm-instr gvm-instr port)
+ (define (write-closure-parms parms)
+ (display " " port)
+ (let ((len (+ 1 (write-gvm-opnd (closure-parms-loc parms) port))))
+ (display " = (" port)
+ (let ((len (+ len (+ 4 (write-gvm-lbl (closure-parms-lbl parms) port)))))
+ (+ len
+ (write-terminated-opnd-list (closure-parms-opnds parms) port)))))
+ (define (write-terminated-opnd-list l port)
+ (let loop ((l l) (len 0))
+ (if (pair? l)
+ (let ((opnd (car l)))
+ (display " " port)
+ (loop (cdr l) (+ len (+ 1 (write-gvm-opnd opnd port)))))
+ (begin (display ")" port) (+ len 1)))))
+ (define (write-param-pattern gvm-instr port)
+ (let ((len (if (not (= (label-entry-min gvm-instr)
+ (label-entry-nb-parms gvm-instr)))
+ (let ((len (write-returning-len
+ (label-entry-min gvm-instr)
+ port)))
+ (display "-" port)
+ (+ len 1))
+ 0)))
+ (let ((len (+ len
+ (write-returning-len
+ (label-entry-nb-parms gvm-instr)
+ port))))
+ (if (label-entry-rest? gvm-instr)
+ (begin (display "+" port) (+ len 1))
+ len))))
+ (define (write-prim-applic prim opnds port)
+ (display "(" port)
+ (let ((len (+ 1 (display-returning-len (proc-obj-name prim) port))))
+ (+ len (write-terminated-opnd-list opnds port))))
+ (define (write-instr gvm-instr)
+ (case (gvm-instr-type gvm-instr)
+ ((label)
+ (let ((len (write-gvm-lbl (label-lbl-num gvm-instr) port)))
+ (display " " port)
+ (let ((len (+ len
+ (+ 1
+ (write-returning-len
+ (frame-size (gvm-instr-frame gvm-instr))
+ port)))))
+ (case (label-type gvm-instr)
+ ((simple) len)
+ ((entry)
+ (if (label-entry-closed? gvm-instr)
+ (begin
+ (display " closure-entry-point " port)
+ (+ len (+ 21 (write-param-pattern gvm-instr port))))
+ (begin
+ (display " entry-point " port)
+ (+ len (+ 13 (write-param-pattern gvm-instr port))))))
+ ((return) (display " return-point" port) (+ len 13))
+ ((task-entry) (display " task-entry-point" port) (+ len 17))
+ ((task-return) (display " task-return-point" port) (+ len 18))
+ (else
+ (compiler-internal-error
+ "write-gvm-instr, unknown label type"))))))
+ ((apply)
+ (display " " port)
+ (let ((len (+ 2
+ (if (apply-loc gvm-instr)
+ (let ((len (write-gvm-opnd
+ (apply-loc gvm-instr)
+ port)))
+ (display " = " port)
+ (+ len 3))
+ 0))))
+ (+ len
+ (write-prim-applic
+ (apply-prim gvm-instr)
+ (apply-opnds gvm-instr)
+ port))))
+ ((copy)
+ (display " " port)
+ (let ((len (+ 2 (write-gvm-opnd (copy-loc gvm-instr) port))))
+ (display " = " port)
+ (+ len (+ 3 (write-gvm-opnd (copy-opnd gvm-instr) port)))))
+ ((close)
+ (display " close" port)
+ (let ((len (+ 7 (write-closure-parms (car (close-parms gvm-instr))))))
+ (let loop ((l (cdr (close-parms gvm-instr))) (len len))
+ (if (pair? l)
+ (let ((x (car l)))
+ (display "," port)
+ (loop (cdr l) (+ len (+ 1 (write-closure-parms x)))))
+ len))))
+ ((ifjump)
+ (display " if " port)
+ (let ((len (+ 5
+ (write-prim-applic
+ (ifjump-test gvm-instr)
+ (ifjump-opnds gvm-instr)
+ port))))
+ (let ((len (+ len
+ (if (ifjump-poll? gvm-instr)
+ (begin (display " jump* " port) 7)
+ (begin (display " jump " port) 6)))))
+ (let ((len (+ len
+ (write-returning-len
+ (frame-size (gvm-instr-frame gvm-instr))
+ port))))
+ (display " " port)
+ (let ((len (+ len
+ (+ 1
+ (write-gvm-lbl (ifjump-true gvm-instr) port)))))
+ (display " else " port)
+ (+ len (+ 6 (write-gvm-lbl (ifjump-false gvm-instr) port))))))))
+ ((jump)
+ (display " " port)
+ (let ((len (+ 2
+ (if (jump-poll? gvm-instr)
+ (begin (display "jump* " port) 6)
+ (begin (display "jump " port) 5)))))
+ (let ((len (+ len
+ (write-returning-len
+ (frame-size (gvm-instr-frame gvm-instr))
+ port))))
+ (display " " port)
+ (let ((len (+ len
+ (+ 1 (write-gvm-opnd (jump-opnd gvm-instr) port)))))
+ (+ len
+ (if (jump-nb-args gvm-instr)
+ (begin
+ (display " " port)
+ (+ 1
+ (write-returning-len (jump-nb-args gvm-instr) port)))
+ 0))))))
+ (else
+ (compiler-internal-error
+ "write-gvm-instr, unknown 'gvm-instr':"
+ gvm-instr))))
+ (define (spaces n)
+ (if (> n 0)
+ (if (> n 7)
+ (begin (display " " port) (spaces (- n 8)))
+ (begin (display " " port) (spaces (- n 1))))))
+ (let ((len (write-instr gvm-instr)))
+ (spaces (- 40 len))
+ (display " " port)
+ (write-frame (gvm-instr-frame gvm-instr) port))
+ (let ((x (gvm-instr-comment gvm-instr)))
+ (if x
+ (let ((y (comment-get x 'text)))
+ (if y (begin (display " ; " port) (display y port)))))))
+(define (write-frame frame port)
+ (define (write-var var opnd sep)
+ (display sep port)
+ (write-gvm-opnd opnd port)
+ (if var
+ (begin
+ (display "=" port)
+ (cond ((eq? var closure-env-var)
+ (write (map (lambda (var) (var-name var))
+ (frame-closed frame))
+ port))
+ ((eq? var ret-var) (display "#" port))
+ ((temp-var? var) (display "." port))
+ (else (write (var-name var) port))))))
+ (define (live? var)
+ (let ((live (frame-live frame)))
+ (or (set-member? var live)
+ (and (eq? var closure-env-var)
+ (not (set-empty?
+ (set-intersection
+ live
+ (list->set (frame-closed frame)))))))))
+ (let loop1 ((i 1) (l (reverse (frame-slots frame))) (sep "; "))
+ (if (pair? l)
+ (let ((var (car l)))
+ (write-var (if (live? var) var #f) (make-stk i) sep)
+ (loop1 (+ i 1) (cdr l) " "))
+ (let loop2 ((i 0) (l (frame-regs frame)) (sep sep))
+ (if (pair? l)
+ (let ((var (car l)))
+ (if (live? var)
+ (begin
+ (write-var var (make-reg i) sep)
+ (loop2 (+ i 1) (cdr l) " "))
+ (loop2 (+ i 1) (cdr l) sep))))))))
+(define (write-gvm-opnd gvm-opnd port)
+ (define (write-opnd)
+ (cond ((reg? gvm-opnd)
+ (display "+" port)
+ (+ 1 (write-returning-len (reg-num gvm-opnd) port)))
+ ((stk? gvm-opnd)
+ (display "-" port)
+ (+ 1 (write-returning-len (stk-num gvm-opnd) port)))
+ ((glo? gvm-opnd) (write-returning-len (glo-name gvm-opnd) port))
+ ((clo? gvm-opnd)
+ (let ((len (write-gvm-opnd (clo-base gvm-opnd) port)))
+ (display "(" port)
+ (let ((len (+ len
+ (+ 1
+ (write-returning-len
+ (clo-index gvm-opnd)
+ port)))))
+ (display ")" port)
+ (+ len 1))))
+ ((lbl? gvm-opnd) (write-gvm-lbl (lbl-num gvm-opnd) port))
+ ((obj? gvm-opnd)
+ (display "'" port)
+ (+ (write-gvm-obj (obj-val gvm-opnd) port) 1))
+ (else
+ (compiler-internal-error
+ "write-gvm-opnd, unknown 'gvm-opnd':"
+ gvm-opnd))))
+ (write-opnd))
+(define (write-gvm-lbl lbl port)
+ (display "#" port)
+ (+ (write-returning-len lbl port) 1))
+(define (write-gvm-obj val port)
+ (cond ((false-object? val) (display "#f" port) 2)
+ ((undef-object? val) (display "#[undefined]" port) 12)
+ ((proc-obj? val)
+ (if (proc-obj-primitive? val)
+ (display "#[primitive " port)
+ (display "#[procedure " port))
+ (let ((len (display-returning-len (proc-obj-name val) port)))
+ (display "]" port)
+ (+ len 13)))
+ (else (write-returning-len val port))))
+(define (virtual.begin!)
+ (set! *opnd-table* (make-vector opnd-table-size))
+ (set! *opnd-table-alloc* 0)
+ '())
+(define (virtual.end!) (set! *opnd-table* '()) '())
+(define (make-target version name)
+ (define current-target-version 4)
+ (if (not (= version current-target-version))
+ (compiler-internal-error
+ "make-target, version of target package is not current"
+ name))
+ (let ((x (make-vector 11))) (vector-set! x 1 name) x))
+(define (target-name x) (vector-ref x 1))
+(define (target-begin! x) (vector-ref x 2))
+(define (target-begin!-set! x y) (vector-set! x 2 y))
+(define (target-end! x) (vector-ref x 3))
+(define (target-end!-set! x y) (vector-set! x 3 y))
+(define (target-dump x) (vector-ref x 4))
+(define (target-dump-set! x y) (vector-set! x 4 y))
+(define (target-nb-regs x) (vector-ref x 5))
+(define (target-nb-regs-set! x y) (vector-set! x 5 y))
+(define (target-prim-info x) (vector-ref x 6))
+(define (target-prim-info-set! x y) (vector-set! x 6 y))
+(define (target-label-info x) (vector-ref x 7))
+(define (target-label-info-set! x y) (vector-set! x 7 y))
+(define (target-jump-info x) (vector-ref x 8))
+(define (target-jump-info-set! x y) (vector-set! x 8 y))
+(define (target-proc-result x) (vector-ref x 9))
+(define (target-proc-result-set! x y) (vector-set! x 9 y))
+(define (target-task-return x) (vector-ref x 10))
+(define (target-task-return-set! x y) (vector-set! x 10 y))
+(define targets-loaded '())
+(define (get-target name)
+ (let ((x (assq name targets-loaded)))
+ (if x (cdr x) (compiler-error "Target package is not available" name))))
+(define (put-target targ)
+ (let* ((name (target-name targ)) (x (assq name targets-loaded)))
+ (if x
+ (set-cdr! x targ)
+ (set! targets-loaded (cons (cons name targ) targets-loaded)))
+ '()))
+(define (default-target)
+ (if (null? targets-loaded)
+ (compiler-error "No target package is available")
+ (car (car targets-loaded))))
+(define (select-target! name info-port)
+ (set! target (get-target name))
+ ((target-begin! target) info-port)
+ (set! target.dump (target-dump target))
+ (set! target.nb-regs (target-nb-regs target))
+ (set! target.prim-info (target-prim-info target))
+ (set! target.label-info (target-label-info target))
+ (set! target.jump-info (target-jump-info target))
+ (set! target.proc-result (target-proc-result target))
+ (set! target.task-return (target-task-return target))
+ (set! **not-proc-obj (target.prim-info **not-sym))
+ '())
+(define (unselect-target!) ((target-end! target)) '())
+(define target '())
+(define target.dump '())
+(define target.nb-regs '())
+(define target.prim-info '())
+(define target.label-info '())
+(define target.jump-info '())
+(define target.proc-result '())
+(define target.task-return '())
+(define **not-proc-obj '())
+(define (target.specialized-prim-info* name decl)
+ (let ((x (target.prim-info* name decl)))
+ (and x ((proc-obj-specialize x) decl))))
+(define (target.prim-info* name decl)
+ (and (if (standard-procedure name decl)
+ (standard-binding? name decl)
+ (extended-binding? name decl))
+ (target.prim-info name)))
+(define generic-sym (string->canonical-symbol "GENERIC"))
+(define fixnum-sym (string->canonical-symbol "FIXNUM"))
+(define flonum-sym (string->canonical-symbol "FLONUM"))
+(define-namable-decl generic-sym 'arith)
+(define-namable-decl fixnum-sym 'arith)
+(define-namable-decl flonum-sym 'arith)
+(define (arith-implementation name decls)
+ (declaration-value 'arith name generic-sym decls))
+(define (cf source target-name . opts)
+ (let* ((dest (file-root source))
+ (module-name (file-name dest))
+ (info-port (if (memq 'verbose opts) (current-output-port) #f))
+ (result (compile-program
+ (list **include-sym source)
+ (if target-name target-name (default-target))
+ opts
+ module-name
+ dest
+ info-port)))
+ (if (and info-port (not (eq? info-port (current-output-port))))
+ (close-output-port info-port))
+ result))
+(define (ce source target-name . opts)
+ (let* ((dest "program")
+ (module-name "program")
+ (info-port (if (memq 'verbose opts) (current-output-port) #f))
+ (result (compile-program
+ source
+ (if target-name target-name (default-target))
+ opts
+ module-name
+ dest
+ info-port)))
+ (if (and info-port (not (eq? info-port (current-output-port))))
+ (close-output-port info-port))
+ result))
+(define wrap-program #f)
+(set! wrap-program (lambda (program) program))
+(define (compile-program program target-name opts module-name dest info-port)
+ (define (compiler-body)
+ (if (not (valid-module-name? module-name))
+ (compiler-error
+ "Invalid characters in file name (must be a symbol with no \"#\")")
+ (begin
+ (ptree.begin! info-port)
+ (virtual.begin!)
+ (select-target! target-name info-port)
+ (parse-program
+ (list (expression->source (wrap-program program) #f))
+ (make-global-environment)
+ module-name
+ (lambda (lst env c-intf)
+ (let ((parsed-program
+ (map (lambda (x) (normalize-parse-tree (car x) (cdr x)))
+ lst)))
+ (if (memq 'expansion opts)
+ (let ((port (current-output-port)))
+ (display "Expansion:" port)
+ (newline port)
+ (let loop ((l parsed-program))
+ (if (pair? l)
+ (let ((ptree (car l)))
+ (pp-expression
+ (parse-tree->expression ptree)
+ port)
+ (loop (cdr l)))))
+ (newline port)))
+ (let ((module-init-proc
+ (compile-parsed-program
+ module-name
+ parsed-program
+ env
+ c-intf
+ info-port)))
+ (if (memq 'report opts) (generate-report env))
+ (if (memq 'gvm opts)
+ (let ((gvm-port
+ (open-output-file (string-append dest ".gvm"))))
+ (virtual.dump module-init-proc gvm-port)
+ (close-output-port gvm-port)))
+ (target.dump module-init-proc dest c-intf opts)
+ (dump-c-intf module-init-proc dest c-intf)))))
+ (unselect-target!)
+ (virtual.end!)
+ (ptree.end!)
+ #t)))
+ (let ((successful (with-exception-handling compiler-body)))
+ (if info-port
+ (if successful
+ (begin
+ (display "Compilation finished." info-port)
+ (newline info-port))
+ (begin
+ (display "Compilation terminated abnormally." info-port)
+ (newline info-port))))
+ successful))
+(define (valid-module-name? module-name)
+ (define (valid-char? c)
+ (and (not (memv c
+ '(#\#
+ #\;
+ #\(
+ #\)
+ #\space
+ #\[
+ #\]
+ #\{
+ #\}
+ #\"
+ #\'
+ #\`
+ #\,)))
+ (not (char-whitespace? c))))
+ (let ((n (string-length module-name)))
+ (and (> n 0)
+ (not (string=? module-name "."))
+ (not (string->number module-name 10))
+ (let loop ((i 0))
+ (if (< i n)
+ (if (valid-char? (string-ref module-name i)) (loop (+ i 1)) #f)
+ #t)))))
+(define (dump-c-intf module-init-proc dest c-intf)
+ (let ((decls (c-intf-decls c-intf))
+ (procs (c-intf-procs c-intf))
+ (inits (c-intf-inits c-intf)))
+ (if (or (not (null? decls)) (not (null? procs)) (not (null? inits)))
+ (let* ((module-name (proc-obj-name module-init-proc))
+ (filename (string-append dest ".c"))
+ (port (open-output-file filename)))
+ (display "/* File: \"" port)
+ (display filename port)
+ (display "\", C-interface file produced by Gambit " port)
+ (display compiler-version port)
+ (display " */" port)
+ (newline port)
+ (display "#define " port)
+ (display c-id-prefix port)
+ (display "MODULE_NAME \"" port)
+ (display module-name port)
+ (display "\"" port)
+ (newline port)
+ (display "#define " port)
+ (display c-id-prefix port)
+ (display "MODULE_LINKER " port)
+ (display c-id-prefix port)
+ (display (scheme-id->c-id module-name) port)
+ (newline port)
+ (display "#define " port)
+ (display c-id-prefix port)
+ (display "VERSION \"" port)
+ (display compiler-version port)
+ (display "\"" port)
+ (newline port)
+ (if (not (null? procs))
+ (begin
+ (display "#define " port)
+ (display c-id-prefix port)
+ (display "C_PRC_COUNT " port)
+ (display (length procs) port)
+ (newline port)))
+ (display "#include \"gambit.h\"" port)
+ (newline port)
+ (display c-id-prefix port)
+ (display "BEGIN_MODULE" port)
+ (newline port)
+ (for-each
+ (lambda (x)
+ (let ((scheme-name (vector-ref x 0)))
+ (display c-id-prefix port)
+ (display "SUPPLY_PRM(" port)
+ (display c-id-prefix port)
+ (display "P_" port)
+ (display (scheme-id->c-id scheme-name) port)
+ (display ")" port)
+ (newline port)))
+ procs)
+ (newline port)
+ (for-each (lambda (x) (display x port) (newline port)) decls)
+ (if (not (null? procs))
+ (begin
+ (for-each
+ (lambda (x)
+ (let ((scheme-name (vector-ref x 0))
+ (c-name (vector-ref x 1))
+ (arity (vector-ref x 2))
+ (def (vector-ref x 3)))
+ (display c-id-prefix port)
+ (display "BEGIN_C_COD(" port)
+ (display c-name port)
+ (display "," port)
+ (display c-id-prefix port)
+ (display "P_" port)
+ (display (scheme-id->c-id scheme-name) port)
+ (display "," port)
+ (display arity port)
+ (display ")" port)
+ (newline port)
+ (display "#undef ___ARG1" port)
+ (newline port)
+ (display "#define ___ARG1 ___R1" port)
+ (newline port)
+ (display "#undef ___ARG2" port)
+ (newline port)
+ (display "#define ___ARG2 ___R2" port)
+ (newline port)
+ (display "#undef ___ARG3" port)
+ (newline port)
+ (display "#define ___ARG3 ___R3" port)
+ (newline port)
+ (display "#undef ___RESULT" port)
+ (newline port)
+ (display "#define ___RESULT ___R1" port)
+ (newline port)
+ (display def port)
+ (display c-id-prefix port)
+ (display "END_C_COD" port)
+ (newline port)))
+ procs)
+ (newline port)
+ (display c-id-prefix port)
+ (display "BEGIN_C_PRC" port)
+ (newline port)
+ (let loop ((i 0) (lst procs))
+ (if (not (null? lst))
+ (let* ((x (car lst))
+ (scheme-name (vector-ref x 0))
+ (c-name (vector-ref x 1))
+ (arity (vector-ref x 2)))
+ (if (= i 0) (display " " port) (display "," port))
+ (display c-id-prefix port)
+ (display "DEF_C_PRC(" port)
+ (display c-name port)
+ (display "," port)
+ (display c-id-prefix port)
+ (display "P_" port)
+ (display (scheme-id->c-id scheme-name) port)
+ (display "," port)
+ (display arity port)
+ (display ")" port)
+ (newline port)
+ (loop (+ i 1) (cdr lst)))))
+ (display c-id-prefix port)
+ (display "END_C_PRC" port)
+ (newline port)))
+ (newline port)
+ (display c-id-prefix port)
+ (display "BEGIN_PRM" port)
+ (newline port)
+ (for-each (lambda (x) (display x port) (newline port)) inits)
+ (display c-id-prefix port)
+ (display "END_PRM" port)
+ (newline port)
+ (close-output-port port)))))
+(define (generate-report env)
+ (let ((vars (sort-variables (env-global-variables env)))
+ (decl (env-declarations env)))
+ (define (report title pred? vars wrote-something?)
+ (if (pair? vars)
+ (let ((var (car vars)))
+ (if (pred? var)
+ (begin
+ (if (not wrote-something?)
+ (begin (display " ") (display title) (newline)))
+ (let loop1 ((l (var-refs var)) (r? #f) (c? #f))
+ (if (pair? l)
+ (let* ((x (car l)) (y (node-parent x)))
+ (if (and y (app? y) (eq? x (app-oper y)))
+ (loop1 (cdr l) r? #t)
+ (loop1 (cdr l) #t c?)))
+ (let loop2 ((l (var-sets var)) (d? #f) (a? #f))
+ (if (pair? l)
+ (if (set? (car l))
+ (loop2 (cdr l) d? #t)
+ (loop2 (cdr l) #t a?))
+ (begin
+ (display " [")
+ (if d? (display "D") (display " "))
+ (if a? (display "A") (display " "))
+ (if r? (display "R") (display " "))
+ (if c? (display "C") (display " "))
+ (display "] ")
+ (display (var-name var))
+ (newline))))))
+ (report title pred? (cdr vars) #t))
+ (cons (car vars)
+ (report title pred? (cdr vars) wrote-something?))))
+ (begin (if wrote-something? (newline)) '())))
+ (display "Global variable usage:")
+ (newline)
+ (newline)
+ (report "OTHERS"
+ (lambda (x) #t)
+ (report "EXTENDED"
+ (lambda (x) (target.prim-info (var-name x)))
+ (report "STANDARD"
+ (lambda (x) (standard-procedure (var-name x) decl))
+ vars
+ #f)
+ #f)
+ #f)))
+(define (compile-parsed-program module-name program env c-intf info-port)
+ (if info-port (display "Compiling:" info-port))
+ (set! trace-indentation 0)
+ (set! *bbs* (make-bbs))
+ (set! *global-env* env)
+ (set! proc-queue '())
+ (set! constant-vars '())
+ (set! known-procs '())
+ (restore-context (make-context 0 '() (list ret-var) '() (entry-poll) #f))
+ (let* ((entry-lbl (bbs-new-lbl! *bbs*))
+ (body-lbl (bbs-new-lbl! *bbs*))
+ (frame (current-frame ret-var-set))
+ (comment (if (null? program) #f (source-comment (car program)))))
+ (bbs-entry-lbl-num-set! *bbs* entry-lbl)
+ (set! entry-bb
+ (make-bb (make-label-entry entry-lbl 0 0 #f #f frame comment) *bbs*))
+ (bb-put-branch! entry-bb (make-jump (make-lbl body-lbl) #f #f frame #f))
+ (set! *bb* (make-bb (make-label-simple body-lbl frame comment) *bbs*))
+ (let loop1 ((l (c-intf-procs c-intf)))
+ (if (not (null? l))
+ (let* ((x (car l))
+ (name (vector-ref x 0))
+ (sym (string->canonical-symbol name))
+ (var (env-lookup-global-var *global-env* sym)))
+ (add-constant-var
+ var
+ (make-obj (make-proc-obj name #t #f 0 #t '() '(#f))))
+ (loop1 (cdr l)))))
+ (let loop2 ((l program))
+ (if (not (null? l))
+ (let ((node (car l)))
+ (if (def? node)
+ (let* ((var (def-var node)) (val (global-val var)))
+ (if (and val (prc? val))
+ (add-constant-var
+ var
+ (make-obj
+ (make-proc-obj
+ (symbol->string (var-name var))
+ #t
+ #f
+ (call-pattern val)
+ #t
+ '()
+ '(#f)))))))
+ (loop2 (cdr l)))))
+ (let loop3 ((l program))
+ (if (null? l)
+ (let ((ret-opnd (var->opnd ret-var)))
+ (seal-bb #t 'return)
+ (dealloc-slots nb-slots)
+ (bb-put-branch!
+ *bb*
+ (make-jump ret-opnd #f #f (current-frame (set-empty)) #f)))
+ (let ((node (car l)))
+ (if (def? node)
+ (begin
+ (gen-define (def-var node) (def-val node) info-port)
+ (loop3 (cdr l)))
+ (if (null? (cdr l))
+ (gen-node node ret-var-set 'tail)
+ (begin
+ (gen-node node ret-var-set 'need)
+ (loop3 (cdr l))))))))
+ (let loop4 ()
+ (if (pair? proc-queue)
+ (let ((x (car proc-queue)))
+ (set! proc-queue (cdr proc-queue))
+ (gen-proc (car x) (cadr x) (caddr x) info-port)
+ (trace-unindent info-port)
+ (loop4))))
+ (if info-port (begin (newline info-port) (newline info-port)))
+ (bbs-purify! *bbs*)
+ (let ((proc (make-proc-obj
+ (string-append "#!" module-name)
+ #t
+ *bbs*
+ '(0)
+ #t
+ '()
+ '(#f))))
+ (set! *bb* '())
+ (set! *bbs* '())
+ (set! *global-env* '())
+ (set! proc-queue '())
+ (set! constant-vars '())
+ (set! known-procs '())
+ (clear-context)
+ proc)))
+(define *bb* '())
+(define *bbs* '())
+(define *global-env* '())
+(define proc-queue '())
+(define constant-vars '())
+(define known-procs '())
+(define trace-indentation '())
+(define (trace-indent info-port)
+ (set! trace-indentation (+ trace-indentation 1))
+ (if info-port
+ (begin
+ (newline info-port)
+ (let loop ((i trace-indentation))
+ (if (> i 0) (begin (display " " info-port) (loop (- i 1))))))))
+(define (trace-unindent info-port)
+ (set! trace-indentation (- trace-indentation 1)))
+(define (gen-define var node info-port)
+ (if (prc? node)
+ (let* ((p-bbs *bbs*)
+ (p-bb *bb*)
+ (p-proc-queue proc-queue)
+ (p-known-procs known-procs)
+ (p-context (current-context))
+ (bbs (make-bbs))
+ (lbl1 (bbs-new-lbl! bbs))
+ (lbl2 (bbs-new-lbl! bbs))
+ (context (entry-context node '()))
+ (frame (context->frame
+ context
+ (set-union (free-variables (prc-body node)) ret-var-set)))
+ (bb1 (make-bb (make-label-entry
+ lbl1
+ (length (prc-parms node))
+ (prc-min node)
+ (prc-rest node)
+ #f
+ frame
+ (source-comment node))
+ bbs))
+ (bb2 (make-bb (make-label-simple lbl2 frame (source-comment node))
+ bbs)))
+ (define (do-body)
+ (gen-proc node bb2 context info-port)
+ (let loop ()
+ (if (pair? proc-queue)
+ (let ((x (car proc-queue)))
+ (set! proc-queue (cdr proc-queue))
+ (gen-proc (car x) (cadr x) (caddr x) info-port)
+ (trace-unindent info-port)
+ (loop))))
+ (trace-unindent info-port)
+ (bbs-purify! *bbs*))
+ (context-entry-bb-set! context bb1)
+ (bbs-entry-lbl-num-set! bbs lbl1)
+ (bb-put-branch! bb1 (make-jump (make-lbl lbl2) #f #f frame #f))
+ (set! *bbs* bbs)
+ (set! proc-queue '())
+ (set! known-procs '())
+ (if (constant-var? var)
+ (let-constant-var
+ var
+ (make-lbl lbl1)
+ (lambda () (add-known-proc lbl1 node) (do-body)))
+ (do-body))
+ (set! *bbs* p-bbs)
+ (set! *bb* p-bb)
+ (set! proc-queue p-proc-queue)
+ (set! known-procs p-known-procs)
+ (restore-context p-context)
+ (let* ((x (assq var constant-vars))
+ (proc (if x
+ (let ((p (cdr x)))
+ (proc-obj-code-set! (obj-val p) bbs)
+ p)
+ (make-obj
+ (make-proc-obj
+ (symbol->string (var-name var))
+ #f
+ bbs
+ (call-pattern node)
+ #t
+ '()
+ '(#f))))))
+ (put-copy
+ proc
+ (make-glo (var-name var))
+ #f
+ ret-var-set
+ (source-comment node))))
+ (put-copy
+ (gen-node node ret-var-set 'need)
+ (make-glo (var-name var))
+ #f
+ ret-var-set
+ (source-comment node))))
+(define (call-pattern node)
+ (make-pattern (prc-min node) (length (prc-parms node)) (prc-rest node)))
+(define (make-context nb-slots slots regs closed poll entry-bb)
+ (vector nb-slots slots regs closed poll entry-bb))
+(define (context-nb-slots x) (vector-ref x 0))
+(define (context-slots x) (vector-ref x 1))
+(define (context-regs x) (vector-ref x 2))
+(define (context-closed x) (vector-ref x 3))
+(define (context-poll x) (vector-ref x 4))
+(define (context-entry-bb x) (vector-ref x 5))
+(define (context-entry-bb-set! x y) (vector-set! x 5 y))
+(define nb-slots '())
+(define slots '())
+(define regs '())
+(define closed '())
+(define poll '())
+(define entry-bb '())
+(define (restore-context context)
+ (set! nb-slots (context-nb-slots context))
+ (set! slots (context-slots context))
+ (set! regs (context-regs context))
+ (set! closed (context-closed context))
+ (set! poll (context-poll context))
+ (set! entry-bb (context-entry-bb context)))
+(define (clear-context)
+ (restore-context (make-context '() '() '() '() '() '())))
+(define (current-context)
+ (make-context nb-slots slots regs closed poll entry-bb))
+(define (current-frame live) (make-frame nb-slots slots regs closed live))
+(define (context->frame context live)
+ (make-frame
+ (context-nb-slots context)
+ (context-slots context)
+ (context-regs context)
+ (context-closed context)
+ live))
+(define (make-poll since-entry? delta) (cons since-entry? delta))
+(define (poll-since-entry? x) (car x))
+(define (poll-delta x) (cdr x))
+(define (entry-poll) (make-poll #f (- poll-period poll-head)))
+(define (return-poll poll)
+ (let ((delta (poll-delta poll)))
+ (make-poll (poll-since-entry? poll) (+ poll-head (max delta poll-tail)))))
+(define (poll-merge poll other-poll)
+ (make-poll
+ (or (poll-since-entry? poll) (poll-since-entry? other-poll))
+ (max (poll-delta poll) (poll-delta other-poll))))
+(define poll-period #f)
+(set! poll-period 90)
+(define poll-head #f)
+(set! poll-head 15)
+(define poll-tail #f)
+(set! poll-tail 15)
+(define (entry-context proc closed)
+ (define (empty-vars-list n)
+ (if (> n 0) (cons empty-var (empty-vars-list (- n 1))) '()))
+ (let* ((parms (prc-parms proc))
+ (pc (target.label-info
+ (prc-min proc)
+ (length parms)
+ (prc-rest proc)
+ (not (null? closed))))
+ (fs (pcontext-fs pc))
+ (slots-list (empty-vars-list fs))
+ (regs-list (empty-vars-list target.nb-regs)))
+ (define (assign-var-to-loc var loc)
+ (let ((x (cond ((reg? loc)
+ (let ((i (reg-num loc)))
+ (if (<= i target.nb-regs)
+ (nth-after regs-list i)
+ (compiler-internal-error
+ "entry-context, reg out of bound in back-end's pcontext"))))
+ ((stk? loc)
+ (let ((i (stk-num loc)))
+ (if (<= i fs)
+ (nth-after slots-list (- fs i))
+ (compiler-internal-error
+ "entry-context, stk out of bound in back-end's pcontext"))))
+ (else
+ (compiler-internal-error
+ "entry-context, loc other than reg or stk in back-end's pcontext")))))
+ (if (eq? (car x) empty-var)
+ (set-car! x var)
+ (compiler-internal-error
+ "entry-context, duplicate location in back-end's pcontext"))))
+ (let loop ((l (pcontext-map pc)))
+ (if (not (null? l))
+ (let* ((couple (car l)) (name (car couple)) (loc (cdr couple)))
+ (cond ((eq? name 'return) (assign-var-to-loc ret-var loc))
+ ((eq? name 'closure-env)
+ (assign-var-to-loc closure-env-var loc))
+ (else (assign-var-to-loc (list-ref parms (- name 1)) loc)))
+ (loop (cdr l)))))
+ (make-context fs slots-list regs-list closed (entry-poll) #f)))
+(define (get-var opnd)
+ (cond ((glo? opnd) (env-lookup-global-var *global-env* (glo-name opnd)))
+ ((reg? opnd) (list-ref regs (reg-num opnd)))
+ ((stk? opnd) (list-ref slots (- nb-slots (stk-num opnd))))
+ (else
+ (compiler-internal-error
+ "get-var, location must be global, register or stack slot"))))
+(define (put-var opnd new)
+ (define (put-v opnd new)
+ (cond ((reg? opnd) (set! regs (replace-nth regs (reg-num opnd) new)))
+ ((stk? opnd)
+ (set! slots (replace-nth slots (- nb-slots (stk-num opnd)) new)))
+ (else
+ (compiler-internal-error
+ "put-var, location must be register or stack slot, for var:"
+ (var-name new)))))
+ (if (eq? new ret-var)
+ (let ((x (var->opnd ret-var))) (and x (put-v x empty-var))))
+ (put-v opnd new))
+(define (flush-regs) (set! regs '()))
+(define (push-slot)
+ (set! nb-slots (+ nb-slots 1))
+ (set! slots (cons empty-var slots)))
+(define (dealloc-slots n)
+ (set! nb-slots (- nb-slots n))
+ (set! slots (nth-after slots n)))
+(define (pop-slot) (dealloc-slots 1))
+(define (replace-nth l i v)
+ (if (null? l)
+ (if (= i 0) (list v) (cons empty-var (replace-nth l (- i 1) v)))
+ (if (= i 0)
+ (cons v (cdr l))
+ (cons (car l) (replace-nth (cdr l) (- i 1) v)))))
+(define (live-vars live)
+ (if (not (set-empty? (set-intersection live (list->set closed))))
+ (set-adjoin live closure-env-var)
+ live))
+(define (dead-slots live)
+ (let ((live-v (live-vars live)))
+ (define (loop s l i)
+ (cond ((null? l) (list->set (reverse s)))
+ ((set-member? (car l) live-v) (loop s (cdr l) (- i 1)))
+ (else (loop (cons i s) (cdr l) (- i 1)))))
+ (loop '() slots nb-slots)))
+(define (live-slots live)
+ (let ((live-v (live-vars live)))
+ (define (loop s l i)
+ (cond ((null? l) (list->set (reverse s)))
+ ((set-member? (car l) live-v) (loop (cons i s) (cdr l) (- i 1)))
+ (else (loop s (cdr l) (- i 1)))))
+ (loop '() slots nb-slots)))
+(define (dead-regs live)
+ (let ((live-v (live-vars live)))
+ (define (loop s l i)
+ (cond ((>= i target.nb-regs) (list->set (reverse s)))
+ ((null? l) (loop (cons i s) l (+ i 1)))
+ ((and (set-member? (car l) live-v) (not (memq (car l) slots)))
+ (loop s (cdr l) (+ i 1)))
+ (else (loop (cons i s) (cdr l) (+ i 1)))))
+ (loop '() regs 0)))
+(define (live-regs live)
+ (let ((live-v (live-vars live)))
+ (define (loop s l i)
+ (cond ((null? l) (list->set (reverse s)))
+ ((and (set-member? (car l) live-v) (not (memq (car l) slots)))
+ (loop (cons i s) (cdr l) (+ i 1)))
+ (else (loop s (cdr l) (+ i 1)))))
+ (loop '() regs 0)))
+(define (lowest-dead-slot live)
+ (make-stk (or (lowest (dead-slots live)) (+ nb-slots 1))))
+(define (highest-live-slot live) (make-stk (or (highest (live-slots live)) 0)))
+(define (lowest-dead-reg live)
+ (let ((x (lowest (set-remove (dead-regs live) 0)))) (if x (make-reg x) #f)))
+(define (highest-dead-reg live)
+ (let ((x (highest (dead-regs live)))) (if x (make-reg x) #f)))
+(define (highest set) (if (set-empty? set) #f (apply max (set->list set))))
+(define (lowest set) (if (set-empty? set) #f (apply min (set->list set))))
+(define (above set n) (set-keep (lambda (x) (> x n)) set))
+(define (below set n) (set-keep (lambda (x) (< x n)) set))
+(define (var->opnd var)
+ (let ((x (assq var constant-vars)))
+ (if x
+ (cdr x)
+ (if (global? var)
+ (make-glo (var-name var))
+ (let ((n (pos-in-list var regs)))
+ (if n
+ (make-reg n)
+ (let ((n (pos-in-list var slots)))
+ (if n
+ (make-stk (- nb-slots n))
+ (let ((n (pos-in-list var closed)))
+ (if n
+ (make-clo (var->opnd closure-env-var) (+ n 1))
+ (compiler-internal-error
+ "var->opnd, variable is not accessible:"
+ (var-name var))))))))))))
+(define (source-comment node)
+ (let ((x (make-comment))) (comment-put! x 'source (node-source node)) x))
+(define (sort-variables lst)
+ (sort-list
+ lst
+ (lambda (x y)
+ (string<? (symbol->string (var-name x)) (symbol->string (var-name y))))))
+(define (add-constant-var var opnd)
+ (set! constant-vars (cons (cons var opnd) constant-vars)))
+(define (let-constant-var var opnd thunk)
+ (let* ((x (assq var constant-vars)) (temp (cdr x)))
+ (set-cdr! x opnd)
+ (thunk)
+ (set-cdr! x temp)))
+(define (constant-var? var) (assq var constant-vars))
+(define (not-constant-var? var) (not (constant-var? var)))
+(define (add-known-proc label proc)
+ (set! known-procs (cons (cons label proc) known-procs)))
+(define (gen-proc proc bb context info-port)
+ (trace-indent info-port)
+ (if info-port
+ (if (prc-name proc)
+ (display (prc-name proc) info-port)
+ (display "\"unknown\"" info-port)))
+ (let ((lbl (bb-lbl-num bb))
+ (live (set-union (free-variables (prc-body proc)) ret-var-set)))
+ (set! *bb* bb)
+ (restore-context context)
+ (gen-node (prc-body proc) ret-var-set 'tail)))
+(define (schedule-gen-proc proc closed-list)
+ (let* ((lbl1 (bbs-new-lbl! *bbs*))
+ (lbl2 (bbs-new-lbl! *bbs*))
+ (context (entry-context proc closed-list))
+ (frame (context->frame
+ context
+ (set-union (free-variables (prc-body proc)) ret-var-set)))
+ (bb1 (make-bb (make-label-entry
+ lbl1
+ (length (prc-parms proc))
+ (prc-min proc)
+ (prc-rest proc)
+ (not (null? closed-list))
+ frame
+ (source-comment proc))
+ *bbs*))
+ (bb2 (make-bb (make-label-simple lbl2 frame (source-comment proc))
+ *bbs*)))
+ (context-entry-bb-set! context bb1)
+ (bb-put-branch! bb1 (make-jump (make-lbl lbl2) #f #f frame #f))
+ (set! proc-queue (cons (list proc bb2 context) proc-queue))
+ (make-lbl lbl1)))
+(define (gen-node node live why)
+ (cond ((cst? node) (gen-return (make-obj (cst-val node)) why node))
+ ((ref? node)
+ (let* ((var (ref-var node)) (name (var-name var)))
+ (gen-return
+ (cond ((eq? why 'side) (make-obj undef-object))
+ ((global? var)
+ (let ((prim (target.prim-info* name (node-decl node))))
+ (if prim (make-obj prim) (var->opnd var))))
+ (else (var->opnd var)))
+ why
+ node)))
+ ((set? node)
+ (let* ((src (gen-node
+ (set-val node)
+ (set-adjoin live (set-var node))
+ 'keep))
+ (dst (var->opnd (set-var node))))
+ (put-copy src dst #f live (source-comment node))
+ (gen-return (make-obj undef-object) why node)))
+ ((def? node)
+ (compiler-internal-error
+ "gen-node, 'def' node not at root of parse tree"))
+ ((tst? node) (gen-tst node live why))
+ ((conj? node) (gen-conj/disj node live why))
+ ((disj? node) (gen-conj/disj node live why))
+ ((prc? node)
+ (let* ((closed (not-constant-closed-vars node))
+ (closed-list (sort-variables (set->list closed)))
+ (proc-lbl (schedule-gen-proc node closed-list)))
+ (let ((opnd (if (null? closed-list)
+ (begin
+ (add-known-proc (lbl-num proc-lbl) node)
+ proc-lbl)
+ (begin
+ (dealloc-slots
+ (- nb-slots
+ (stk-num (highest-live-slot
+ (set-union closed live)))))
+ (push-slot)
+ (let ((slot (make-stk nb-slots))
+ (var (make-temp-var 'closure)))
+ (put-var slot var)
+ (bb-put-non-branch!
+ *bb*
+ (make-close
+ (list (make-closure-parms
+ slot
+ (lbl-num proc-lbl)
+ (map var->opnd closed-list)))
+ (current-frame (set-adjoin live var))
+ (source-comment node)))
+ slot)))))
+ (gen-return opnd why node))))
+ ((app? node) (gen-call node live why))
+ ((fut? node) (gen-fut node live why))
+ (else
+ (compiler-internal-error
+ "gen-node, unknown parse tree node type:"
+ node))))
+(define (gen-return opnd why node)
+ (cond ((eq? why 'tail)
+ (let ((var (make-temp-var 'result)))
+ (put-copy
+ opnd
+ target.proc-result
+ var
+ ret-var-set
+ (source-comment node))
+ (let ((ret-opnd (var->opnd ret-var)))
+ (seal-bb (intrs-enabled? (node-decl node)) 'return)
+ (dealloc-slots nb-slots)
+ (bb-put-branch!
+ *bb*
+ (make-jump
+ ret-opnd
+ #f
+ #f
+ (current-frame (set-singleton var))
+ #f)))))
+ (else opnd)))
+(define (not-constant-closed-vars val)
+ (set-keep not-constant-var? (free-variables val)))
+(define (predicate node live cont)
+ (define (cont* true-lbl false-lbl) (cont false-lbl true-lbl))
+ (define (generic-true-test)
+ (predicate-test node live **not-proc-obj '0 (list node) cont*))
+ (cond ((or (conj? node) (disj? node)) (predicate-conj/disj node live cont))
+ ((app? node)
+ (let ((proc (node->proc (app-oper node))))
+ (if proc
+ (let ((spec (specialize-for-call proc (node-decl node))))
+ (if (and (proc-obj-test spec)
+ (nb-args-conforms?
+ (length (app-args node))
+ (proc-obj-call-pat spec)))
+ (if (eq? spec **not-proc-obj)
+ (predicate (car (app-args node)) live cont*)
+ (predicate-test
+ node
+ live
+ spec
+ (proc-obj-strict-pat proc)
+ (app-args node)
+ cont))
+ (generic-true-test)))
+ (generic-true-test))))
+ (else (generic-true-test))))
+(define (predicate-conj/disj node live cont)
+ (let* ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
+ (alt (if (conj? node) (conj-alt node) (disj-alt node)))
+ (alt-live (set-union live (free-variables alt))))
+ (predicate
+ pre
+ alt-live
+ (lambda (true-lbl false-lbl)
+ (let ((pre-context (current-context)))
+ (set! *bb*
+ (make-bb (make-label-simple
+ (if (conj? node) true-lbl false-lbl)
+ (current-frame alt-live)
+ (source-comment alt))
+ *bbs*))
+ (predicate
+ alt
+ live
+ (lambda (true-lbl2 false-lbl2)
+ (let ((alt-context (current-context)))
+ (restore-context pre-context)
+ (set! *bb*
+ (make-bb (make-label-simple
+ (if (conj? node) false-lbl true-lbl)
+ (current-frame live)
+ (source-comment alt))
+ *bbs*))
+ (merge-contexts-and-seal-bb
+ alt-context
+ live
+ (intrs-enabled? (node-decl node))
+ 'internal
+ (source-comment node))
+ (bb-put-branch!
+ *bb*
+ (make-jump
+ (make-lbl (if (conj? node) false-lbl2 true-lbl2))
+ #f
+ #f
+ (current-frame live)
+ #f))
+ (cont true-lbl2 false-lbl2)))))))))
+(define (predicate-test node live test strict-pat args cont)
+ (let loop ((args* args) (liv live) (vars* '()))
+ (if (not (null? args*))
+ (let* ((needed (vals-live-vars liv (cdr args*)))
+ (var (save-var
+ (gen-node (car args*) needed 'need)
+ (make-temp-var 'predicate)
+ needed
+ (source-comment (car args*)))))
+ (loop (cdr args*) (set-adjoin liv var) (cons var vars*)))
+ (let* ((true-lbl (bbs-new-lbl! *bbs*))
+ (false-lbl (bbs-new-lbl! *bbs*)))
+ (seal-bb (intrs-enabled? (node-decl node)) 'internal)
+ (bb-put-branch!
+ *bb*
+ (make-ifjump
+ test
+ (map var->opnd (reverse vars*))
+ true-lbl
+ false-lbl
+ #f
+ (current-frame live)
+ (source-comment node)))
+ (cont true-lbl false-lbl)))))
+(define (gen-tst node live why)
+ (let ((pre (tst-pre node)) (con (tst-con node)) (alt (tst-alt node)))
+ (predicate
+ pre
+ (set-union live (free-variables con) (free-variables alt))
+ (lambda (true-lbl false-lbl)
+ (let ((pre-context (current-context))
+ (true-bb (make-bb (make-label-simple
+ true-lbl
+ (current-frame
+ (set-union live (free-variables con)))
+ (source-comment con))
+ *bbs*))
+ (false-bb
+ (make-bb (make-label-simple
+ false-lbl
+ (current-frame (set-union live (free-variables alt)))
+ (source-comment alt))
+ *bbs*)))
+ (set! *bb* true-bb)
+ (let ((con-opnd (gen-node con live why)))
+ (if (eq? why 'tail)
+ (begin
+ (restore-context pre-context)
+ (set! *bb* false-bb)
+ (gen-node alt live why))
+ (let* ((result-var (make-temp-var 'result))
+ (live-after (set-adjoin live result-var)))
+ (save-opnd-to-reg
+ con-opnd
+ target.proc-result
+ result-var
+ live
+ (source-comment con))
+ (let ((con-context (current-context)) (con-bb *bb*))
+ (restore-context pre-context)
+ (set! *bb* false-bb)
+ (save-opnd-to-reg
+ (gen-node alt live why)
+ target.proc-result
+ result-var
+ live
+ (source-comment alt))
+ (let ((next-lbl (bbs-new-lbl! *bbs*)) (alt-bb *bb*))
+ (if (> (context-nb-slots con-context) nb-slots)
+ (begin
+ (seal-bb (intrs-enabled? (node-decl node))
+ 'internal)
+ (let ((alt-context (current-context)))
+ (restore-context con-context)
+ (set! *bb* con-bb)
+ (merge-contexts-and-seal-bb
+ alt-context
+ live-after
+ (intrs-enabled? (node-decl node))
+ 'internal
+ (source-comment node))))
+ (let ((alt-context (current-context)))
+ (restore-context con-context)
+ (set! *bb* con-bb)
+ (seal-bb (intrs-enabled? (node-decl node))
+ 'internal)
+ (let ((con-context* (current-context)))
+ (restore-context alt-context)
+ (set! *bb* alt-bb)
+ (merge-contexts-and-seal-bb
+ con-context*
+ live-after
+ (intrs-enabled? (node-decl node))
+ 'internal
+ (source-comment node)))))
+ (let ((frame (current-frame live-after)))
+ (bb-put-branch!
+ con-bb
+ (make-jump (make-lbl next-lbl) #f #f frame #f))
+ (bb-put-branch!
+ alt-bb
+ (make-jump (make-lbl next-lbl) #f #f frame #f))
+ (set! *bb*
+ (make-bb (make-label-simple
+ next-lbl
+ frame
+ (source-comment node))
+ *bbs*))
+ target.proc-result)))))))))))
+(define (nb-args-conforms? n call-pat) (pattern-member? n call-pat))
+(define (merge-contexts-and-seal-bb other-context live poll? where comment)
+ (let ((live-v (live-vars live))
+ (other-nb-slots (context-nb-slots other-context))
+ (other-regs (context-regs other-context))
+ (other-slots (context-slots other-context))
+ (other-poll (context-poll other-context))
+ (other-entry-bb (context-entry-bb other-context)))
+ (let loop1 ((i (- target.nb-regs 1)))
+ (if (>= i 0)
+ (let ((other-var (reg->var other-regs i)) (var (reg->var regs i)))
+ (if (and (not (eq? var other-var)) (set-member? other-var live-v))
+ (let ((r (make-reg i)))
+ (put-var r empty-var)
+ (if (not (or (not (set-member? var live-v))
+ (memq var regs)
+ (memq var slots)))
+ (let ((top (make-stk (+ nb-slots 1))))
+ (put-copy r top var live-v comment)))
+ (put-copy (var->opnd other-var) r other-var live-v comment)))
+ (loop1 (- i 1)))))
+ (let loop2 ((i 1))
+ (if (<= i other-nb-slots)
+ (let ((other-var (stk->var other-slots i)) (var (stk->var slots i)))
+ (if (and (not (eq? var other-var)) (set-member? other-var live-v))
+ (let ((s (make-stk i)))
+ (if (<= i nb-slots) (put-var s empty-var))
+ (if (not (or (not (set-member? var live-v))
+ (memq var regs)
+ (memq var slots)))
+ (let ((top (make-stk (+ nb-slots 1))))
+ (put-copy s top var live-v comment)))
+ (put-copy (var->opnd other-var) s other-var live-v comment))
+ (if (> i nb-slots)
+ (let ((top (make-stk (+ nb-slots 1))))
+ (put-copy
+ (make-obj undef-object)
+ top
+ empty-var
+ live-v
+ comment))))
+ (loop2 (+ i 1)))))
+ (dealloc-slots (- nb-slots other-nb-slots))
+ (let loop3 ((i (- target.nb-regs 1)))
+ (if (>= i 0)
+ (let ((other-var (reg->var other-regs i)) (var (reg->var regs i)))
+ (if (not (eq? var other-var)) (put-var (make-reg i) empty-var))
+ (loop3 (- i 1)))))
+ (let loop4 ((i 1))
+ (if (<= i other-nb-slots)
+ (let ((other-var (stk->var other-slots i)) (var (stk->var slots i)))
+ (if (not (eq? var other-var)) (put-var (make-stk i) empty-var))
+ (loop4 (+ i 1)))))
+ (seal-bb poll? where)
+ (set! poll (poll-merge poll other-poll))
+ (if (not (eq? entry-bb other-entry-bb))
+ (compiler-internal-error
+ "merge-contexts-and-seal-bb, entry-bb's do not agree"))))
+(define (seal-bb poll? where)
+ (define (my-last-pair l) (if (pair? (cdr l)) (my-last-pair (cdr l)) l))
+ (define (poll-at split-point)
+ (let loop ((i 0) (l1 (bb-non-branch-instrs *bb*)) (l2 '()))
+ (if (< i split-point)
+ (loop (+ i 1) (cdr l1) (cons (car l1) l2))
+ (let* ((label-instr (bb-label-instr *bb*))
+ (non-branch-instrs1 (reverse l2))
+ (non-branch-instrs2 l1)
+ (frame (gvm-instr-frame
+ (car (my-last-pair
+ (cons label-instr non-branch-instrs1)))))
+ (prec-bb (make-bb label-instr *bbs*))
+ (new-lbl (bbs-new-lbl! *bbs*)))
+ (bb-non-branch-instrs-set! prec-bb non-branch-instrs1)
+ (bb-put-branch!
+ prec-bb
+ (make-jump (make-lbl new-lbl) #f #t frame #f))
+ (bb-label-instr-set! *bb* (make-label-simple new-lbl frame #f))
+ (bb-non-branch-instrs-set! *bb* non-branch-instrs2)
+ (set! poll (make-poll #t 0))))))
+ (define (poll-at-end) (poll-at (length (bb-non-branch-instrs *bb*))))
+ (define (impose-polling-constraints)
+ (let ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
+ (delta (poll-delta poll)))
+ (if (> (+ delta n) poll-period)
+ (begin
+ (poll-at (max (- poll-period delta) 0))
+ (impose-polling-constraints)))))
+ (if poll? (impose-polling-constraints))
+ (let* ((n (+ (length (bb-non-branch-instrs *bb*)) 1))
+ (delta (+ (poll-delta poll) n))
+ (since-entry? (poll-since-entry? poll)))
+ (if (and poll?
+ (case where
+ ((call) (> delta (- poll-period poll-head)))
+ ((tail-call) (> delta poll-tail))
+ ((return) (and since-entry? (> delta (+ poll-head poll-tail))))
+ ((internal) #f)
+ (else
+ (compiler-internal-error "seal-bb, unknown 'where':" where))))
+ (poll-at-end)
+ (set! poll (make-poll since-entry? delta)))))
+(define (reg->var regs i)
+ (cond ((null? regs) '())
+ ((> i 0) (reg->var (cdr regs) (- i 1)))
+ (else (car regs))))
+(define (stk->var slots i)
+ (let ((j (- (length slots) i))) (if (< j 0) '() (list-ref slots j))))
+(define (gen-conj/disj node live why)
+ (let ((pre (if (conj? node) (conj-pre node) (disj-pre node)))
+ (alt (if (conj? node) (conj-alt node) (disj-alt node))))
+ (let ((needed (set-union live (free-variables alt)))
+ (bool? (boolean-value? pre))
+ (predicate-var (make-temp-var 'predicate)))
+ (define (general-predicate node live cont)
+ (let* ((con-lbl (bbs-new-lbl! *bbs*)) (alt-lbl (bbs-new-lbl! *bbs*)))
+ (save-opnd-to-reg
+ (gen-node pre live 'need)
+ target.proc-result
+ predicate-var
+ live
+ (source-comment pre))
+ (seal-bb (intrs-enabled? (node-decl node)) 'internal)
+ (bb-put-branch!
+ *bb*
+ (make-ifjump
+ **not-proc-obj
+ (list target.proc-result)
+ alt-lbl
+ con-lbl
+ #f
+ (current-frame (set-adjoin live predicate-var))
+ (source-comment node)))
+ (cont con-lbl alt-lbl)))
+ (define (alternative con-lbl alt-lbl)
+ (let* ((pre-context (current-context))
+ (result-var (make-temp-var 'result))
+ (con-live (if bool? live (set-adjoin live predicate-var)))
+ (alt-live (set-union live (free-variables alt)))
+ (con-bb (make-bb (make-label-simple
+ con-lbl
+ (current-frame con-live)
+ (source-comment alt))
+ *bbs*))
+ (alt-bb (make-bb (make-label-simple
+ alt-lbl
+ (current-frame alt-live)
+ (source-comment alt))
+ *bbs*)))
+ (if bool?
+ (begin
+ (set! *bb* con-bb)
+ (save-opnd-to-reg
+ (make-obj (if (conj? node) false-object #t))
+ target.proc-result
+ result-var
+ live
+ (source-comment node)))
+ (put-var (var->opnd predicate-var) result-var))
+ (let ((con-context (current-context)))
+ (set! *bb* alt-bb)
+ (restore-context pre-context)
+ (let ((alt-opnd (gen-node alt live why)))
+ (if (eq? why 'tail)
+ (begin
+ (restore-context con-context)
+ (set! *bb* con-bb)
+ (let ((ret-opnd (var->opnd ret-var))
+ (result-set (set-singleton result-var)))
+ (seal-bb (intrs-enabled? (node-decl node)) 'return)
+ (dealloc-slots nb-slots)
+ (bb-put-branch!
+ *bb*
+ (make-jump
+ ret-opnd
+ #f
+ #f
+ (current-frame result-set)
+ #f))))
+ (let ((alt-context* (current-context)) (alt-bb* *bb*))
+ (restore-context con-context)
+ (set! *bb* con-bb)
+ (seal-bb (intrs-enabled? (node-decl node)) 'internal)
+ (let ((con-context* (current-context))
+ (next-lbl (bbs-new-lbl! *bbs*)))
+ (restore-context alt-context*)
+ (set! *bb* alt-bb*)
+ (save-opnd-to-reg
+ alt-opnd
+ target.proc-result
+ result-var
+ live
+ (source-comment alt))
+ (merge-contexts-and-seal-bb
+ con-context*
+ (set-adjoin live result-var)
+ (intrs-enabled? (node-decl node))
+ 'internal
+ (source-comment node))
+ (let ((frame (current-frame
+ (set-adjoin live result-var))))
+ (bb-put-branch!
+ *bb*
+ (make-jump (make-lbl next-lbl) #f #f frame #f))
+ (bb-put-branch!
+ con-bb
+ (make-jump (make-lbl next-lbl) #f #f frame #f))
+ (set! *bb*
+ (make-bb (make-label-simple
+ next-lbl
+ frame
+ (source-comment node))
+ *bbs*))
+ target.proc-result))))))))
+ ((if bool? predicate general-predicate)
+ pre
+ needed
+ (lambda (true-lbl false-lbl)
+ (if (conj? node)
+ (alternative false-lbl true-lbl)
+ (alternative true-lbl false-lbl)))))))
+(define (gen-call node live why)
+ (let* ((oper (app-oper node)) (args (app-args node)) (nb-args (length args)))
+ (if (and (prc? oper)
+ (not (prc-rest oper))
+ (= (length (prc-parms oper)) nb-args))
+ (gen-let (prc-parms oper) args (prc-body oper) live why)
+ (if (inlinable-app? node)
+ (let ((eval-order (arg-eval-order #f args))
+ (vars (map (lambda (x) (cons x #f)) args)))
+ (let loop ((l eval-order) (liv live))
+ (if (not (null? l))
+ (let* ((needed (vals-live-vars liv (map car (cdr l))))
+ (arg (car (car l)))
+ (pos (cdr (car l)))
+ (var (save-var
+ (gen-node arg needed 'need)
+ (make-temp-var pos)
+ needed
+ (source-comment arg))))
+ (set-cdr! (assq arg vars) var)
+ (loop (cdr l) (set-adjoin liv var)))
+ (let ((loc (if (eq? why 'side)
+ (make-reg 0)
+ (or (lowest-dead-reg live)
+ (lowest-dead-slot live)))))
+ (if (and (stk? loc) (> (stk-num loc) nb-slots))
+ (push-slot))
+ (let* ((args (map var->opnd (map cdr vars)))
+ (var (make-temp-var 'result))
+ (proc (node->proc oper))
+ (strict-pat (proc-obj-strict-pat proc)))
+ (if (not (eq? why 'side)) (put-var loc var))
+ (bb-put-non-branch!
+ *bb*
+ (make-apply
+ (specialize-for-call proc (node-decl node))
+ args
+ (if (eq? why 'side) #f loc)
+ (current-frame
+ (if (eq? why 'side) live (set-adjoin live var)))
+ (source-comment node)))
+ (gen-return loc why node))))))
+ (let* ((calling-local-proc?
+ (and (ref? oper)
+ (let ((opnd (var->opnd (ref-var oper))))
+ (and (lbl? opnd)
+ (let ((x (assq (lbl-num opnd) known-procs)))
+ (and x
+ (let ((proc (cdr x)))
+ (and (not (prc-rest proc))
+ (= (prc-min proc) nb-args)
+ (= (length (prc-parms proc))
+ nb-args)
+ (lbl-num opnd)))))))))
+ (jstate (get-jump-state
+ args
+ (if calling-local-proc?
+ (target.label-info nb-args nb-args #f #f)
+ (target.jump-info nb-args))))
+ (in-stk (jump-state-in-stk jstate))
+ (in-reg (jump-state-in-reg jstate))
+ (eval-order
+ (arg-eval-order (if calling-local-proc? #f oper) in-reg))
+ (live-after
+ (if (eq? why 'tail) (set-remove live ret-var) live))
+ (live-for-regs (args-live-vars live eval-order))
+ (return-lbl (if (eq? why 'tail) #f (bbs-new-lbl! *bbs*))))
+ (save-regs
+ (live-regs live-after)
+ (stk-live-vars live-for-regs in-stk why)
+ (source-comment node))
+ (let ((frame-start (stk-num (highest-live-slot live-after))))
+ (let loop1 ((l in-stk) (liv live-after) (i (+ frame-start 1)))
+ (if (not (null? l))
+ (let ((arg (car l))
+ (slot (make-stk i))
+ (needed (set-union
+ (stk-live-vars liv (cdr l) why)
+ live-for-regs)))
+ (if arg
+ (let ((var (if (and (eq? arg 'return)
+ (eq? why 'tail))
+ ret-var
+ (make-temp-var (- frame-start i)))))
+ (save-opnd-to-stk
+ (if (eq? arg 'return)
+ (if (eq? why 'tail)
+ (var->opnd ret-var)
+ (make-lbl return-lbl))
+ (gen-node arg needed 'need))
+ slot
+ var
+ needed
+ (source-comment
+ (if (eq? arg 'return) node arg)))
+ (loop1 (cdr l) (set-adjoin liv var) (+ i 1)))
+ (begin
+ (if (> i nb-slots)
+ (put-copy
+ (make-obj undef-object)
+ slot
+ empty-var
+ liv
+ (source-comment node)))
+ (loop1 (cdr l) liv (+ i 1)))))
+ (let loop2 ((l eval-order)
+ (liv liv)
+ (reg-map '())
+ (oper-var '()))
+ (if (not (null? l))
+ (let* ((arg (car (car l)))
+ (pos (cdr (car l)))
+ (needed (args-live-vars liv (cdr l)))
+ (var (if (and (eq? arg 'return)
+ (eq? why 'tail))
+ ret-var
+ (make-temp-var pos)))
+ (opnd (if (eq? arg 'return)
+ (if (eq? why 'tail)
+ (var->opnd ret-var)
+ (make-lbl return-lbl))
+ (gen-node arg needed 'need))))
+ (if (eq? pos 'operator)
+ (if (and (ref? arg)
+ (not (or (obj? opnd) (lbl? opnd))))
+ (loop2 (cdr l)
+ (set-adjoin liv (ref-var arg))
+ reg-map
+ (ref-var arg))
+ (begin
+ (save-arg
+ opnd
+ var
+ needed
+ (source-comment
+ (if (eq? arg 'return) node arg)))
+ (loop2 (cdr l)
+ (set-adjoin liv var)
+ reg-map
+ var)))
+ (let ((reg (make-reg pos)))
+ (if (all-args-trivial? (cdr l))
+ (save-opnd-to-reg
+ opnd
+ reg
+ var
+ needed
+ (source-comment
+ (if (eq? arg 'return) node arg)))
+ (save-in-slot
+ opnd
+ var
+ needed
+ (source-comment
+ (if (eq? arg 'return) node arg))))
+ (loop2 (cdr l)
+ (set-adjoin liv var)
+ (cons (cons pos var) reg-map)
+ oper-var))))
+ (let loop3 ((i (- target.nb-regs 1)))
+ (if (>= i 0)
+ (let ((couple (assq i reg-map)))
+ (if couple
+ (let ((var (cdr couple)))
+ (if (not (eq? (reg->var regs i) var))
+ (save-opnd-to-reg
+ (var->opnd var)
+ (make-reg i)
+ var
+ liv
+ (source-comment node)))))
+ (loop3 (- i 1)))
+ (let ((opnd (if calling-local-proc?
+ (make-lbl
+ (+ calling-local-proc? 1))
+ (var->opnd oper-var))))
+ (seal-bb (intrs-enabled? (node-decl node))
+ (if return-lbl 'call 'tail-call))
+ (dealloc-slots
+ (- nb-slots
+ (+ frame-start (length in-stk))))
+ (bb-put-branch!
+ *bb*
+ (make-jump
+ opnd
+ (if calling-local-proc? #f nb-args)
+ #f
+ (current-frame liv)
+ (source-comment node)))
+ (let ((result-var (make-temp-var 'result)))
+ (dealloc-slots (- nb-slots frame-start))
+ (flush-regs)
+ (put-var target.proc-result result-var)
+ (if return-lbl
+ (begin
+ (set! poll (return-poll poll))
+ (set! *bb*
+ (make-bb (make-label-return
+ return-lbl
+ (current-frame
+ (set-adjoin
+ live
+ result-var))
+ (source-comment
+ node))
+ *bbs*))))
+ target.proc-result))))))))))))))
+(define (contained-reg/slot opnd)
+ (cond ((reg? opnd) opnd)
+ ((stk? opnd) opnd)
+ ((clo? opnd) (contained-reg/slot (clo-base opnd)))
+ (else #f)))
+(define (opnd-needed opnd needed)
+ (let ((x (contained-reg/slot opnd)))
+ (if x (set-adjoin needed (get-var x)) needed)))
+(define (save-opnd opnd live comment)
+ (let ((slot (lowest-dead-slot live)))
+ (put-copy opnd slot (get-var opnd) live comment)))
+(define (save-regs regs live comment)
+ (for-each
+ (lambda (i) (save-opnd (make-reg i) live comment))
+ (set->list regs)))
+(define (save-opnd-to-reg opnd reg var live comment)
+ (if (set-member? (reg-num reg) (live-regs live))
+ (save-opnd reg (opnd-needed opnd live) comment))
+ (put-copy opnd reg var live comment))
+(define (save-opnd-to-stk opnd stk var live comment)
+ (if (set-member? (stk-num stk) (live-slots live))
+ (save-opnd stk (opnd-needed opnd live) comment))
+ (put-copy opnd stk var live comment))
+(define (all-args-trivial? l)
+ (if (null? l)
+ #t
+ (let ((arg (car (car l))))
+ (or (eq? arg 'return)
+ (and (trivial? arg) (all-args-trivial? (cdr l)))))))
+(define (every-trivial? l)
+ (or (null? l) (and (trivial? (car l)) (every-trivial? (cdr l)))))
+(define (trivial? node)
+ (or (cst? node)
+ (ref? node)
+ (and (set? node) (trivial? (set-val node)))
+ (and (inlinable-app? node) (every-trivial? (app-args node)))))
+(define (inlinable-app? node)
+ (if (app? node)
+ (let ((proc (node->proc (app-oper node))))
+ (and proc
+ (let ((spec (specialize-for-call proc (node-decl node))))
+ (and (proc-obj-inlinable spec)
+ (nb-args-conforms?
+ (length (app-args node))
+ (proc-obj-call-pat spec))))))
+ #f))
+(define (boolean-value? node)
+ (or (and (conj? node)
+ (boolean-value? (conj-pre node))
+ (boolean-value? (conj-alt node)))
+ (and (disj? node)
+ (boolean-value? (disj-pre node))
+ (boolean-value? (disj-alt node)))
+ (boolean-app? node)))
+(define (boolean-app? node)
+ (if (app? node)
+ (let ((proc (node->proc (app-oper node))))
+ (if proc (eq? (type-name (proc-obj-type proc)) 'boolean) #f))
+ #f))
+(define (node->proc node)
+ (cond ((cst? node) (if (proc-obj? (cst-val node)) (cst-val node) #f))
+ ((ref? node)
+ (if (global? (ref-var node))
+ (target.prim-info* (var-name (ref-var node)) (node-decl node))
+ #f))
+ (else #f)))
+(define (specialize-for-call proc decl) ((proc-obj-specialize proc) decl))
+(define (get-jump-state args pc)
+ (define (empty-node-list n)
+ (if (> n 0) (cons #f (empty-node-list (- n 1))) '()))
+ (let* ((fs (pcontext-fs pc))
+ (slots-list (empty-node-list fs))
+ (regs-list (empty-node-list target.nb-regs)))
+ (define (assign-node-to-loc var loc)
+ (let ((x (cond ((reg? loc)
+ (let ((i (reg-num loc)))
+ (if (<= i target.nb-regs)
+ (nth-after regs-list i)
+ (compiler-internal-error
+ "jump-state, reg out of bound in back-end's pcontext"))))
+ ((stk? loc)
+ (let ((i (stk-num loc)))
+ (if (<= i fs)
+ (nth-after slots-list (- i 1))
+ (compiler-internal-error
+ "jump-state, stk out of bound in back-end's pcontext"))))
+ (else
+ (compiler-internal-error
+ "jump-state, loc other than reg or stk in back-end's pcontext")))))
+ (if (not (car x))
+ (set-car! x var)
+ (compiler-internal-error
+ "jump-state, duplicate location in back-end's pcontext"))))
+ (let loop ((l (pcontext-map pc)))
+ (if (not (null? l))
+ (let* ((couple (car l)) (name (car couple)) (loc (cdr couple)))
+ (cond ((eq? name 'return) (assign-node-to-loc 'return loc))
+ (else (assign-node-to-loc (list-ref args (- name 1)) loc)))
+ (loop (cdr l)))))
+ (vector slots-list regs-list)))
+(define (jump-state-in-stk x) (vector-ref x 0))
+(define (jump-state-in-reg x) (vector-ref x 1))
+(define (arg-eval-order oper nodes)
+ (define (loop nodes pos part1 part2)
+ (cond ((null? nodes)
+ (let ((p1 (reverse part1)) (p2 (free-vars-order part2)))
+ (cond ((not oper) (append p1 p2))
+ ((trivial? oper)
+ (append p1 p2 (list (cons oper 'operator))))
+ (else (append (cons (cons oper 'operator) p1) p2)))))
+ ((not (car nodes)) (loop (cdr nodes) (+ pos 1) part1 part2))
+ ((or (eq? (car nodes) 'return) (trivial? (car nodes)))
+ (loop (cdr nodes)
+ (+ pos 1)
+ part1
+ (cons (cons (car nodes) pos) part2)))
+ (else
+ (loop (cdr nodes)
+ (+ pos 1)
+ (cons (cons (car nodes) pos) part1)
+ part2))))
+ (loop nodes 0 '() '()))
+(define (free-vars-order l)
+ (let ((bins '()) (ordered-args '()))
+ (define (free-v x) (if (eq? x 'return) (set-empty) (free-variables x)))
+ (define (add-to-bin! x)
+ (let ((y (assq x bins)))
+ (if y (set-cdr! y (+ (cdr y) 1)) (set! bins (cons (cons x 1) bins)))))
+ (define (payoff-if-removed node)
+ (let ((x (free-v node)))
+ (let loop ((l (set->list x)) (r 0))
+ (if (null? l)
+ r
+ (let ((y (cdr (assq (car l) bins))))
+ (loop (cdr l) (+ r (quotient 1000 (* y y)))))))))
+ (define (remove-free-vars! x)
+ (let loop ((l (set->list x)))
+ (if (not (null? l))
+ (let ((y (assq (car l) bins)))
+ (set-cdr! y (- (cdr y) 1))
+ (loop (cdr l))))))
+ (define (find-max-payoff l thunk)
+ (if (null? l)
+ (thunk '() -1)
+ (find-max-payoff
+ (cdr l)
+ (lambda (best-arg best-payoff)
+ (let ((payoff (payoff-if-removed (car (car l)))))
+ (if (>= payoff best-payoff)
+ (thunk (car l) payoff)
+ (thunk best-arg best-payoff)))))))
+ (define (remove x l)
+ (cond ((null? l) '())
+ ((eq? x (car l)) (cdr l))
+ (else (cons (car l) (remove x (cdr l))))))
+ (for-each
+ (lambda (x) (for-each add-to-bin! (set->list (free-v (car x)))))
+ l)
+ (let loop ((args l) (ordered-args '()))
+ (if (null? args)
+ (reverse ordered-args)
+ (find-max-payoff
+ args
+ (lambda (best-arg best-payoff)
+ (remove-free-vars! (free-v (car best-arg)))
+ (loop (remove best-arg args) (cons best-arg ordered-args))))))))
+(define (args-live-vars live order)
+ (cond ((null? order) live)
+ ((eq? (car (car order)) 'return)
+ (args-live-vars (set-adjoin live ret-var) (cdr order)))
+ (else
+ (args-live-vars
+ (set-union live (free-variables (car (car order))))
+ (cdr order)))))
+(define (stk-live-vars live slots why)
+ (cond ((null? slots) live)
+ ((not (car slots)) (stk-live-vars live (cdr slots) why))
+ ((eq? (car slots) 'return)
+ (stk-live-vars
+ (if (eq? why 'tail) (set-adjoin live ret-var) live)
+ (cdr slots)
+ why))
+ (else
+ (stk-live-vars
+ (set-union live (free-variables (car slots)))
+ (cdr slots)
+ why))))
+(define (gen-let vars vals node live why)
+ (let ((var-val-map (pair-up vars vals))
+ (var-set (list->set vars))
+ (all-live
+ (set-union
+ live
+ (free-variables node)
+ (apply set-union (map free-variables vals)))))
+ (define (var->val var) (cdr (assq var var-val-map)))
+ (define (proc-var? var) (prc? (var->val var)))
+ (define (closed-vars var const-proc-vars)
+ (set-difference
+ (not-constant-closed-vars (var->val var))
+ const-proc-vars))
+ (define (no-closed-vars? var const-proc-vars)
+ (set-empty? (closed-vars var const-proc-vars)))
+ (define (closed-vars? var const-proc-vars)
+ (not (no-closed-vars? var const-proc-vars)))
+ (define (compute-const-proc-vars proc-vars)
+ (let loop1 ((const-proc-vars proc-vars))
+ (let ((new-const-proc-vars
+ (set-keep
+ (lambda (x) (no-closed-vars? x const-proc-vars))
+ const-proc-vars)))
+ (if (not (set-equal? new-const-proc-vars const-proc-vars))
+ (loop1 new-const-proc-vars)
+ const-proc-vars))))
+ (let* ((proc-vars (set-keep proc-var? var-set))
+ (const-proc-vars (compute-const-proc-vars proc-vars))
+ (clo-vars
+ (set-keep (lambda (x) (closed-vars? x const-proc-vars)) proc-vars))
+ (clo-vars-list (set->list clo-vars)))
+ (for-each
+ (lambda (proc-var)
+ (let ((label (schedule-gen-proc (var->val proc-var) '())))
+ (add-known-proc (lbl-num label) (var->val proc-var))
+ (add-constant-var proc-var label)))
+ (set->list const-proc-vars))
+ (let ((non-clo-vars-list
+ (set->list
+ (set-keep
+ (lambda (var)
+ (and (not (set-member? var const-proc-vars))
+ (not (set-member? var clo-vars))))
+ vars)))
+ (liv (set-union
+ live
+ (apply set-union
+ (map (lambda (x) (closed-vars x const-proc-vars))
+ clo-vars-list))
+ (free-variables node))))
+ (let loop2 ((vars* non-clo-vars-list))
+ (if (not (null? vars*))
+ (let* ((var (car vars*))
+ (val (var->val var))
+ (needed (vals-live-vars liv (map var->val (cdr vars*)))))
+ (if (var-useless? var)
+ (gen-node val needed 'side)
+ (save-val
+ (gen-node val needed 'need)
+ var
+ needed
+ (source-comment val)))
+ (loop2 (cdr vars*)))))
+ (if (pair? clo-vars-list)
+ (begin
+ (dealloc-slots (- nb-slots (stk-num (highest-live-slot liv))))
+ (let loop3 ((l clo-vars-list))
+ (if (not (null? l))
+ (begin
+ (push-slot)
+ (let ((var (car l)) (slot (make-stk nb-slots)))
+ (put-var slot var)
+ (loop3 (cdr l))))))
+ (bb-put-non-branch!
+ *bb*
+ (make-close
+ (map (lambda (var)
+ (let ((closed-list
+ (sort-variables
+ (set->list (closed-vars var const-proc-vars)))))
+ (if (null? closed-list)
+ (compiler-internal-error
+ "gen-let, no closed variables:"
+ (var-name var))
+ (make-closure-parms
+ (var->opnd var)
+ (lbl-num (schedule-gen-proc
+ (var->val var)
+ closed-list))
+ (map var->opnd closed-list)))))
+ clo-vars-list)
+ (current-frame liv)
+ (source-comment node)))))
+ (gen-node node live why)))))
+(define (save-arg opnd var live comment)
+ (if (glo? opnd)
+ (add-constant-var var opnd)
+ (save-val opnd var live comment)))
+(define (save-val opnd var live comment)
+ (cond ((or (obj? opnd) (lbl? opnd)) (add-constant-var var opnd))
+ ((and (reg? opnd) (not (set-member? (reg-num opnd) (live-regs live))))
+ (put-var opnd var))
+ ((and (stk? opnd) (not (set-member? (stk-num opnd) (live-slots live))))
+ (put-var opnd var))
+ (else (save-in-slot opnd var live comment))))
+(define (save-in-slot opnd var live comment)
+ (let ((slot (lowest-dead-slot live))) (put-copy opnd slot var live comment)))
+(define (save-var opnd var live comment)
+ (cond ((or (obj? opnd) (lbl? opnd)) (add-constant-var var opnd) var)
+ ((or (glo? opnd) (reg? opnd) (stk? opnd)) (get-var opnd))
+ (else
+ (let ((dest (or (highest-dead-reg live) (lowest-dead-slot live))))
+ (put-copy opnd dest var live comment)
+ var))))
+(define (put-copy opnd loc var live comment)
+ (if (and (stk? loc) (> (stk-num loc) nb-slots)) (push-slot))
+ (if var (put-var loc var))
+ (if (not (eq? opnd loc))
+ (bb-put-non-branch!
+ *bb*
+ (make-copy
+ opnd
+ loc
+ (current-frame (if var (set-adjoin live var) live))
+ comment))))
+(define (var-useless? var)
+ (and (set-empty? (var-refs var)) (set-empty? (var-sets var))))
+(define (vals-live-vars live vals)
+ (if (null? vals)
+ live
+ (vals-live-vars
+ (set-union live (free-variables (car vals)))
+ (cdr vals))))
+(define (gen-fut node live why)
+ (let* ((val (fut-val node))
+ (clo-vars (not-constant-closed-vars val))
+ (clo-vars-list (set->list clo-vars))
+ (ret-var* (make-temp-var 0))
+ (live-after live)
+ (live-starting-task
+ (set-adjoin (set-union live-after clo-vars) ret-var*))
+ (task-lbl (bbs-new-lbl! *bbs*))
+ (return-lbl (bbs-new-lbl! *bbs*)))
+ (save-regs (live-regs live-after) live-starting-task (source-comment node))
+ (let ((frame-start (stk-num (highest-live-slot live-after))))
+ (save-opnd-to-reg
+ (make-lbl return-lbl)
+ target.task-return
+ ret-var*
+ (set-remove live-starting-task ret-var*)
+ (source-comment node))
+ (let loop1 ((l clo-vars-list) (i 0))
+ (if (null? l)
+ (dealloc-slots (- nb-slots (+ frame-start i)))
+ (let ((var (car l)) (rest (cdr l)))
+ (if (memq var regs)
+ (loop1 rest i)
+ (let loop2 ((j (- target.nb-regs 1)))
+ (if (>= j 0)
+ (if (or (>= j (length regs))
+ (not (set-member?
+ (list-ref regs j)
+ live-starting-task)))
+ (let ((reg (make-reg j)))
+ (put-copy
+ (var->opnd var)
+ reg
+ var
+ live-starting-task
+ (source-comment node))
+ (loop1 rest i))
+ (loop2 (- j 1)))
+ (let ((slot (make-stk (+ frame-start (+ i 1))))
+ (needed (list->set rest)))
+ (if (and (or (> (stk-num slot) nb-slots)
+ (not (memq (list-ref
+ slots
+ (- nb-slots (stk-num slot)))
+ regs)))
+ (set-member?
+ (stk-num slot)
+ (live-slots needed)))
+ (save-opnd
+ slot
+ live-starting-task
+ (source-comment node)))
+ (put-copy
+ (var->opnd var)
+ slot
+ var
+ live-starting-task
+ (source-comment node))
+ (loop1 rest (+ i 1)))))))))
+ (seal-bb (intrs-enabled? (node-decl node)) 'call)
+ (bb-put-branch!
+ *bb*
+ (make-jump
+ (make-lbl task-lbl)
+ #f
+ #f
+ (current-frame live-starting-task)
+ #f))
+ (let ((task-context
+ (make-context
+ (- nb-slots frame-start)
+ (reverse (nth-after (reverse slots) frame-start))
+ (cons ret-var (cdr regs))
+ '()
+ poll
+ entry-bb))
+ (return-context
+ (make-context
+ frame-start
+ (nth-after slots (- nb-slots frame-start))
+ '()
+ closed
+ (return-poll poll)
+ entry-bb)))
+ (restore-context task-context)
+ (set! *bb*
+ (make-bb (make-label-task-entry
+ task-lbl
+ (current-frame live-starting-task)
+ (source-comment node))
+ *bbs*))
+ (gen-node val ret-var-set 'tail)
+ (let ((result-var (make-temp-var 'future)))
+ (restore-context return-context)
+ (put-var target.proc-result result-var)
+ (set! *bb*
+ (make-bb (make-label-task-return
+ return-lbl
+ (current-frame (set-adjoin live result-var))
+ (source-comment node))
+ *bbs*))
+ (gen-return target.proc-result why node))))))
+(define prim-procs
+ '(("not" (1) #f 0 boolean)
+ ("boolean?" (1) #f 0 boolean)
+ ("eqv?" (2) #f 0 boolean)
+ ("eq?" (2) #f 0 boolean)
+ ("equal?" (2) #f 0 boolean)
+ ("pair?" (1) #f 0 boolean)
+ ("cons" (2) #f () pair)
+ ("car" (1) #f 0 (#f))
+ ("cdr" (1) #f 0 (#f))
+ ("set-car!" (2) #t (1) pair)
+ ("set-cdr!" (2) #t (1) pair)
+ ("caar" (1) #f 0 (#f))
+ ("cadr" (1) #f 0 (#f))
+ ("cdar" (1) #f 0 (#f))
+ ("cddr" (1) #f 0 (#f))
+ ("caaar" (1) #f 0 (#f))
+ ("caadr" (1) #f 0 (#f))
+ ("cadar" (1) #f 0 (#f))
+ ("caddr" (1) #f 0 (#f))
+ ("cdaar" (1) #f 0 (#f))
+ ("cdadr" (1) #f 0 (#f))
+ ("cddar" (1) #f 0 (#f))
+ ("cdddr" (1) #f 0 (#f))
+ ("caaaar" (1) #f 0 (#f))
+ ("caaadr" (1) #f 0 (#f))
+ ("caadar" (1) #f 0 (#f))
+ ("caaddr" (1) #f 0 (#f))
+ ("cadaar" (1) #f 0 (#f))
+ ("cadadr" (1) #f 0 (#f))
+ ("caddar" (1) #f 0 (#f))
+ ("cadddr" (1) #f 0 (#f))
+ ("cdaaar" (1) #f 0 (#f))
+ ("cdaadr" (1) #f 0 (#f))
+ ("cdadar" (1) #f 0 (#f))
+ ("cdaddr" (1) #f 0 (#f))
+ ("cddaar" (1) #f 0 (#f))
+ ("cddadr" (1) #f 0 (#f))
+ ("cdddar" (1) #f 0 (#f))
+ ("cddddr" (1) #f 0 (#f))
+ ("null?" (1) #f 0 boolean)
+ ("list?" (1) #f 0 boolean)
+ ("list" 0 #f () list)
+ ("length" (1) #f 0 integer)
+ ("append" 0 #f 0 list)
+ ("reverse" (1) #f 0 list)
+ ("list-ref" (2) #f 0 (#f))
+ ("memq" (2) #f 0 list)
+ ("memv" (2) #f 0 list)
+ ("member" (2) #f 0 list)
+ ("assq" (2) #f 0 #f)
+ ("assv" (2) #f 0 #f)
+ ("assoc" (2) #f 0 #f)
+ ("symbol?" (1) #f 0 boolean)
+ ("symbol->string" (1) #f 0 string)
+ ("string->symbol" (1) #f 0 symbol)
+ ("number?" (1) #f 0 boolean)
+ ("complex?" (1) #f 0 boolean)
+ ("real?" (1) #f 0 boolean)
+ ("rational?" (1) #f 0 boolean)
+ ("integer?" (1) #f 0 boolean)
+ ("exact?" (1) #f 0 boolean)
+ ("inexact?" (1) #f 0 boolean)
+ ("=" 0 #f 0 boolean)
+ ("<" 0 #f 0 boolean)
+ (">" 0 #f 0 boolean)
+ ("<=" 0 #f 0 boolean)
+ (">=" 0 #f 0 boolean)
+ ("zero?" (1) #f 0 boolean)
+ ("positive?" (1) #f 0 boolean)
+ ("negative?" (1) #f 0 boolean)
+ ("odd?" (1) #f 0 boolean)
+ ("even?" (1) #f 0 boolean)
+ ("max" 1 #f 0 number)
+ ("min" 1 #f 0 number)
+ ("+" 0 #f 0 number)
+ ("*" 0 #f 0 number)
+ ("-" 1 #f 0 number)
+ ("/" 1 #f 0 number)
+ ("abs" (1) #f 0 number)
+ ("quotient" 1 #f 0 integer)
+ ("remainder" (2) #f 0 integer)
+ ("modulo" (2) #f 0 integer)
+ ("gcd" 1 #f 0 integer)
+ ("lcm" 1 #f 0 integer)
+ ("numerator" (1) #f 0 integer)
+ ("denominator" (1) #f 0 integer)
+ ("floor" (1) #f 0 integer)
+ ("ceiling" (1) #f 0 integer)
+ ("truncate" (1) #f 0 integer)
+ ("round" (1) #f 0 integer)
+ ("rationalize" (2) #f 0 number)
+ ("exp" (1) #f 0 number)
+ ("log" (1) #f 0 number)
+ ("sin" (1) #f 0 number)
+ ("cos" (1) #f 0 number)
+ ("tan" (1) #f 0 number)
+ ("asin" (1) #f 0 number)
+ ("acos" (1) #f 0 number)
+ ("atan" (1 2) #f 0 number)
+ ("sqrt" (1) #f 0 number)
+ ("expt" (2) #f 0 number)
+ ("make-rectangular" (2) #f 0 number)
+ ("make-polar" (2) #f 0 number)
+ ("real-part" (1) #f 0 real)
+ ("imag-part" (1) #f 0 real)
+ ("magnitude" (1) #f 0 real)
+ ("angle" (1) #f 0 real)
+ ("exact->inexact" (1) #f 0 number)
+ ("inexact->exact" (1) #f 0 number)
+ ("number->string" (1 2) #f 0 string)
+ ("string->number" (1 2) #f 0 number)
+ ("char?" (1) #f 0 boolean)
+ ("char=?" 0 #f 0 boolean)
+ ("char<?" 0 #f 0 boolean)
+ ("char>?" 0 #f 0 boolean)
+ ("char<=?" 0 #f 0 boolean)
+ ("char>=?" 0 #f 0 boolean)
+ ("char-ci=?" 0 #f 0 boolean)
+ ("char-ci<?" 0 #f 0 boolean)
+ ("char-ci>?" 0 #f 0 boolean)
+ ("char-ci<=?" 0 #f 0 boolean)
+ ("char-ci>=?" 0 #f 0 boolean)
+ ("char-alphabetic?" (1) #f 0 boolean)
+ ("char-numeric?" (1) #f 0 boolean)
+ ("char-whitespace?" (1) #f 0 boolean)
+ ("char-upper-case?" (1) #f 0 boolean)
+ ("char-lower-case?" (1) #f 0 boolean)
+ ("char->integer" (1) #f 0 integer)
+ ("integer->char" (1) #f 0 char)
+ ("char-upcase" (1) #f 0 char)
+ ("char-downcase" (1) #f 0 char)
+ ("string?" (1) #f 0 boolean)
+ ("make-string" (1 2) #f 0 string)
+ ("string" 0 #f 0 string)
+ ("string-length" (1) #f 0 integer)
+ ("string-ref" (2) #f 0 char)
+ ("string-set!" (3) #t 0 string)
+ ("string=?" 0 #f 0 boolean)
+ ("string<?" 0 #f 0 boolean)
+ ("string>?" 0 #f 0 boolean)
+ ("string<=?" 0 #f 0 boolean)
+ ("string>=?" 0 #f 0 boolean)
+ ("string-ci=?" 0 #f 0 boolean)
+ ("string-ci<?" 0 #f 0 boolean)
+ ("string-ci>?" 0 #f 0 boolean)
+ ("string-ci<=?" 0 #f 0 boolean)
+ ("string-ci>=?" 0 #f 0 boolean)
+ ("substring" (3) #f 0 string)
+ ("string-append" 0 #f 0 string)
+ ("vector?" (1) #f 0 boolean)
+ ("make-vector" (1 2) #f (1) vector)
+ ("vector" 0 #f () vector)
+ ("vector-length" (1) #f 0 integer)
+ ("vector-ref" (2) #f 0 (#f))
+ ("vector-set!" (3) #t (1 2) vector)
+ ("procedure?" (1) #f 0 boolean)
+ ("apply" 2 #t 0 (#f))
+ ("map" 2 #t 0 list)
+ ("for-each" 2 #t 0 #f)
+ ("call-with-current-continuation" (1) #t 0 (#f))
+ ("call-with-input-file" (2) #t 0 (#f))
+ ("call-with-output-file" (2) #t 0 (#f))
+ ("input-port?" (1) #f 0 boolean)
+ ("output-port?" (1) #f 0 boolean)
+ ("current-input-port" (0) #f 0 port)
+ ("current-output-port" (0) #f 0 port)
+ ("open-input-file" (1) #t 0 port)
+ ("open-output-file" (1) #t 0 port)
+ ("close-input-port" (1) #t 0 #f)
+ ("close-output-port" (1) #t 0 #f)
+ ("eof-object?" (1) #f 0 boolean)
+ ("read" (0 1) #t 0 #f)
+ ("read-char" (0 1) #t 0 #f)
+ ("peek-char" (0 1) #t 0 #f)
+ ("write" (0 1) #t 0 #f)
+ ("display" (0 1) #t 0 #f)
+ ("newline" (0 1) #t 0 #f)
+ ("write-char" (1 2) #t 0 #f)
+ ("list-tail" (2) #f 0 (#f))
+ ("string->list" (1) #f 0 list)
+ ("list->string" (1) #f 0 string)
+ ("string-copy" (1) #f 0 string)
+ ("string-fill!" (2) #t 0 string)
+ ("vector->list" (1) #f 0 list)
+ ("list->vector" (1) #f 0 vector)
+ ("vector-fill!" (2) #t 0 vector)
+ ("force" (1) #t 0 #f)
+ ("with-input-from-file" (2) #t 0 (#f))
+ ("with-output-to-file" (2) #t 0 (#f))
+ ("char-ready?" (0 1) #f 0 boolean)
+ ("load" (1) #t 0 (#f))
+ ("transcript-on" (1) #t 0 #f)
+ ("transcript-off" (0) #t 0 #f)
+ ("touch" (1) #t 0 #f)
+ ("##type" (1) #f () integer)
+ ("##type-cast" (2) #f () (#f))
+ ("##subtype" (1) #f () integer)
+ ("##subtype-set!" (2) #t () #f)
+ ("##not" (1) #f () boolean)
+ ("##null?" (1) #f () boolean)
+ ("##unassigned?" (1) #f () boolean)
+ ("##unbound?" (1) #f () boolean)
+ ("##eq?" (2) #f () boolean)
+ ("##fixnum?" (1) #f () boolean)
+ ("##flonum?" (1) #f () boolean)
+ ("##special?" (1) #f () boolean)
+ ("##pair?" (1) #f () boolean)
+ ("##subtyped?" (1) #f () boolean)
+ ("##procedure?" (1) #f () boolean)
+ ("##placeholder?" (1) #f () boolean)
+ ("##vector?" (1) #f () boolean)
+ ("##symbol?" (1) #f () boolean)
+ ("##ratnum?" (1) #f () boolean)
+ ("##cpxnum?" (1) #f () boolean)
+ ("##string?" (1) #f () boolean)
+ ("##bignum?" (1) #f () boolean)
+ ("##char?" (1) #f () boolean)
+ ("##closure?" (1) #f () boolean)
+ ("##subprocedure?" (1) #f () boolean)
+ ("##return-dynamic-env-bind?" (1) #f () boolean)
+ ("##fixnum.+" 0 #f () integer)
+ ("##fixnum.*" 0 #f () integer)
+ ("##fixnum.-" 1 #f () integer)
+ ("##fixnum.quotient" (2) #f () integer)
+ ("##fixnum.remainder" (2) #f () integer)
+ ("##fixnum.modulo" (2) #f () integer)
+ ("##fixnum.logior" 0 #f () integer)
+ ("##fixnum.logxor" 0 #f () integer)
+ ("##fixnum.logand" 0 #f () integer)
+ ("##fixnum.lognot" (1) #f () integer)
+ ("##fixnum.ash" (2) #f () integer)
+ ("##fixnum.lsh" (2) #f () integer)
+ ("##fixnum.zero?" (1) #f () boolean)
+ ("##fixnum.positive?" (1) #f () boolean)
+ ("##fixnum.negative?" (1) #f () boolean)
+ ("##fixnum.odd?" (1) #f () boolean)
+ ("##fixnum.even?" (1) #f () boolean)
+ ("##fixnum.=" 0 #f () boolean)
+ ("##fixnum.<" 0 #f () boolean)
+ ("##fixnum.>" 0 #f () boolean)
+ ("##fixnum.<=" 0 #f () boolean)
+ ("##fixnum.>=" 0 #f () boolean)
+ ("##flonum.->fixnum" (1) #f () integer)
+ ("##flonum.<-fixnum" (1) #f () real)
+ ("##flonum.+" 0 #f () real)
+ ("##flonum.*" 0 #f () real)
+ ("##flonum.-" 1 #f () real)
+ ("##flonum./" 1 #f () real)
+ ("##flonum.abs" (1) #f () real)
+ ("##flonum.truncate" (1) #f () real)
+ ("##flonum.round" (1) #f () real)
+ ("##flonum.exp" (1) #f () real)
+ ("##flonum.log" (1) #f () real)
+ ("##flonum.sin" (1) #f () real)
+ ("##flonum.cos" (1) #f () real)
+ ("##flonum.tan" (1) #f () real)
+ ("##flonum.asin" (1) #f () real)
+ ("##flonum.acos" (1) #f () real)
+ ("##flonum.atan" (1) #f () real)
+ ("##flonum.sqrt" (1) #f () real)
+ ("##flonum.zero?" (1) #f () boolean)
+ ("##flonum.positive?" (1) #f () boolean)
+ ("##flonum.negative?" (1) #f () boolean)
+ ("##flonum.=" 0 #f () boolean)
+ ("##flonum.<" 0 #f () boolean)
+ ("##flonum.>" 0 #f () boolean)
+ ("##flonum.<=" 0 #f () boolean)
+ ("##flonum.>=" 0 #f () boolean)
+ ("##char=?" 0 #f () boolean)
+ ("##char<?" 0 #f () boolean)
+ ("##char>?" 0 #f () boolean)
+ ("##char<=?" 0 #f () boolean)
+ ("##char>=?" 0 #f () boolean)
+ ("##cons" (2) #f () pair)
+ ("##set-car!" (2) #t () pair)
+ ("##set-cdr!" (2) #t () pair)
+ ("##car" (1) #f () (#f))
+ ("##cdr" (1) #f () (#f))
+ ("##caar" (1) #f () (#f))
+ ("##cadr" (1) #f () (#f))
+ ("##cdar" (1) #f () (#f))
+ ("##cddr" (1) #f () (#f))
+ ("##caaar" (1) #f () (#f))
+ ("##caadr" (1) #f () (#f))
+ ("##cadar" (1) #f () (#f))
+ ("##caddr" (1) #f () (#f))
+ ("##cdaar" (1) #f () (#f))
+ ("##cdadr" (1) #f () (#f))
+ ("##cddar" (1) #f () (#f))
+ ("##cdddr" (1) #f () (#f))
+ ("##caaaar" (1) #f () (#f))
+ ("##caaadr" (1) #f () (#f))
+ ("##caadar" (1) #f () (#f))
+ ("##caaddr" (1) #f () (#f))
+ ("##cadaar" (1) #f () (#f))
+ ("##cadadr" (1) #f () (#f))
+ ("##caddar" (1) #f () (#f))
+ ("##cadddr" (1) #f () (#f))
+ ("##cdaaar" (1) #f () (#f))
+ ("##cdaadr" (1) #f () (#f))
+ ("##cdadar" (1) #f () (#f))
+ ("##cdaddr" (1) #f () (#f))
+ ("##cddaar" (1) #f () (#f))
+ ("##cddadr" (1) #f () (#f))
+ ("##cdddar" (1) #f () (#f))
+ ("##cddddr" (1) #f () (#f))
+ ("##make-cell" (1) #f () pair)
+ ("##cell-ref" (1) #f () (#f))
+ ("##cell-set!" (2) #t () pair)
+ ("##vector" 0 #f () vector)
+ ("##make-vector" (2) #f () vector)
+ ("##vector-length" (1) #f () integer)
+ ("##vector-ref" (2) #f () (#f))
+ ("##vector-set!" (3) #t () vector)
+ ("##vector-shrink!" (2) #t () vector)
+ ("##string" 0 #f () string)
+ ("##make-string" (2) #f () string)
+ ("##string-length" (1) #f () integer)
+ ("##string-ref" (2) #f () char)
+ ("##string-set!" (3) #t () string)
+ ("##string-shrink!" (2) #t () string)
+ ("##vector8" 0 #f () string)
+ ("##make-vector8" (2) #f () string)
+ ("##vector8-length" (1) #f () integer)
+ ("##vector8-ref" (2) #f () integer)
+ ("##vector8-set!" (3) #t () string)
+ ("##vector8-shrink!" (2) #t () string)
+ ("##vector16" 0 #f () string)
+ ("##make-vector16" (2) #f () string)
+ ("##vector16-length" (1) #f () integer)
+ ("##vector16-ref" (2) #f () integer)
+ ("##vector16-set!" (3) #t () string)
+ ("##vector16-shrink!" (2) #t () string)
+ ("##closure-code" (1) #f () #f)
+ ("##closure-ref" (2) #f () (#f))
+ ("##closure-set!" (3) #t () #f)
+ ("##subprocedure-id" (1) #f () #f)
+ ("##subprocedure-parent" (1) #f () #f)
+ ("##return-fs" (1) #f () #f)
+ ("##return-link" (1) #f () #f)
+ ("##procedure-info" (1) #f () #f)
+ ("##pstate" (0) #f () #f)
+ ("##make-placeholder" (1) #f 0 (#f))
+ ("##touch" (1) #t 0 #f)
+ ("##apply" (2) #t () (#f))
+ ("##call-with-current-continuation" (1) #t () (#f))
+ ("##global-var" (1) #t () #f)
+ ("##global-var-ref" (1) #f () (#f))
+ ("##global-var-set!" (2) #t () #f)
+ ("##atomic-car" (1) #f () (#f))
+ ("##atomic-cdr" (1) #f () (#f))
+ ("##atomic-set-car!" (2) #t () pair)
+ ("##atomic-set-cdr!" (2) #t () pair)
+ ("##atomic-set-car-if-eq?!" (3) #t () boolean)
+ ("##atomic-set-cdr-if-eq?!" (3) #t () boolean)
+ ("##quasi-append" 0 #f 0 list)
+ ("##quasi-list" 0 #f () list)
+ ("##quasi-cons" (2) #f () pair)
+ ("##quasi-list->vector" (1) #f 0 vector)
+ ("##case-memv" (2) #f 0 list)))
+(define ofile-version-major 5)
+(define ofile-version-minor 0)
+(define prim-proc-prefix 1)
+(define user-proc-prefix 2)
+(define pair-prefix 3)
+(define flonum-prefix 4)
+(define local-object-bits -524281)
+(define symbol-object-bits -393209)
+(define prim-proc-object-bits -262137)
+(define padding-tag 0)
+(define end-of-code-tag 32768)
+(define m68020-proc-code-tag 32769)
+(define m68881-proc-code-tag 32770)
+(define stat-tag 32771)
+(define global-var-ref-tag 34816)
+(define global-var-set-tag 36864)
+(define global-var-ref-jump-tag 38912)
+(define prim-proc-ref-tag 40960)
+(define local-proc-ref-tag 49152)
+(define long-index-mask 16383)
+(define word-index-mask 2047)
+(define (ofile.begin! filename add-obj)
+ (set! ofile-add-obj add-obj)
+ (set! ofile-syms (queue-empty))
+; (set! *ofile-port1* (open-output-file (string-append filename ".O")))
+ (if ofile-asm?
+ (begin
+ (set! *ofile-port2*
+ (asm-open-output-file (string-append filename ".asm")))
+ (set! *ofile-pos* 0)))
+ (ofile-word ofile-version-major)
+ (ofile-word ofile-version-minor)
+ '())
+(define (ofile.end!)
+ (ofile-line "")
+; (close-output-port *ofile-port1*)
+ (if ofile-asm? (asm-close-output-port *ofile-port2*))
+ '())
+(define asm-output '())
+(define asm-line '())
+(define (asm-open-output-file filename)
+ (set! asm-output '())
+ (set! asm-line '()))
+(define (asm-close-output-port asm-port) #f)
+(define (asm-newline asm-port) (asm-display char-newline asm-port))
+(define (asm-display obj asm-port)
+ (if (eqv? obj char-newline)
+ (begin
+ (set! asm-output
+ (cons (apply string-append (reverse asm-line)) asm-output))
+ (set! asm-line '()))
+ (set! asm-line
+ (cons (cond ((string? obj) obj)
+ ((char? obj) (if (eqv? obj char-tab) " " (string obj)))
+ ((number? obj) (number->string obj))
+ (else (compiler-internal-error "asm-display" obj)))
+ asm-line))))
+(define (asm-output-get) (reverse asm-output))
+(define *ofile-port1* '())
+(define *ofile-port2* '())
+(define *ofile-pos* '())
+(define ofile-nl char-newline)
+(define ofile-tab char-tab)
+(define ofile-asm? '())
+(set! ofile-asm? '())
+(define ofile-asm-bits? '())
+(set! ofile-asm-bits? #f)
+(define ofile-asm-gvm? '())
+(set! ofile-asm-gvm? #f)
+(define ofile-stats? '())
+(set! ofile-stats? '())
+(define ofile-add-obj '())
+(set! ofile-add-obj '())
+(define ofile-syms '())
+(set! ofile-syms '())
+(define (ofile-word n)
+ (let ((n (modulo n 65536)))
+ (if (and ofile-asm? ofile-asm-bits?)
+ (let ()
+ (define (ofile-display x)
+ (asm-display x *ofile-port2*)
+ (cond ((eq? x ofile-nl) (set! *ofile-pos* 0))
+ ((eq? x ofile-tab)
+ (set! *ofile-pos* (* (quotient (+ *ofile-pos* 8) 8) 8)))
+ (else (set! *ofile-pos* (+ *ofile-pos* (string-length x))))))
+ (if (> *ofile-pos* 64) (ofile-display ofile-nl))
+ (if (= *ofile-pos* 0) (ofile-display " .word") (ofile-display ","))
+ (ofile-display ofile-tab)
+ (let ((s (make-string 6 #\0)))
+ (string-set! s 1 #\x)
+ (let loop ((i 5) (n n))
+ (if (> n 0)
+ (begin
+ (string-set!
+ s
+ i
+ (string-ref "0123456789ABCDEF" (remainder n 16)))
+ (loop (- i 1) (quotient n 16)))))
+ (ofile-display s))))
+' (write-word n *ofile-port1*)))
+(define (ofile-long x) (ofile-word (upper-16bits x)) (ofile-word x))
+(define (ofile-string s)
+ (let ((len (string-length s)))
+ (define (ref i) (if (>= i len) 0 (character-encoding (string-ref s i))))
+ (let loop ((i 0))
+ (if (< i len)
+ (begin
+ (ofile-word (+ (* (ref i) 256) (ref (+ i 1))))
+ (loop (+ i 2)))))
+ (if (= (remainder len 2) 0) (ofile-word 0))))
+(define (ofile-wsym tag name)
+ (let ((n (string-pos-in-list name (queue->list ofile-syms))))
+ (if n
+ (ofile-word (+ tag n))
+ (let ((m (length (queue->list ofile-syms))))
+ (queue-put! ofile-syms name)
+ (ofile-word (+ tag word-index-mask))
+ (ofile-string name)))))
+(define (ofile-lsym tag name)
+ (let ((n (string-pos-in-list name (queue->list ofile-syms))))
+ (if n
+ (ofile-long (+ tag (* n 8)))
+ (let ((m (length (queue->list ofile-syms))))
+ (queue-put! ofile-syms name)
+ (ofile-long (+ tag (* long-index-mask 8)))
+ (ofile-string name)))))
+(define (ofile-ref obj)
+ (let ((n (obj-encoding obj)))
+ (if n
+ (ofile-long n)
+ (if (symbol-object? obj)
+ (begin (ofile-lsym symbol-object-bits (symbol->string obj)))
+ (let ((m (ofile-add-obj obj)))
+ (if m
+ (ofile-long (+ local-object-bits (* m 8)))
+ (begin
+ (ofile-lsym
+ prim-proc-object-bits
+ (proc-obj-name obj)))))))))
+(define (ofile-prim-proc s)
+ (ofile-long prim-proc-prefix)
+ (ofile-wsym 0 s)
+ (ofile-comment (list "| #[primitive " s "] =")))
+(define (ofile-user-proc) (ofile-long user-proc-prefix))
+(define (ofile-line s)
+ (if ofile-asm?
+ (begin
+ (if (> *ofile-pos* 0) (asm-newline *ofile-port2*))
+ (asm-display s *ofile-port2*)
+ (asm-newline *ofile-port2*)
+ (set! *ofile-pos* 0))))
+(define (ofile-tabs-to n)
+ (let loop ()
+ (if (< *ofile-pos* n)
+ (begin
+ (asm-display ofile-tab *ofile-port2*)
+ (set! *ofile-pos* (* (quotient (+ *ofile-pos* 8) 8) 8))
+ (loop)))))
+(define (ofile-comment l)
+ (if ofile-asm?
+ (let ()
+ (if ofile-asm-bits?
+ (begin (ofile-tabs-to 32) (asm-display "|" *ofile-port2*)))
+ (for-each (lambda (x) (asm-display x *ofile-port2*)) l)
+ (asm-newline *ofile-port2*)
+ (set! *ofile-pos* 0))))
+(define (ofile-gvm-instr code)
+ (if (and ofile-asm? ofile-asm-gvm?)
+ (let ((gvm-instr (code-gvm-instr code)) (sn (code-slots-needed code)))
+ (if (> *ofile-pos* 0)
+ (begin (asm-newline *ofile-port2*) (set! *ofile-pos* 0)))
+ (if ofile-asm-bits? (ofile-tabs-to 32))
+ (asm-display "| GVM: [" *ofile-port2*)
+ (asm-display sn *ofile-port2*)
+ (asm-display "] " *ofile-port2*)
+ (asm-newline *ofile-port2*)
+ (set! *ofile-pos* 0))))
+(define (ofile-stat stat)
+ (define (obj->string x)
+ (cond ((string? x) x)
+ ((symbol-object? x) (symbol->string x))
+ ((number? x) (number->string x))
+ ((false-object? x) "#f")
+ ((eq? x #t) "#t")
+ ((null? x) "()")
+ ((pair? x)
+ (let loop ((l1 (cdr x)) (l2 (list (obj->string (car x)) "(")))
+ (cond ((pair? l1)
+ (loop (cdr l1)
+ (cons (obj->string (car l1)) (cons " " l2))))
+ ((null? l1) (apply string-append (reverse (cons ")" l2))))
+ (else
+ (apply string-append
+ (reverse (cons ")"
+ (cons (obj->string l1)
+ (cons " . " l2)))))))))
+ (else
+ (compiler-internal-error
+ "ofile-stat, can't convert to string 'x'"
+ x))))
+ (ofile-string (obj->string stat)))
+(define (upper-16bits x)
+ (cond ((>= x 0) (quotient x 65536))
+ ((>= x (- 65536)) -1)
+ (else (- (quotient (+ x 65537) 65536) 2))))
+(define type-fixnum 0)
+(define type-flonum 1)
+(define type-special 7)
+(define type-pair 4)
+(define type-placeholder 5)
+(define type-subtyped 3)
+(define type-procedure 2)
+(define subtype-vector 0)
+(define subtype-symbol 1)
+(define subtype-port 2)
+(define subtype-ratnum 3)
+(define subtype-cpxnum 4)
+(define subtype-string 16)
+(define subtype-bignum 17)
+(define data-false (- 33686019))
+(define data-null (- 67372037))
+(define data-true -2)
+(define data-undef -3)
+(define data-unass -4)
+(define data-unbound -5)
+(define data-eof -6)
+(define data-max-fixnum 268435455)
+(define data-min-fixnum (- 268435456))
+(define (make-encoding data type) (+ (* data 8) type))
+(define (obj-type obj)
+ (cond ((false-object? obj) 'special)
+ ((undef-object? obj) 'special)
+ ((symbol-object? obj) 'subtyped)
+ ((proc-obj? obj) 'procedure)
+ ((eq? obj #t) 'special)
+ ((null? obj) 'special)
+ ((pair? obj) 'pair)
+ ((number? obj)
+ (cond ((and (integer? obj)
+ (exact? obj)
+ (>= obj data-min-fixnum)
+ (<= obj data-max-fixnum))
+ 'fixnum)
+ (
+#t
+;; (and (inexact? (real-part obj))
+;; (zero? (imag-part obj))
+;; (exact? (imag-part obj)))
+ 'flonum)
+ (else 'subtyped)))
+ ((char? obj) 'special)
+ (else 'subtyped)))
+(define (obj-subtype obj)
+ (cond ((symbol-object? obj) 'symbol)
+ ((number? obj)
+ (cond ((and (integer? obj) (exact? obj)) 'bignum)
+ ((and (rational? obj) (exact? obj)) 'ratnum)
+ (else 'cpxnum)))
+ ((vector? obj) 'vector)
+ ((string? obj) 'string)
+ (else
+ (compiler-internal-error "obj-subtype, unknown object 'obj'" obj))))
+(define (obj-type-tag obj)
+ (case (obj-type obj)
+ ((fixnum) type-fixnum)
+ ((flonum) type-flonum)
+ ((special) type-special)
+ ((pair) type-pair)
+ ((subtyped) type-subtyped)
+ ((procedure) type-procedure)
+ (else (compiler-internal-error "obj-type-tag, unknown object 'obj'" obj))))
+(define (obj-encoding obj)
+ (case (obj-type obj)
+ ((fixnum) (make-encoding obj type-fixnum))
+ ((special)
+ (make-encoding
+ (cond ((false-object? obj) data-false)
+ ((undef-object? obj) data-undef)
+ ((eq? obj #t) data-true)
+ ((null? obj) data-null)
+ ((char? obj) (character-encoding obj))
+ (else
+ (compiler-internal-error
+ "obj-encoding, unknown SPECIAL object 'obj'"
+ obj)))
+ type-special))
+ (else #f)))
+(define bits-false (make-encoding data-false type-special))
+(define bits-null (make-encoding data-null type-special))
+(define bits-true (make-encoding data-true type-special))
+(define bits-unass (make-encoding data-unass type-special))
+(define bits-unbound (make-encoding data-unbound type-special))
+(define (asm.begin!)
+ (set! asm-code-queue (queue-empty))
+ (set! asm-const-queue (queue-empty))
+ '())
+(define (asm.end! debug-info)
+ (asm-assemble! debug-info)
+ (set! asm-code-queue '())
+ (set! asm-const-queue '())
+ '())
+(define asm-code-queue '())
+(define asm-const-queue '())
+(define (asm-word x) (queue-put! asm-code-queue (modulo x 65536)))
+(define (asm-long x) (asm-word (upper-16bits x)) (asm-word x))
+(define (asm-label lbl label-descr)
+ (queue-put! asm-code-queue (cons 'label (cons lbl label-descr))))
+(define (asm-comment x) (queue-put! asm-code-queue (cons 'comment x)))
+(define (asm-align n offset)
+ (queue-put! asm-code-queue (cons 'align (cons n offset))))
+(define (asm-ref-glob glob)
+ (queue-put!
+ asm-code-queue
+ (cons 'ref-glob (symbol->string (glob-name glob)))))
+(define (asm-set-glob glob)
+ (queue-put!
+ asm-code-queue
+ (cons 'set-glob (symbol->string (glob-name glob)))))
+(define (asm-ref-glob-jump glob)
+ (queue-put!
+ asm-code-queue
+ (cons 'ref-glob-jump (symbol->string (glob-name glob)))))
+(define (asm-proc-ref num offset)
+ (queue-put! asm-code-queue (cons 'proc-ref (cons num offset))))
+(define (asm-prim-ref proc offset)
+ (queue-put!
+ asm-code-queue
+ (cons 'prim-ref (cons (proc-obj-name proc) offset))))
+(define (asm-m68020-proc) (queue-put! asm-code-queue '(m68020-proc)))
+(define (asm-m68881-proc) (queue-put! asm-code-queue '(m68881-proc)))
+(define (asm-stat x) (queue-put! asm-code-queue (cons 'stat x)))
+(define (asm-brel type lbl)
+ (queue-put! asm-code-queue (cons 'brab (cons type lbl))))
+(define (asm-wrel lbl offs)
+ (queue-put! asm-code-queue (cons 'wrel (cons lbl offs))))
+(define (asm-lrel lbl offs n)
+ (queue-put! asm-code-queue (cons 'lrel (cons lbl (cons offs n)))))
+(define (asm-assemble! debug-info)
+ (define header-offset 2)
+ (define ref-glob-len 2)
+ (define set-glob-len 10)
+ (define ref-glob-jump-len 2)
+ (define proc-ref-len 4)
+ (define prim-ref-len 4)
+ (define stat-len 4)
+ (define (padding loc n offset) (modulo (- offset loc) n))
+ (queue-put! asm-const-queue debug-info)
+ (asm-align 4 0)
+ (emit-label const-lbl)
+ (let ((code-list (queue->list asm-code-queue))
+ (const-list (queue->list asm-const-queue)))
+ (let* ((fix-list
+ (let loop ((l code-list) (len header-offset) (x '()))
+ (if (null? l)
+ (reverse x)
+ (let ((part (car l)) (rest (cdr l)))
+ (if (pair? part)
+ (case (car part)
+ ((label align brab)
+ (loop rest 0 (cons (cons len part) x)))
+ ((wrel) (loop rest (+ len 2) x))
+ ((lrel) (loop rest (+ len 4) x))
+ ((ref-glob) (loop rest (+ len ref-glob-len) x))
+ ((set-glob) (loop rest (+ len set-glob-len) x))
+ ((ref-glob-jump)
+ (loop rest (+ len ref-glob-jump-len) x))
+ ((proc-ref) (loop rest (+ len proc-ref-len) x))
+ ((prim-ref) (loop rest (+ len prim-ref-len) x))
+ ((stat) (loop rest (+ len stat-len) x))
+ ((comment m68020-proc m68881-proc) (loop rest len x))
+ (else
+ (compiler-internal-error
+ "asm-assemble!, unknown code list element"
+ part)))
+ (loop rest (+ len 2) x))))))
+ (lbl-list
+ (let loop ((l fix-list) (x '()))
+ (if (null? l)
+ x
+ (let ((part (cdar l)) (rest (cdr l)))
+ (if (eq? (car part) 'label)
+ (loop rest (cons (cons (cadr part) part) x))
+ (loop rest x)))))))
+ (define (replace-lbl-refs-by-pointer-to-label)
+ (let loop ((l code-list))
+ (if (not (null? l))
+ (let ((part (car l)) (rest (cdr l)))
+ (if (pair? part)
+ (case (car part)
+ ((brab)
+ (set-cdr! (cdr part) (cdr (assq (cddr part) lbl-list))))
+ ((wrel)
+ (set-car! (cdr part) (cdr (assq (cadr part) lbl-list))))
+ ((lrel)
+ (set-car!
+ (cdr part)
+ (cdr (assq (cadr part) lbl-list))))))
+ (loop rest)))))
+ (define (assign-loc-to-labels)
+ (let loop ((l fix-list) (loc 0))
+ (if (not (null? l))
+ (let* ((first (car l))
+ (rest (cdr l))
+ (len (car first))
+ (cur-loc (+ loc len))
+ (part (cdr first)))
+ (case (car part)
+ ((label)
+ (if (cddr part)
+ (vector-set!
+ (cddr part)
+ 0
+ (quotient (- cur-loc header-offset) 8)))
+ (set-car! (cdr part) cur-loc)
+ (loop rest cur-loc))
+ ((align)
+ (loop rest
+ (+ cur-loc
+ (padding cur-loc (cadr part) (cddr part)))))
+ ((brab) (loop rest (+ cur-loc 2)))
+ ((braw) (loop rest (+ cur-loc 4)))
+ (else
+ (compiler-internal-error
+ "assign-loc-to-labels, unknown code list element"
+ part)))))))
+ (define (branch-tensioning-pass)
+ (assign-loc-to-labels)
+ (let loop ((changed? #f) (l fix-list) (loc 0))
+ (if (null? l)
+ (if changed? (branch-tensioning-pass))
+ (let* ((first (car l))
+ (rest (cdr l))
+ (len (car first))
+ (cur-loc (+ loc len))
+ (part (cdr first)))
+ (case (car part)
+ ((label) (loop changed? rest cur-loc))
+ ((align)
+ (loop changed?
+ rest
+ (+ cur-loc
+ (padding cur-loc (cadr part) (cddr part)))))
+ ((brab)
+ (let ((dist (- (cadr (cddr part)) (+ cur-loc 2))))
+ (if (or (< dist -128) (> dist 127) (= dist 0))
+ (begin
+ (set-car! part 'braw)
+ (loop #t rest (+ cur-loc 2)))
+ (loop changed? rest (+ cur-loc 2)))))
+ ((braw) (loop changed? rest (+ cur-loc 4)))
+ (else
+ (compiler-internal-error
+ "branch-tensioning-pass, unknown code list element"
+ part)))))))
+ (define (write-block start-loc end-loc start end)
+ (if (> end-loc start-loc)
+ (ofile-word (quotient (- end-loc start-loc) 2)))
+ (let loop ((loc start-loc) (l start))
+ (if (not (eq? l end))
+ (let ((part (car l)) (rest (cdr l)))
+ (if (pair? part)
+ (case (car part)
+ ((label) (loop loc rest))
+ ((align)
+ (let ((n (padding loc (cadr part) (cddr part))))
+ (let pad ((i 0))
+ (if (< i n)
+ (begin (ofile-word 0) (pad (+ i 2)))
+ (loop (+ loc n) rest)))))
+ ((brab)
+ (let ((dist (- (cadr (cddr part)) (+ loc 2))))
+ (ofile-word (+ (cadr part) (modulo dist 256)))
+ (loop (+ loc 2) rest)))
+ ((braw)
+ (let ((dist (- (cadr (cddr part)) (+ loc 2))))
+ (ofile-word (cadr part))
+ (ofile-word (modulo dist 65536))
+ (loop (+ loc 4) rest)))
+ ((wrel)
+ (let ((dist (+ (- (cadr (cadr part)) loc) (cddr part))))
+ (ofile-word (modulo dist 65536))
+ (loop (+ loc 2) rest)))
+ ((lrel)
+ (let ((dist (+ (- (cadr (cadr part)) loc)
+ (caddr part))))
+ (ofile-long (+ (* dist 65536) (cdddr part)))
+ (loop (+ loc 4) rest)))
+ ((comment)
+ (let ((x (cdr part)))
+ (if (pair? x) (ofile-comment x) (ofile-gvm-instr x))
+ (loop loc rest))))
+ (begin (ofile-word part) (loop (+ loc 2) rest)))))))
+ (define (write-code)
+ (let ((proc-len
+ (+ (cadr (cdr (assq const-lbl lbl-list)))
+ (* (length const-list) 4))))
+ (if (>= proc-len 32768)
+ (compiler-limitation-error
+ "procedure is too big (32K bytes limit per procedure)"))
+ (ofile-word (+ 32768 proc-len)))
+ (let loop1 ((start code-list) (start-loc header-offset))
+ (let loop2 ((end start) (loc start-loc))
+ (if (null? end)
+ (write-block start-loc loc start end)
+ (let ((part (car end)) (rest (cdr end)))
+ (if (pair? part)
+ (case (car part)
+ ((label comment) (loop2 rest loc))
+ ((align)
+ (loop2 rest
+ (+ loc (padding loc (cadr part) (cddr part)))))
+ ((brab wrel) (loop2 rest (+ loc 2)))
+ ((braw) (loop2 rest (+ loc 4)))
+ ((lrel) (loop2 rest (+ loc 4)))
+ (else
+ (write-block start-loc loc start end)
+ (case (car part)
+ ((ref-glob)
+ (ofile-wsym global-var-ref-tag (cdr part))
+ (loop1 rest (+ loc ref-glob-len)))
+ ((set-glob)
+ (ofile-wsym global-var-set-tag (cdr part))
+ (loop1 rest (+ loc set-glob-len)))
+ ((ref-glob-jump)
+ (ofile-wsym global-var-ref-jump-tag (cdr part))
+ (loop1 rest (+ loc ref-glob-jump-len)))
+ ((proc-ref)
+ (ofile-word (+ local-proc-ref-tag (cadr part)))
+ (ofile-word (cddr part))
+ (loop1 rest (+ loc proc-ref-len)))
+ ((prim-ref)
+ (ofile-wsym prim-proc-ref-tag (cadr part))
+ (ofile-word (cddr part))
+ (loop1 rest (+ loc prim-ref-len)))
+ ((m68020-proc)
+ (ofile-word m68020-proc-code-tag)
+ (loop1 rest loc))
+ ((m68881-proc)
+ (ofile-word m68881-proc-code-tag)
+ (loop1 rest loc))
+ ((stat)
+ (ofile-word stat-tag)
+ (ofile-stat (cdr part))
+ (loop1 rest (+ loc stat-len))))))
+ (loop2 rest (+ loc 2)))))))
+ (ofile-word end-of-code-tag)
+ (for-each ofile-ref const-list)
+ (ofile-long (obj-encoding (+ (length const-list) 1))))
+ (replace-lbl-refs-by-pointer-to-label)
+ (branch-tensioning-pass)
+ (write-code))))
+(define const-lbl 0)
+(define (identical-opnd68? opnd1 opnd2) (eqv? opnd1 opnd2))
+(define (reg68? x) (or (dreg? x) (areg? x)))
+(define (make-dreg num) num)
+(define (dreg? x) (and (integer? x) (>= x 0) (< x 8)))
+(define (dreg-num x) x)
+(define (make-areg num) (+ num 8))
+(define (areg? x) (and (integer? x) (>= x 8) (< x 16)))
+(define (areg-num x) (- x 8))
+(define (make-ind areg) (+ areg 8))
+(define (ind? x) (and (integer? x) (>= x 16) (< x 24)))
+(define (ind-areg x) (- x 8))
+(define (make-pinc areg) (+ areg 16))
+(define (pinc? x) (and (integer? x) (>= x 24) (< x 32)))
+(define (pinc-areg x) (- x 16))
+(define (make-pdec areg) (+ areg 24))
+(define (pdec? x) (and (integer? x) (>= x 32) (< x 40)))
+(define (pdec-areg x) (- x 24))
+(define (make-disp areg offset) (+ (+ areg 32) (* (modulo offset 65536) 8)))
+(define (disp? x) (and (integer? x) (>= x 40) (< x 524328)))
+(define (disp-areg x) (+ (remainder x 8) 8))
+(define (disp-offset x)
+ (- (modulo (+ (quotient (- x 40) 8) 32768) 65536) 32768))
+(define (make-disp* areg offset)
+ (if (= offset 0) (make-ind areg) (make-disp areg offset)))
+(define (disp*? x) (or (ind? x) (disp? x)))
+(define (disp*-areg x) (if (ind? x) (ind-areg x) (disp-areg x)))
+(define (disp*-offset x) (if (ind? x) 0 (disp-offset x)))
+(define (make-inx areg ireg offset)
+ (+ (+ areg 524320) (* ireg 8) (* (modulo offset 256) 128)))
+(define (inx? x) (and (integer? x) (>= x 524328) (< x 557096)))
+(define (inx-areg x) (+ (remainder (- x 524328) 8) 8))
+(define (inx-ireg x) (quotient (remainder (- x 524328) 128) 8))
+(define (inx-offset x)
+ (- (modulo (+ (quotient (- x 524328) 128) 128) 256) 128))
+(define (make-freg num) (+ 557096 num))
+(define (freg? x) (and (integer? x) (>= x 557096) (< x 557104)))
+(define (freg-num x) (- x 557096))
+(define (make-pcr lbl offset)
+ (+ 557104 (+ (modulo offset 65536) (* lbl 65536))))
+(define (pcr? x) (and (integer? x) (>= x 557104)))
+(define (pcr-lbl x) (quotient (- x 557104) 65536))
+(define (pcr-offset x) (- (modulo (- x 524336) 65536) 32768))
+(define (make-imm val) (if (< val 0) (* val 2) (- -1 (* val 2))))
+(define (imm? x) (and (integer? x) (< x 0)))
+(define (imm-val x) (if (even? x) (quotient x 2) (- (quotient x 2))))
+(define (make-glob name) name)
+(define (glob? x) (symbol? x))
+(define (glob-name x) x)
+(define (make-frame-base-rel slot) (make-disp sp-reg slot))
+(define (frame-base-rel? x)
+ (and (disp? x) (identical-opnd68? sp-reg (disp-areg x))))
+(define (frame-base-rel-slot x) (disp-offset x))
+(define (make-reg-list regs) regs)
+(define (reg-list? x) (or (pair? x) (null? x)))
+(define (reg-list-regs x) x)
+(define first-dtemp 0)
+(define gvm-reg1 1)
+(define poll-timer-reg (make-dreg 5))
+(define null-reg (make-dreg 6))
+(define placeholder-reg (make-dreg 6))
+(define false-reg (make-dreg 7))
+(define pair-reg (make-dreg 7))
+(define gvm-reg0 0)
+(define first-atemp 1)
+(define heap-reg (make-areg 3))
+(define ltq-tail-reg (make-areg 4))
+(define pstate-reg (make-areg 5))
+(define table-reg (make-areg 6))
+(define sp-reg (make-areg 7))
+(define pdec-sp (make-pdec sp-reg))
+(define pinc-sp (make-pinc sp-reg))
+(define dtemp1 (make-dreg first-dtemp))
+(define atemp1 (make-areg first-atemp))
+(define atemp2 (make-areg (+ first-atemp 1)))
+(define ftemp1 (make-freg 0))
+(define arg-count-reg dtemp1)
+(define (trap-offset n) (+ 32768 (* (- n 32) 8)))
+(define (emit-move.l opnd1 opnd2)
+ (let ((src (opnd->mode/reg opnd1)) (dst (opnd->reg/mode opnd2)))
+ (asm-word (+ 8192 (+ dst src)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-wr-long opnd2)
+ (if ofile-asm?
+ (emit-asm "movl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))
+(define (emit-move.w opnd1 opnd2)
+ (let ((src (opnd->mode/reg opnd1)) (dst (opnd->reg/mode opnd2)))
+ (asm-word (+ 12288 (+ dst src)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-wr-word opnd2)
+ (if ofile-asm?
+ (emit-asm "movw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))
+(define (emit-move.b opnd1 opnd2)
+ (let ((src (opnd->mode/reg opnd1)) (dst (opnd->reg/mode opnd2)))
+ (asm-word (+ 4096 (+ dst src)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-wr-word opnd2)
+ (if ofile-asm?
+ (emit-asm "movb" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2)))))
+(define (emit-moveq n opnd)
+ (asm-word (+ 28672 (+ (* (dreg-num opnd) 512) (modulo n 256))))
+ (if ofile-asm? (emit-asm "moveq" ofile-tab "#" n "," (opnd-str opnd))))
+(define (emit-movem.l opnd1 opnd2)
+ (define (reg-mask reg-list flip-bits?)
+ (let loop ((i 15) (bit 32768) (mask 0))
+ (if (>= i 0)
+ (loop (- i 1)
+ (quotient bit 2)
+ (if (memq i reg-list)
+ (+ mask (if flip-bits? (quotient 32768 bit) bit))
+ mask))
+ mask)))
+ (define (movem op reg-list opnd)
+ (asm-word (+ op (opnd->mode/reg opnd)))
+ (asm-word (reg-mask reg-list (pdec? opnd))))
+ (if (reg-list? opnd1)
+ (begin (movem 18624 opnd1 opnd2) (opnd-ext-wr-long opnd2))
+ (begin (movem 19648 opnd2 opnd1) (opnd-ext-rd-long opnd1)))
+ (if ofile-asm?
+ (emit-asm "moveml" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-exg opnd1 opnd2)
+ (define (exg r1 r2)
+ (let ((mode (if (dreg? r2) 49472 (if (dreg? r1) 49544 49480)))
+ (num1 (if (dreg? r1) (dreg-num r1) (areg-num r1)))
+ (num2 (if (dreg? r2) (dreg-num r2) (areg-num r2))))
+ (asm-word (+ mode (+ (* num1 512) num2)))))
+ (if (dreg? opnd2) (exg opnd2 opnd1) (exg opnd1 opnd2))
+ (if ofile-asm?
+ (emit-asm "exg" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-eor.l opnd1 opnd2)
+ (cond ((imm? opnd1)
+ (asm-word (+ 2688 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-wr-long opnd2))
+ (else
+ (asm-word
+ (+ 45440 (+ (* (dreg-num opnd1) 512) (opnd->mode/reg opnd2))))
+ (opnd-ext-wr-long opnd2)))
+ (if ofile-asm?
+ (emit-asm "eorl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-and.l opnd1 opnd2)
+ (cond ((imm? opnd1)
+ (asm-word (+ 640 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-wr-long opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 49280 49536))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-long other)
+ (opnd-ext-wr-long other)))))
+ (if ofile-asm?
+ (emit-asm "andl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-and.w opnd1 opnd2)
+ (cond ((imm? opnd1)
+ (asm-word (+ 576 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-wr-word opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 49216 49472))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-word other)
+ (opnd-ext-wr-word other)))))
+ (if ofile-asm?
+ (emit-asm "andw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-or.l opnd1 opnd2)
+ (cond ((imm? opnd1)
+ (asm-word (+ 128 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-wr-long opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 32896 33152))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-long other)
+ (opnd-ext-wr-long other)))))
+ (if ofile-asm?
+ (emit-asm "orl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-addq.l n opnd)
+ (let ((m (if (= n 8) 0 n)))
+ (asm-word (+ 20608 (* m 512) (opnd->mode/reg opnd)))
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm? (emit-asm "addql" ofile-tab "#" n "," (opnd-str opnd)))))
+(define (emit-addq.w n opnd)
+ (let ((m (if (= n 8) 0 n)))
+ (asm-word (+ 20544 (* m 512) (opnd->mode/reg opnd)))
+ (opnd-ext-wr-word opnd)
+ (if ofile-asm? (emit-asm "addqw" ofile-tab "#" n "," (opnd-str opnd)))))
+(define (emit-add.l opnd1 opnd2)
+ (cond ((areg? opnd2)
+ (asm-word
+ (+ 53696 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-long opnd1))
+ ((imm? opnd1)
+ (asm-word (+ 1664 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-wr-long opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 53376 53632))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-long other)
+ (opnd-ext-wr-long other)))))
+ (if ofile-asm?
+ (emit-asm "addl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-add.w opnd1 opnd2)
+ (cond ((areg? opnd2)
+ (asm-word
+ (+ 53440 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-word opnd1))
+ ((imm? opnd1)
+ (asm-word (+ 1600 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-wr-word opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 53312 53568))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-word other)
+ (opnd-ext-wr-word other)))))
+ (if ofile-asm?
+ (emit-asm "addw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-addx.w opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 53568 (+ (* (dreg-num opnd2) 512) (dreg-num opnd1))))
+ (asm-word
+ (+ 53576
+ (+ (* (areg-num (pdec-areg opnd2)) 512)
+ (areg-num (pdec-areg opnd1))))))
+ (if ofile-asm?
+ (emit-asm "addxw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-subq.l n opnd)
+ (let ((m (if (= n 8) 0 n)))
+ (asm-word (+ 20864 (* m 512) (opnd->mode/reg opnd)))
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm? (emit-asm "subql" ofile-tab "#" n "," (opnd-str opnd)))))
+(define (emit-subq.w n opnd)
+ (let ((m (if (= n 8) 0 n)))
+ (asm-word (+ 20800 (* m 512) (opnd->mode/reg opnd)))
+ (opnd-ext-wr-word opnd)
+ (if ofile-asm? (emit-asm "subqw" ofile-tab "#" n "," (opnd-str opnd)))))
+(define (emit-sub.l opnd1 opnd2)
+ (cond ((areg? opnd2)
+ (asm-word
+ (+ 37312 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-long opnd1))
+ ((imm? opnd1)
+ (asm-word (+ 1152 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-wr-long opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 36992 37248))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-long other)
+ (opnd-ext-wr-long other)))))
+ (if ofile-asm?
+ (emit-asm "subl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-sub.w opnd1 opnd2)
+ (cond ((areg? opnd2)
+ (asm-word
+ (+ 37056 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-word opnd1))
+ ((imm? opnd1)
+ (asm-word (+ 1088 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-wr-word opnd2))
+ (else
+ (let ((mode (if (dreg? opnd2) 36928 37184))
+ (reg (if (dreg? opnd2) (dreg-num opnd2) (dreg-num opnd1)))
+ (other (if (dreg? opnd2) opnd1 opnd2)))
+ (asm-word (+ mode (+ (* reg 512) (opnd->mode/reg other))))
+ (if (dreg? opnd2)
+ (opnd-ext-rd-word other)
+ (opnd-ext-wr-word other)))))
+ (if ofile-asm?
+ (emit-asm "subw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-asl.l opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57760 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57728 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "asll" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-asl.w opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57696 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57664 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "aslw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-asr.l opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57504 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57472 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "asrl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-asr.w opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57440 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57408 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "asrw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-lsl.l opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57768 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57736 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "lsll" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-lsr.l opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57512 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57480 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "lsrl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-lsr.w opnd1 opnd2)
+ (if (dreg? opnd1)
+ (asm-word (+ 57448 (+ (* (dreg-num opnd1) 512) (dreg-num opnd2))))
+ (let ((n (imm-val opnd1)))
+ (asm-word (+ 57416 (+ (* (if (= n 8) 0 n) 512) (dreg-num opnd2))))))
+ (if ofile-asm?
+ (emit-asm "lsrw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-clr.l opnd)
+ (asm-word (+ 17024 (opnd->mode/reg opnd)))
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm? (emit-asm "clrl" ofile-tab (opnd-str opnd))))
+(define (emit-neg.l opnd)
+ (asm-word (+ 17536 (opnd->mode/reg opnd)))
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm? (emit-asm "negl" ofile-tab (opnd-str opnd))))
+(define (emit-not.l opnd)
+ (asm-word (+ 18048 (opnd->mode/reg opnd)))
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm? (emit-asm "notl" ofile-tab (opnd-str opnd))))
+(define (emit-ext.l opnd)
+ (asm-word (+ 18624 (dreg-num opnd)))
+ (if ofile-asm? (emit-asm "extl" ofile-tab (opnd-str opnd))))
+(define (emit-ext.w opnd)
+ (asm-word (+ 18560 (dreg-num opnd)))
+ (if ofile-asm? (emit-asm "extw" ofile-tab (opnd-str opnd))))
+(define (emit-swap opnd)
+ (asm-word (+ 18496 (dreg-num opnd)))
+ (if ofile-asm? (emit-asm "swap" ofile-tab (opnd-str opnd))))
+(define (emit-cmp.l opnd1 opnd2)
+ (cond ((areg? opnd2)
+ (asm-word
+ (+ 45504 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-long opnd1))
+ ((imm? opnd1)
+ (asm-word (+ 3200 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (opnd-ext-rd-long opnd2))
+ (else
+ (asm-word
+ (+ 45184 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-long opnd1)))
+ (if ofile-asm?
+ (emit-asm "cmpl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-cmp.w opnd1 opnd2)
+ (cond ((areg? opnd2)
+ (asm-word
+ (+ 45248 (+ (* (areg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-word opnd1))
+ ((imm? opnd1)
+ (asm-word (+ 3136 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-rd-word opnd2))
+ (else
+ (asm-word
+ (+ 45120 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-word opnd1)))
+ (if ofile-asm?
+ (emit-asm "cmpw" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-cmp.b opnd1 opnd2)
+ (cond ((imm? opnd1)
+ (asm-word (+ 3072 (opnd->mode/reg opnd2)))
+ (opnd-ext-rd-word opnd1)
+ (opnd-ext-rd-word opnd2))
+ (else
+ (asm-word
+ (+ 45056 (+ (* (dreg-num opnd2) 512) (opnd->mode/reg opnd1))))
+ (opnd-ext-rd-word opnd1)))
+ (if ofile-asm?
+ (emit-asm "cmpb" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-tst.l opnd)
+ (asm-word (+ 19072 (opnd->mode/reg opnd)))
+ (opnd-ext-rd-long opnd)
+ (if ofile-asm? (emit-asm "tstl" ofile-tab (opnd-str opnd))))
+(define (emit-tst.w opnd)
+ (asm-word (+ 19008 (opnd->mode/reg opnd)))
+ (opnd-ext-rd-word opnd)
+ (if ofile-asm? (emit-asm "tstw" ofile-tab (opnd-str opnd))))
+(define (emit-lea opnd areg)
+ (asm-word (+ 16832 (+ (* (areg-num areg) 512) (opnd->mode/reg opnd))))
+ (opnd-ext-rd-long opnd)
+ (if ofile-asm?
+ (emit-asm "lea" ofile-tab (opnd-str opnd) "," (opnd-str areg))))
+(define (emit-unlk areg)
+ (asm-word (+ 20056 (areg-num areg)))
+ (if ofile-asm? (emit-asm "unlk" ofile-tab (opnd-str areg))))
+(define (emit-move-proc num opnd)
+ (let ((dst (opnd->reg/mode opnd)))
+ (asm-word (+ 8192 (+ dst 60)))
+ (asm-proc-ref num 0)
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm? (emit-asm "MOVE_PROC(" num "," (opnd-str opnd) ")"))))
+(define (emit-move-prim val opnd)
+ (let ((dst (opnd->reg/mode opnd)))
+ (asm-word (+ 8192 (+ dst 60)))
+ (asm-prim-ref val 0)
+ (opnd-ext-wr-long opnd)
+ (if ofile-asm?
+ (emit-asm "MOVE_PRIM(" (proc-obj-name val) "," (opnd-str opnd) ")"))))
+(define (emit-pea opnd)
+ (asm-word (+ 18496 (opnd->mode/reg opnd)))
+ (opnd-ext-rd-long opnd)
+ (if ofile-asm? (emit-asm "pea" ofile-tab (opnd-str opnd))))
+(define (emit-pea* n)
+ (asm-word 18552)
+ (asm-word n)
+ (if ofile-asm? (emit-asm "pea" ofile-tab n)))
+(define (emit-btst opnd1 opnd2)
+ (asm-word (+ 256 (+ (* (dreg-num opnd1) 512) (opnd->mode/reg opnd2))))
+ (opnd-ext-rd-word opnd2)
+ (if ofile-asm?
+ (emit-asm "btst" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-bra lbl)
+ (asm-brel 24576 lbl)
+ (if ofile-asm? (emit-asm "bra" ofile-tab "L" lbl)))
+(define (emit-bcc lbl)
+ (asm-brel 25600 lbl)
+ (if ofile-asm? (emit-asm "bcc" ofile-tab "L" lbl)))
+(define (emit-bcs lbl)
+ (asm-brel 25856 lbl)
+ (if ofile-asm? (emit-asm "bcs" ofile-tab "L" lbl)))
+(define (emit-bhi lbl)
+ (asm-brel 25088 lbl)
+ (if ofile-asm? (emit-asm "bhi" ofile-tab "L" lbl)))
+(define (emit-bls lbl)
+ (asm-brel 25344 lbl)
+ (if ofile-asm? (emit-asm "bls" ofile-tab "L" lbl)))
+(define (emit-bmi lbl)
+ (asm-brel 27392 lbl)
+ (if ofile-asm? (emit-asm "bmi" ofile-tab "L" lbl)))
+(define (emit-bpl lbl)
+ (asm-brel 27136 lbl)
+ (if ofile-asm? (emit-asm "bpl" ofile-tab "L" lbl)))
+(define (emit-beq lbl)
+ (asm-brel 26368 lbl)
+ (if ofile-asm? (emit-asm "beq" ofile-tab "L" lbl)))
+(define (emit-bne lbl)
+ (asm-brel 26112 lbl)
+ (if ofile-asm? (emit-asm "bne" ofile-tab "L" lbl)))
+(define (emit-blt lbl)
+ (asm-brel 27904 lbl)
+ (if ofile-asm? (emit-asm "blt" ofile-tab "L" lbl)))
+(define (emit-bgt lbl)
+ (asm-brel 28160 lbl)
+ (if ofile-asm? (emit-asm "bgt" ofile-tab "L" lbl)))
+(define (emit-ble lbl)
+ (asm-brel 28416 lbl)
+ (if ofile-asm? (emit-asm "ble" ofile-tab "L" lbl)))
+(define (emit-bge lbl)
+ (asm-brel 27648 lbl)
+ (if ofile-asm? (emit-asm "bge" ofile-tab "L" lbl)))
+(define (emit-dbra dreg lbl)
+ (asm-word (+ 20936 dreg))
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "dbra" ofile-tab (opnd-str dreg) ",L" lbl)))
+(define (emit-trap num)
+ (asm-word (+ 20032 num))
+ (if ofile-asm? (emit-asm "trap" ofile-tab "#" num)))
+(define (emit-trap1 num args)
+ (asm-word (+ 20136 (areg-num table-reg)))
+ (asm-word (trap-offset num))
+ (let loop ((args args))
+ (if (not (null? args)) (begin (asm-word (car args)) (loop (cdr args)))))
+ (if ofile-asm?
+ (let ()
+ (define (words l)
+ (if (null? l) (list ")") (cons "," (cons (car l) (words (cdr l))))))
+ (apply emit-asm (cons "TRAP1(" (cons num (words args)))))))
+(define (emit-trap2 num args)
+ (asm-word (+ 20136 (areg-num table-reg)))
+ (asm-word (trap-offset num))
+ (asm-align 8 (modulo (- 4 (* (length args) 2)) 8))
+ (let loop ((args args))
+ (if (not (null? args)) (begin (asm-word (car args)) (loop (cdr args)))))
+ (if ofile-asm?
+ (let ()
+ (define (words l)
+ (if (null? l) (list ")") (cons "," (cons (car l) (words (cdr l))))))
+ (apply emit-asm (cons "TRAP2(" (cons num (words args)))))))
+(define (emit-trap3 num)
+ (asm-word (+ 20200 (areg-num table-reg)))
+ (asm-word (trap-offset num))
+ (if ofile-asm? (emit-asm "TRAP3(" num ")")))
+(define (emit-rts) (asm-word 20085) (if ofile-asm? (emit-asm "rts")))
+(define (emit-nop) (asm-word 20081) (if ofile-asm? (emit-asm "nop")))
+(define (emit-jmp opnd)
+ (asm-word (+ 20160 (opnd->mode/reg opnd)))
+ (opnd-ext-rd-long opnd)
+ (if ofile-asm? (emit-asm "jmp" ofile-tab (opnd-str opnd))))
+(define (emit-jmp-glob glob)
+ (asm-word 8814)
+ (asm-ref-glob-jump glob)
+ (asm-word 20177)
+ (if ofile-asm? (emit-asm "JMP_GLOB(" (glob-name glob) ")")))
+(define (emit-jmp-proc num offset)
+ (asm-word 20217)
+ (asm-proc-ref num offset)
+ (if ofile-asm? (emit-asm "JMP_PROC(" num "," offset ")")))
+(define (emit-jmp-prim val offset)
+ (asm-word 20217)
+ (asm-prim-ref val offset)
+ (if ofile-asm? (emit-asm "JMP_PRIM(" (proc-obj-name val) "," offset ")")))
+(define (emit-jsr opnd)
+ (asm-word (+ 20096 (opnd->mode/reg opnd)))
+ (opnd-ext-rd-long opnd)
+ (if ofile-asm? (emit-asm "jsr" ofile-tab (opnd-str opnd))))
+(define (emit-word n)
+ (asm-word n)
+ (if ofile-asm? (emit-asm ".word" ofile-tab n)))
+(define (emit-label lbl)
+ (asm-label lbl #f)
+ (if ofile-asm? (emit-asm* "L" lbl ":")))
+(define (emit-label-subproc lbl parent-lbl label-descr)
+ (asm-align 8 0)
+ (asm-wrel parent-lbl (- 32768 type-procedure))
+ (asm-label lbl label-descr)
+ (if ofile-asm?
+ (begin (emit-asm "SUBPROC(L" parent-lbl ")") (emit-asm* "L" lbl ":"))))
+(define (emit-label-return lbl parent-lbl fs link label-descr)
+ (asm-align 8 4)
+ (asm-word (* fs 4))
+ (asm-word (* (- fs link) 4))
+ (asm-wrel parent-lbl (- 32768 type-procedure))
+ (asm-label lbl label-descr)
+ (if ofile-asm?
+ (begin
+ (emit-asm "RETURN(L" parent-lbl "," fs "," link ")")
+ (emit-asm* "L" lbl ":"))))
+(define (emit-label-task-return lbl parent-lbl fs link label-descr)
+ (asm-align 8 4)
+ (asm-word (+ 32768 (* fs 4)))
+ (asm-word (* (- fs link) 4))
+ (asm-wrel parent-lbl (- 32768 type-procedure))
+ (asm-label lbl label-descr)
+ (if ofile-asm?
+ (begin
+ (emit-asm "TASK_RETURN(L" parent-lbl "," fs "," link ")")
+ (emit-asm* "L" lbl ":"))))
+(define (emit-lbl-ptr lbl)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "LBL_PTR(L" lbl ")")))
+(define (emit-set-glob glob)
+ (asm-set-glob glob)
+ (if ofile-asm? (emit-asm "SET_GLOB(" (glob-name glob) ")")))
+(define (emit-const obj)
+ (let ((n (pos-in-list obj (queue->list asm-const-queue))))
+ (if n
+ (make-pcr const-lbl (* n 4))
+ (let ((m (length (queue->list asm-const-queue))))
+ (queue-put! asm-const-queue obj)
+ (make-pcr const-lbl (* m 4))))))
+(define (emit-stat stat)
+ (asm-word 21177)
+ (asm-stat stat)
+ (if ofile-asm? (emit-asm "STAT(" stat ")")))
+(define (emit-asm . l) (asm-comment (cons ofile-tab l)))
+(define (emit-asm* . l) (asm-comment l))
+(define (emit-muls.l opnd1 opnd2)
+ (asm-m68020-proc)
+ (asm-word (+ 19456 (opnd->mode/reg opnd1)))
+ (asm-word (+ 2048 (* (dreg-num opnd2) 4096)))
+ (opnd-ext-rd-long opnd1)
+ (if ofile-asm?
+ (emit-asm "mulsl" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-divsl.l opnd1 opnd2 opnd3)
+ (asm-m68020-proc)
+ (asm-word (+ 19520 (opnd->mode/reg opnd1)))
+ (asm-word (+ 2048 (* (dreg-num opnd3) 4096) (dreg-num opnd2)))
+ (opnd-ext-rd-long opnd1)
+ (if ofile-asm?
+ (emit-asm
+ "divsll"
+ ofile-tab
+ (opnd-str opnd1)
+ ","
+ (opnd-str opnd2)
+ ":"
+ (opnd-str opnd3))))
+(define (emit-fint.dx opnd1 opnd2) (emit-fop.dx "int" 1 opnd1 opnd2))
+(define (emit-fsinh.dx opnd1 opnd2) (emit-fop.dx "sinh" 2 opnd1 opnd2))
+(define (emit-fintrz.dx opnd1 opnd2) (emit-fop.dx "intrz" 3 opnd1 opnd2))
+(define (emit-fsqrt.dx opnd1 opnd2) (emit-fop.dx "sqrt" 4 opnd1 opnd2))
+(define (emit-flognp1.dx opnd1 opnd2) (emit-fop.dx "lognp1" 6 opnd1 opnd2))
+(define (emit-fetoxm1.dx opnd1 opnd2) (emit-fop.dx "etoxm1" 8 opnd1 opnd2))
+(define (emit-ftanh.dx opnd1 opnd2) (emit-fop.dx "tanh" 9 opnd1 opnd2))
+(define (emit-fatan.dx opnd1 opnd2) (emit-fop.dx "atan" 10 opnd1 opnd2))
+(define (emit-fasin.dx opnd1 opnd2) (emit-fop.dx "asin" 12 opnd1 opnd2))
+(define (emit-fatanh.dx opnd1 opnd2) (emit-fop.dx "atanh" 13 opnd1 opnd2))
+(define (emit-fsin.dx opnd1 opnd2) (emit-fop.dx "sin" 14 opnd1 opnd2))
+(define (emit-ftan.dx opnd1 opnd2) (emit-fop.dx "tan" 15 opnd1 opnd2))
+(define (emit-fetox.dx opnd1 opnd2) (emit-fop.dx "etox" 16 opnd1 opnd2))
+(define (emit-ftwotox.dx opnd1 opnd2) (emit-fop.dx "twotox" 17 opnd1 opnd2))
+(define (emit-ftentox.dx opnd1 opnd2) (emit-fop.dx "tentox" 18 opnd1 opnd2))
+(define (emit-flogn.dx opnd1 opnd2) (emit-fop.dx "logn" 20 opnd1 opnd2))
+(define (emit-flog10.dx opnd1 opnd2) (emit-fop.dx "log10" 21 opnd1 opnd2))
+(define (emit-flog2.dx opnd1 opnd2) (emit-fop.dx "log2" 22 opnd1 opnd2))
+(define (emit-fabs.dx opnd1 opnd2) (emit-fop.dx "abs" 24 opnd1 opnd2))
+(define (emit-fcosh.dx opnd1 opnd2) (emit-fop.dx "cosh" 25 opnd1 opnd2))
+(define (emit-fneg.dx opnd1 opnd2) (emit-fop.dx "neg" 26 opnd1 opnd2))
+(define (emit-facos.dx opnd1 opnd2) (emit-fop.dx "acos" 28 opnd1 opnd2))
+(define (emit-fcos.dx opnd1 opnd2) (emit-fop.dx "cos" 29 opnd1 opnd2))
+(define (emit-fgetexp.dx opnd1 opnd2) (emit-fop.dx "getexp" 30 opnd1 opnd2))
+(define (emit-fgetman.dx opnd1 opnd2) (emit-fop.dx "getman" 31 opnd1 opnd2))
+(define (emit-fdiv.dx opnd1 opnd2) (emit-fop.dx "div" 32 opnd1 opnd2))
+(define (emit-fmod.dx opnd1 opnd2) (emit-fop.dx "mod" 33 opnd1 opnd2))
+(define (emit-fadd.dx opnd1 opnd2) (emit-fop.dx "add" 34 opnd1 opnd2))
+(define (emit-fmul.dx opnd1 opnd2) (emit-fop.dx "mul" 35 opnd1 opnd2))
+(define (emit-fsgldiv.dx opnd1 opnd2) (emit-fop.dx "sgldiv" 36 opnd1 opnd2))
+(define (emit-frem.dx opnd1 opnd2) (emit-fop.dx "rem" 37 opnd1 opnd2))
+(define (emit-fscale.dx opnd1 opnd2) (emit-fop.dx "scale" 38 opnd1 opnd2))
+(define (emit-fsglmul.dx opnd1 opnd2) (emit-fop.dx "sglmul" 39 opnd1 opnd2))
+(define (emit-fsub.dx opnd1 opnd2) (emit-fop.dx "sub" 40 opnd1 opnd2))
+(define (emit-fcmp.dx opnd1 opnd2) (emit-fop.dx "cmp" 56 opnd1 opnd2))
+(define (emit-fop.dx name code opnd1 opnd2)
+ (asm-m68881-proc)
+ (asm-word (+ 61952 (opnd->mode/reg opnd1)))
+ (asm-word
+ (+ (if (freg? opnd1) (* (freg-num opnd1) 1024) 21504)
+ (* (freg-num opnd2) 128)
+ code))
+ (opnd-ext-rd-long opnd1)
+ (if ofile-asm?
+ (emit-asm
+ "f"
+ name
+ (if (freg? opnd1) "x" "d")
+ ofile-tab
+ (opnd-str opnd1)
+ ","
+ (opnd-str opnd2))))
+(define (emit-fmov.dx opnd1 opnd2)
+ (emit-fmov
+ (if (and (freg? opnd1) (freg? opnd2)) (* (freg-num opnd1) 1024) 21504)
+ opnd1
+ opnd2)
+ (if ofile-asm?
+ (emit-asm
+ (if (and (freg? opnd1) (freg? opnd2)) "fmovex" "fmoved")
+ ofile-tab
+ (opnd-str opnd1)
+ ","
+ (opnd-str opnd2))))
+(define (emit-fmov.l opnd1 opnd2)
+ (emit-fmov 16384 opnd1 opnd2)
+ (if ofile-asm?
+ (emit-asm "fmovel" ofile-tab (opnd-str opnd1) "," (opnd-str opnd2))))
+(define (emit-fmov code opnd1 opnd2)
+ (define (fmov code opnd1 opnd2)
+ (asm-m68881-proc)
+ (asm-word (+ 61952 (opnd->mode/reg opnd1)))
+ (asm-word (+ (* (freg-num opnd2) 128) code))
+ (opnd-ext-rd-long opnd1))
+ (if (freg? opnd2) (fmov code opnd1 opnd2) (fmov (+ code 8192) opnd2 opnd1)))
+(define (emit-fbeq lbl)
+ (asm-m68881-proc)
+ (asm-word 62081)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "fbeq" ofile-tab "L" lbl)))
+(define (emit-fbne lbl)
+ (asm-m68881-proc)
+ (asm-word 62094)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "fbne" ofile-tab "L" lbl)))
+(define (emit-fblt lbl)
+ (asm-m68881-proc)
+ (asm-word 62100)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "fblt" ofile-tab "L" lbl)))
+(define (emit-fbgt lbl)
+ (asm-m68881-proc)
+ (asm-word 62098)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "fbgt" ofile-tab "L" lbl)))
+(define (emit-fble lbl)
+ (asm-m68881-proc)
+ (asm-word 62101)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "fble" ofile-tab "L" lbl)))
+(define (emit-fbge lbl)
+ (asm-m68881-proc)
+ (asm-word 62099)
+ (asm-wrel lbl 0)
+ (if ofile-asm? (emit-asm "fbge" ofile-tab "L" lbl)))
+(define (opnd->mode/reg opnd)
+ (cond ((disp? opnd) (+ 32 (disp-areg opnd)))
+ ((inx? opnd) (+ 40 (inx-areg opnd)))
+ ((pcr? opnd) 58)
+ ((imm? opnd) 60)
+ ((glob? opnd) (+ 32 table-reg))
+ ((freg? opnd) 0)
+ (else opnd)))
+(define (opnd->reg/mode opnd)
+ (let ((x (opnd->mode/reg opnd)))
+ (* (+ (* 8 (remainder x 8)) (quotient x 8)) 64)))
+(define (opnd-ext-rd-long opnd) (opnd-extension opnd #f #f))
+(define (opnd-ext-rd-word opnd) (opnd-extension opnd #f #t))
+(define (opnd-ext-wr-long opnd) (opnd-extension opnd #t #f))
+(define (opnd-ext-wr-word opnd) (opnd-extension opnd #t #t))
+(define (opnd-extension opnd write? word?)
+ (cond ((disp? opnd) (asm-word (disp-offset opnd)))
+ ((inx? opnd)
+ (asm-word
+ (+ (+ (* (inx-ireg opnd) 4096) 2048)
+ (modulo (inx-offset opnd) 256))))
+ ((pcr? opnd) (asm-wrel (pcr-lbl opnd) (pcr-offset opnd)))
+ ((imm? opnd)
+ (if word? (asm-word (imm-val opnd)) (asm-long (imm-val opnd))))
+ ((glob? opnd) (if write? (asm-set-glob opnd) (asm-ref-glob opnd)))))
+(define (opnd-str opnd)
+ (cond ((dreg? opnd)
+ (vector-ref
+ '#("d0" "d1" "d2" "d3" "d4" "d5" "d6" "d7")
+ (dreg-num opnd)))
+ ((areg? opnd)
+ (vector-ref
+ '#("a0" "a1" "a2" "a3" "a4" "a5" "a6" "sp")
+ (areg-num opnd)))
+ ((ind? opnd)
+ (vector-ref
+ '#("a0@" "a1@" "a2@" "a3@" "a4@" "a5@" "a6@" "sp@")
+ (areg-num (ind-areg opnd))))
+ ((pinc? opnd)
+ (vector-ref
+ '#("a0@+" "a1@+" "a2@+" "a3@+" "a4@+" "a5@+" "a6@+" "sp@+")
+ (areg-num (pinc-areg opnd))))
+ ((pdec? opnd)
+ (vector-ref
+ '#("a0@-" "a1@-" "a2@-" "a3@-" "a4@-" "a5@-" "a6@-" "sp@-")
+ (areg-num (pdec-areg opnd))))
+ ((disp? opnd)
+ (string-append
+ (opnd-str (disp-areg opnd))
+ "@("
+ (number->string (disp-offset opnd))
+ ")"))
+ ((inx? opnd)
+ (string-append
+ (opnd-str (inx-areg opnd))
+ "@("
+ (number->string (inx-offset opnd))
+ ","
+ (opnd-str (inx-ireg opnd))
+ ":l)"))
+ ((pcr? opnd)
+ (let ((lbl (pcr-lbl opnd)) (offs (pcr-offset opnd)))
+ (if (= offs 0)
+ (string-append "L" (number->string lbl))
+ (string-append
+ "L"
+ (number->string lbl)
+ "+"
+ (number->string offs)))))
+ ((imm? opnd) (string-append "#" (number->string (imm-val opnd))))
+ ((glob? opnd)
+ (string-append "GLOB(" (symbol->string (glob-name opnd)) ")"))
+ ((freg? opnd)
+ (vector-ref
+ '#("fp0" "fp1" "fp2" "fp3" "fp4" "fp5" "fp6" "fp7")
+ (freg-num opnd)))
+ ((reg-list? opnd)
+ (let loop ((l (reg-list-regs opnd)) (result "[") (sep ""))
+ (if (pair? l)
+ (loop (cdr l) (string-append result sep (opnd-str (car l))) "/")
+ (string-append result "]"))))
+ (else (compiler-internal-error "opnd-str, unknown 'opnd'" opnd))))
+(define (begin! info-port targ)
+ (set! return-reg (make-reg 0))
+ (target-end!-set! targ end!)
+ (target-dump-set! targ dump)
+ (target-nb-regs-set! targ nb-gvm-regs)
+ (target-prim-info-set! targ prim-info)
+ (target-label-info-set! targ label-info)
+ (target-jump-info-set! targ jump-info)
+ (target-proc-result-set! targ (make-reg 1))
+ (target-task-return-set! targ return-reg)
+ (set! *info-port* info-port)
+ '())
+(define (end!) '())
+(define *info-port* '())
+(define nb-gvm-regs 5)
+(define nb-arg-regs 3)
+(define pointer-size 4)
+(define prim-proc-table
+ (map (lambda (x)
+ (cons (string->canonical-symbol (car x))
+ (apply make-proc-obj (car x) #t #f (cdr x))))
+ prim-procs))
+(define (prim-info name)
+ (let ((x (assq name prim-proc-table))) (if x (cdr x) #f)))
+(define (get-prim-info name)
+ (let ((proc (prim-info (string->canonical-symbol name))))
+ (if proc
+ proc
+ (compiler-internal-error "get-prim-info, unknown primitive:" name))))
+(define (label-info min-args nb-parms rest? closed?)
+ (let ((nb-stacked (max 0 (- nb-parms nb-arg-regs))))
+ (define (location-of-parms i)
+ (if (> i nb-parms)
+ '()
+ (cons (cons i
+ (if (> i nb-stacked)
+ (make-reg (- i nb-stacked))
+ (make-stk i)))
+ (location-of-parms (+ i 1)))))
+ (let ((x (cons (cons 'return 0) (location-of-parms 1))))
+ (make-pcontext
+ nb-stacked
+ (if closed?
+ (cons (cons 'closure-env (make-reg (+ nb-arg-regs 1))) x)
+ x)))))
+(define (jump-info nb-args)
+ (let ((nb-stacked (max 0 (- nb-args nb-arg-regs))))
+ (define (location-of-args i)
+ (if (> i nb-args)
+ '()
+ (cons (cons i
+ (if (> i nb-stacked)
+ (make-reg (- i nb-stacked))
+ (make-stk i)))
+ (location-of-args (+ i 1)))))
+ (make-pcontext
+ nb-stacked
+ (cons (cons 'return (make-reg 0)) (location-of-args 1)))))
+(define (closed-var-offset i) (+ (* i pointer-size) 2))
+(define (dump proc filename c-intf options)
+ (if *info-port*
+ (begin (display "Dumping:" *info-port*) (newline *info-port*)))
+ (set! ofile-asm? (memq 'asm options))
+ (set! ofile-stats? (memq 'stats options))
+ (set! debug-info? (memq 'debug options))
+ (set! object-queue (queue-empty))
+ (set! objects-dumped (queue-empty))
+ (ofile.begin! filename add-object)
+ (queue-put! object-queue proc)
+ (queue-put! objects-dumped proc)
+ (let loop ((index 0))
+ (if (not (queue-empty? object-queue))
+ (let ((obj (queue-get! object-queue)))
+ (dump-object obj index)
+ (loop (+ index 1)))))
+ (ofile.end!)
+ (if *info-port* (newline *info-port*))
+ (set! object-queue '())
+ (set! objects-dumped '()))
+(define debug-info? '())
+(define object-queue '())
+(define objects-dumped '())
+(define (add-object obj)
+ (if (and (proc-obj? obj) (not (proc-obj-code obj)))
+ #f
+ (let ((n (pos-in-list obj (queue->list objects-dumped))))
+ (if n
+ n
+ (let ((m (length (queue->list objects-dumped))))
+ (queue-put! objects-dumped obj)
+ (queue-put! object-queue obj)
+ m)))))
+(define (dump-object obj index)
+ (ofile-line "|------------------------------------------------------")
+ (case (obj-type obj)
+ ((pair) (dump-pair obj))
+ ((flonum) (dump-flonum obj))
+ ((subtyped)
+ (case (obj-subtype obj)
+ ((vector) (dump-vector obj))
+ ((symbol) (dump-symbol obj))
+;; ((ratnum) (dump-ratnum obj))
+;; ((cpxnum) (dump-cpxnum obj))
+ ((string) (dump-string obj))
+ ((bignum) (dump-bignum obj))
+ (else
+ (compiler-internal-error
+ "dump-object, can't dump object 'obj':"
+ obj))))
+ ((procedure) (dump-procedure obj))
+ (else
+ (compiler-internal-error "dump-object, can't dump object 'obj':" obj))))
+(define (dump-pair pair)
+ (ofile-long pair-prefix)
+ (ofile-ref (cdr pair))
+ (ofile-ref (car pair)))
+(define (dump-vector v)
+ (ofile-long (+ (* (vector-length v) 1024) (* subtype-vector 8)))
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (if (< i len) (begin (ofile-ref (vector-ref v i)) (loop (+ i 1)))))))
+(define (dump-symbol sym)
+ (compiler-internal-error "dump-symbol, can't dump SYMBOL type"))
+;;(define (dump-ratnum x)
+;; (ofile-long (+ (* 2 1024) (* subtype-ratnum 8)))
+;; (ofile-ref (numerator x))
+;; (ofile-ref (denominator x)))
+;;(define (dump-cpxnum x)
+;; (ofile-long (+ (* 2 1024) (* subtype-cpxnum 8)))
+;; (ofile-ref (real-part x))
+;; (ofile-ref (imag-part x)))
+(define (dump-string s)
+ (ofile-long (+ (* (+ (string-length s) 1) 256) (* subtype-string 8)))
+ (let ((len (string-length s)))
+ (define (ref i) (if (>= i len) 0 (character-encoding (string-ref s i))))
+ (let loop ((i 0))
+ (if (<= i len)
+ (begin
+ (ofile-word (+ (* (ref i) 256) (ref (+ i 1))))
+ (loop (+ i 2)))))))
+(define (dump-flonum x)
+ (let ((bits (flonum->bits x)))
+ (ofile-long flonum-prefix)
+ (ofile-long (quotient bits 4294967296))
+ (ofile-long (modulo bits 4294967296))))
+(define (flonum->inexact-exponential-format x)
+ (define (exp-form-pos x y i)
+ (let ((i*2 (+ i i)))
+ (let ((z (if (and (not (< flonum-e-bias i*2)) (not (< x y)))
+ (exp-form-pos x (* y y) i*2)
+ (cons x 0))))
+ (let ((a (car z)) (b (cdr z)))
+ (let ((i+b (+ i b)))
+ (if (and (not (< flonum-e-bias i+b)) (not (< a y)))
+ (begin (set-car! z (/ a y)) (set-cdr! z i+b)))
+ z)))))
+ (define (exp-form-neg x y i)
+ (let ((i*2 (+ i i)))
+ (let ((z (if (and (< i*2 flonum-e-bias-minus-1) (< x y))
+ (exp-form-neg x (* y y) i*2)
+ (cons x 0))))
+ (let ((a (car z)) (b (cdr z)))
+ (let ((i+b (+ i b)))
+ (if (and (< i+b flonum-e-bias-minus-1) (< a y))
+ (begin (set-car! z (/ a y)) (set-cdr! z i+b)))
+ z)))))
+ (define (exp-form x)
+ (if (< x inexact-+1)
+ (let ((z (exp-form-neg x inexact-+1/2 1)))
+ (set-car! z (* inexact-+2 (car z)))
+ (set-cdr! z (- -1 (cdr z)))
+ z)
+ (exp-form-pos x inexact-+2 1)))
+ (if (negative? x)
+ (let ((z (exp-form (- inexact-0 x))))
+ (set-car! z (- inexact-0 (car z)))
+ z)
+ (exp-form x)))
+(define (flonum->exact-exponential-format x)
+ (let ((z (flonum->inexact-exponential-format x)))
+ (let ((y (car z)))
+ (cond ((not (< y inexact-+2))
+ (set-car! z flonum-+m-min)
+ (set-cdr! z flonum-e-bias-plus-1))
+ ((not (< inexact--2 y))
+ (set-car! z flonum--m-min)
+ (set-cdr! z flonum-e-bias-plus-1))
+ (else
+ (set-car!
+ z
+ (truncate (inexact->exact (* (car z) inexact-m-min))))))
+ (set-cdr! z (- (cdr z) flonum-m-bits))
+ z)))
+(define (flonum->bits x)
+ (define (bits a b)
+ (if (< a flonum-+m-min)
+ a
+ (+ (- a flonum-+m-min)
+ (* (+ (+ b flonum-m-bits) flonum-e-bias) flonum-+m-min))))
+ (let ((z (flonum->exact-exponential-format x)))
+ (let ((a (car z)) (b (cdr z)))
+ (if (negative? a) (+ flonum-sign-bit (bits (- 0 a) b)) (bits a b)))))
+(define flonum-m-bits 52)
+(define flonum-e-bits 11)
+(define flonum-sign-bit 9223372036854775808)
+(define flonum-+m-min 4503599627370496)
+(define flonum--m-min -4503599627370496)
+(define flonum-e-bias 1023)
+(define flonum-e-bias-plus-1 1024)
+(define flonum-e-bias-minus-1 1022)
+(define inexact-m-min (exact->inexact flonum-+m-min))
+(define inexact-+2 (exact->inexact 2))
+(define inexact--2 (exact->inexact -2))
+(define inexact-+1 (exact->inexact 1))
+(define inexact-+1/2 (/ (exact->inexact 1) (exact->inexact 2)))
+(define inexact-0 (exact->inexact 0))
+(define (dump-bignum x)
+ (define radix 16384)
+ (define (integer->digits n)
+ (if (= n 0)
+ '()
+ (cons (remainder n radix) (integer->digits (quotient n radix)))))
+ (let ((l (integer->digits (abs x))))
+ (ofile-long (+ (* (+ (length l) 1) 512) (* subtype-bignum 8)))
+ (if (< x 0) (ofile-word 0) (ofile-word 1))
+ (for-each ofile-word l)))
+(define (dump-procedure proc)
+ (let ((bbs (proc-obj-code proc)))
+ (set! entry-lbl-num (bbs-entry-lbl-num bbs))
+ (set! label-counter (bbs-lbl-counter bbs))
+ (set! var-descr-queue (queue-empty))
+ (set! first-class-label-queue (queue-empty))
+ (set! deferred-code-queue (queue-empty))
+ (if *info-port*
+ (begin
+ (display " #[" *info-port*)
+ (if (proc-obj-primitive? proc)
+ (display "primitive " *info-port*)
+ (display "procedure " *info-port*))
+ (display (proc-obj-name proc) *info-port*)
+ (display "]" *info-port*)))
+ (if (proc-obj-primitive? proc)
+ (ofile-prim-proc (proc-obj-name proc))
+ (ofile-user-proc))
+ (asm.begin!)
+ (let loop ((prev-bb #f) (prev-gvm-instr #f) (l (bbs->code-list bbs)))
+ (if (not (null? l))
+ (let ((pres-bb (code-bb (car l)))
+ (pres-gvm-instr (code-gvm-instr (car l)))
+ (pres-slots-needed (code-slots-needed (car l)))
+ (next-gvm-instr
+ (if (null? (cdr l)) #f (code-gvm-instr (cadr l)))))
+ (if ofile-asm? (asm-comment (car l)))
+ (gen-gvm-instr
+ prev-gvm-instr
+ pres-gvm-instr
+ next-gvm-instr
+ pres-slots-needed)
+ (loop pres-bb pres-gvm-instr (cdr l)))))
+ (asm.end!
+ (if debug-info?
+ (vector (lst->vector (queue->list first-class-label-queue))
+ (lst->vector (queue->list var-descr-queue)))
+ #f))
+ (if *info-port* (newline *info-port*))
+ (set! var-descr-queue '())
+ (set! first-class-label-queue '())
+ (set! deferred-code-queue '())
+ (set! instr-source '())
+ (set! entry-frame '())
+ (set! exit-frame '())))
+(define label-counter (lambda () 0))
+(define entry-lbl-num '())
+(define var-descr-queue '())
+(define first-class-label-queue '())
+(define deferred-code-queue '())
+(define instr-source '())
+(define entry-frame '())
+(define exit-frame '())
+(define (defer-code! thunk) (queue-put! deferred-code-queue thunk))
+(define (gen-deferred-code!)
+ (let loop ()
+ (if (not (queue-empty? deferred-code-queue))
+ (let ((thunk (queue-get! deferred-code-queue))) (thunk) (loop)))))
+(define (add-var-descr! descr)
+ (define (index x l)
+ (let loop ((l l) (i 0))
+ (cond ((not (pair? l)) #f)
+ ((equal? (car l) x) i)
+ (else (loop (cdr l) (+ i 1))))))
+ (let ((n (index descr (queue->list var-descr-queue))))
+ (if n
+ n
+ (let ((m (length (queue->list var-descr-queue))))
+ (queue-put! var-descr-queue descr)
+ m))))
+(define (add-first-class-label! source slots frame)
+ (let loop ((i 0) (l1 slots) (l2 '()))
+ (if (pair? l1)
+ (let ((var (car l1)))
+ (let ((x (frame-live? var frame)))
+ (if (and x (or (pair? x) (not (temp-var? x))))
+ (let ((descr-index
+ (add-var-descr!
+ (if (pair? x)
+ (map (lambda (y) (add-var-descr! (var-name y))) x)
+ (var-name x)))))
+ (loop (+ i 1)
+ (cdr l1)
+ (cons (+ (* i 16384) descr-index) l2)))
+ (loop (+ i 1) (cdr l1) l2))))
+ (let ((label-descr (lst->vector (cons 0 (cons source l2)))))
+ (queue-put! first-class-label-queue label-descr)
+ label-descr))))
+(define (gen-gvm-instr prev-gvm-instr gvm-instr next-gvm-instr sn)
+ (set! instr-source (comment-get (gvm-instr-comment gvm-instr) 'source))
+ (set! exit-frame (gvm-instr-frame gvm-instr))
+ (set! entry-frame (and prev-gvm-instr (gvm-instr-frame prev-gvm-instr)))
+ (case (gvm-instr-type gvm-instr)
+ ((label)
+ (set! entry-frame exit-frame)
+ (set! current-fs (frame-size exit-frame))
+ (case (label-type gvm-instr)
+ ((simple) (gen-label-simple (label-lbl-num gvm-instr) sn))
+ ((entry)
+ (gen-label-entry
+ (label-lbl-num gvm-instr)
+ (label-entry-nb-parms gvm-instr)
+ (label-entry-min gvm-instr)
+ (label-entry-rest? gvm-instr)
+ (label-entry-closed? gvm-instr)
+ sn))
+ ((return) (gen-label-return (label-lbl-num gvm-instr) sn))
+ ((task-entry) (gen-label-task-entry (label-lbl-num gvm-instr) sn))
+ ((task-return) (gen-label-task-return (label-lbl-num gvm-instr) sn))
+ (else (compiler-internal-error "gen-gvm-instr, unknown label type"))))
+ ((apply)
+ (gen-apply
+ (apply-prim gvm-instr)
+ (apply-opnds gvm-instr)
+ (apply-loc gvm-instr)
+ sn))
+ ((copy) (gen-copy (copy-opnd gvm-instr) (copy-loc gvm-instr) sn))
+ ((close) (gen-close (close-parms gvm-instr) sn))
+ ((ifjump)
+ (gen-ifjump
+ (ifjump-test gvm-instr)
+ (ifjump-opnds gvm-instr)
+ (ifjump-true gvm-instr)
+ (ifjump-false gvm-instr)
+ (ifjump-poll? gvm-instr)
+ (if (and next-gvm-instr
+ (memq (label-type next-gvm-instr) '(simple task-entry)))
+ (label-lbl-num next-gvm-instr)
+ #f)))
+ ((jump)
+ (gen-jump
+ (jump-opnd gvm-instr)
+ (jump-nb-args gvm-instr)
+ (jump-poll? gvm-instr)
+ (if (and next-gvm-instr
+ (memq (label-type next-gvm-instr) '(simple task-entry)))
+ (label-lbl-num next-gvm-instr)
+ #f)))
+ (else
+ (compiler-internal-error
+ "gen-gvm-instr, unknown 'gvm-instr':"
+ gvm-instr))))
+(define (reg-in-opnd68 opnd)
+ (cond ((dreg? opnd) opnd)
+ ((areg? opnd) opnd)
+ ((ind? opnd) (ind-areg opnd))
+ ((pinc? opnd) (pinc-areg opnd))
+ ((pdec? opnd) (pdec-areg opnd))
+ ((disp? opnd) (disp-areg opnd))
+ ((inx? opnd) (inx-ireg opnd))
+ (else #f)))
+(define (temp-in-opnd68 opnd)
+ (let ((reg (reg-in-opnd68 opnd)))
+ (if reg
+ (cond ((identical-opnd68? reg dtemp1) reg)
+ ((identical-opnd68? reg atemp1) reg)
+ ((identical-opnd68? reg atemp2) reg)
+ (else #f))
+ #f)))
+(define (pick-atemp keep)
+ (if (and keep (identical-opnd68? keep atemp1)) atemp2 atemp1))
+(define return-reg '())
+(define max-nb-args 1024)
+(define heap-allocation-fudge (* pointer-size (+ (* 2 max-nb-args) 1024)))
+(define intr-flag 0)
+(define ltq-tail 1)
+(define ltq-head 2)
+(define heap-lim 12)
+(define closure-lim 17)
+(define closure-ptr 18)
+(define intr-flag-slot (make-disp* pstate-reg (* pointer-size intr-flag)))
+(define ltq-tail-slot (make-disp* pstate-reg (* pointer-size ltq-tail)))
+(define ltq-head-slot (make-disp* pstate-reg (* pointer-size ltq-head)))
+(define heap-lim-slot (make-disp* pstate-reg (* pointer-size heap-lim)))
+(define closure-lim-slot (make-disp* pstate-reg (* pointer-size closure-lim)))
+(define closure-ptr-slot (make-disp* pstate-reg (* pointer-size closure-ptr)))
+(define touch-trap 1)
+(define non-proc-jump-trap 6)
+(define rest-params-trap 7)
+(define rest-params-closed-trap 8)
+(define wrong-nb-arg1-trap 9)
+(define wrong-nb-arg1-closed-trap 10)
+(define wrong-nb-arg2-trap 11)
+(define wrong-nb-arg2-closed-trap 12)
+(define heap-alloc1-trap 13)
+(define heap-alloc2-trap 14)
+(define closure-alloc-trap 15)
+(define intr-trap 24)
+(define cache-line-length 16)
+(define polling-intermittency '())
+(set! polling-intermittency 10)
+(define (stat-clear!) (set! *stats* (cons 0 '())))
+(define (stat-dump!) (emit-stat (cdr *stats*)))
+(define (stat-add! bin count)
+ (define (add! stats bin count)
+ (set-car! stats (+ (car stats) count))
+ (if (not (null? bin))
+ (let ((x (assoc (car bin) (cdr stats))))
+ (if x
+ (add! (cdr x) (cdr bin) count)
+ (begin
+ (set-cdr! stats (cons (list (car bin) 0) (cdr stats)))
+ (add! (cdadr stats) (cdr bin) count))))))
+ (add! *stats* bin count))
+(define (fetch-stat-add! gvm-opnd) (opnd-stat-add! 'fetch gvm-opnd))
+(define (store-stat-add! gvm-opnd) (opnd-stat-add! 'store gvm-opnd))
+(define (jump-stat-add! gvm-opnd) (opnd-stat-add! 'jump gvm-opnd))
+(define (opnd-stat-add! type opnd)
+ (cond ((reg? opnd) (stat-add! (list 'gvm-opnd 'reg type (reg-num opnd)) 1))
+ ((stk? opnd) (stat-add! (list 'gvm-opnd 'stk type) 1))
+ ((glo? opnd) (stat-add! (list 'gvm-opnd 'glo type (glo-name opnd)) 1))
+ ((clo? opnd)
+ (stat-add! (list 'gvm-opnd 'clo type) 1)
+ (fetch-stat-add! (clo-base opnd)))
+ ((lbl? opnd) (stat-add! (list 'gvm-opnd 'lbl type) 1))
+ ((obj? opnd)
+ (let ((val (obj-val opnd)))
+ (if (number? val)
+ (stat-add! (list 'gvm-opnd 'obj type val) 1)
+ (stat-add! (list 'gvm-opnd 'obj type (obj-type val)) 1))))
+ (else
+ (compiler-internal-error "opnd-stat-add!, unknown 'opnd':" opnd))))
+(define (opnd-stat opnd)
+ (cond ((reg? opnd) 'reg)
+ ((stk? opnd) 'stk)
+ ((glo? opnd) 'glo)
+ ((clo? opnd) 'clo)
+ ((lbl? opnd) 'lbl)
+ ((obj? opnd) 'obj)
+ (else (compiler-internal-error "opnd-stat, unknown 'opnd':" opnd))))
+(define *stats* '())
+(define (move-opnd68-to-loc68 opnd loc)
+ (if (not (identical-opnd68? opnd loc))
+ (if (imm? opnd)
+ (move-n-to-loc68 (imm-val opnd) loc)
+ (emit-move.l opnd loc))))
+(define (move-obj-to-loc68 obj loc)
+ (let ((n (obj-encoding obj)))
+ (if n (move-n-to-loc68 n loc) (emit-move.l (emit-const obj) loc))))
+(define (move-n-to-loc68 n loc)
+ (cond ((= n bits-null) (emit-move.l null-reg loc))
+ ((= n bits-false) (emit-move.l false-reg loc))
+ ((and (dreg? loc) (>= n -128) (<= n 127)) (emit-moveq n loc))
+ ((and (areg? loc) (>= n -32768) (<= n 32767))
+ (emit-move.w (make-imm n) loc))
+ ((and (identical-opnd68? loc pdec-sp) (>= n -32768) (<= n 32767))
+ (emit-pea* n))
+ ((= n 0) (emit-clr.l loc))
+ ((and (not (and (inx? loc) (= (inx-ireg loc) dtemp1)))
+ (>= n -128)
+ (<= n 127))
+ (emit-moveq n dtemp1)
+ (emit-move.l dtemp1 loc))
+ (else (emit-move.l (make-imm n) loc))))
+(define (add-n-to-loc68 n loc)
+ (if (not (= n 0))
+ (cond ((and (>= n -8) (<= n 8))
+ (if (> n 0) (emit-addq.l n loc) (emit-subq.l (- n) loc)))
+ ((and (areg? loc) (>= n -32768) (<= n 32767))
+ (emit-lea (make-disp loc n) loc))
+ ((and (not (identical-opnd68? loc dtemp1)) (>= n -128) (<= n 128))
+ (emit-moveq (- (abs n)) dtemp1)
+ (if (> n 0) (emit-sub.l dtemp1 loc) (emit-add.l dtemp1 loc)))
+ (else (emit-add.l (make-imm n) loc)))))
+(define (power-of-2 n)
+ (let loop ((i 0) (k 1))
+ (cond ((= k n) i) ((> k n) #f) (else (loop (+ i 1) (* k 2))))))
+(define (mul-n-to-reg68 n reg)
+ (if (= n 0)
+ (emit-moveq 0 reg)
+ (let ((abs-n (abs n)))
+ (if (= abs-n 1)
+ (if (< n 0) (emit-neg.l reg))
+ (let ((shift (power-of-2 abs-n)))
+ (if shift
+ (let ((m (min shift 32)))
+ (if (or (<= m 8) (identical-opnd68? reg dtemp1))
+ (let loop ((i m))
+ (if (> i 0)
+ (begin
+ (emit-asl.l (make-imm (min i 8)) reg)
+ (loop (- i 8)))))
+ (begin (emit-moveq m dtemp1) (emit-asl.l dtemp1 reg)))
+ (if (< n 0) (emit-neg.l reg)))
+ (emit-muls.l (make-imm n) reg)))))))
+(define (div-n-to-reg68 n reg)
+ (let ((abs-n (abs n)))
+ (if (= abs-n 1)
+ (if (< n 0) (emit-neg.l reg))
+ (let ((shift (power-of-2 abs-n)))
+ (if shift
+ (let ((m (min shift 32)) (lbl (new-lbl!)))
+ (emit-move.l reg reg)
+ (emit-bpl lbl)
+ (add-n-to-loc68 (* (- abs-n 1) 8) reg)
+ (emit-label lbl)
+ (if (or (<= m 8) (identical-opnd68? reg dtemp1))
+ (let loop ((i m))
+ (if (> i 0)
+ (begin
+ (emit-asr.l (make-imm (min i 8)) reg)
+ (loop (- i 8)))))
+ (begin (emit-moveq m dtemp1) (emit-asr.l dtemp1 reg)))
+ (if (< n 0) (emit-neg.l reg)))
+ (emit-divsl.l (make-imm n) reg reg))))))
+(define (cmp-n-to-opnd68 n opnd)
+ (cond ((= n bits-null) (emit-cmp.l opnd null-reg) #f)
+ ((= n bits-false) (emit-cmp.l opnd false-reg) #f)
+ ((or (pcr? opnd) (imm? opnd))
+ (if (= n 0)
+ (begin (emit-move.l opnd dtemp1) #t)
+ (begin
+ (move-opnd68-to-loc68 opnd atemp1)
+ (if (and (>= n -32768) (<= n 32767))
+ (emit-cmp.w (make-imm n) atemp1)
+ (emit-cmp.l (make-imm n) atemp1))
+ #t)))
+ ((= n 0) (emit-move.l opnd dtemp1) #t)
+ ((and (>= n -128) (<= n 127) (not (identical-opnd68? opnd dtemp1)))
+ (emit-moveq n dtemp1)
+ (emit-cmp.l opnd dtemp1)
+ #f)
+ (else (emit-cmp.l (make-imm n) opnd) #t)))
+(define current-fs '())
+(define (adjust-current-fs n) (set! current-fs (+ current-fs n)))
+(define (new-lbl!) (label-counter))
+(define (needed? loc sn) (and loc (if (stk? loc) (<= (stk-num loc) sn) #t)))
+(define (sn-opnd opnd sn)
+ (cond ((stk? opnd) (max (stk-num opnd) sn))
+ ((clo? opnd) (sn-opnd (clo-base opnd) sn))
+ (else sn)))
+(define (sn-opnds opnds sn)
+ (if (null? opnds) sn (sn-opnd (car opnds) (sn-opnds (cdr opnds) sn))))
+(define (sn-opnd68 opnd sn)
+ (cond ((and (disp*? opnd) (identical-opnd68? (disp*-areg opnd) sp-reg))
+ (max (disp*-offset opnd) sn))
+ ((identical-opnd68? opnd pdec-sp) (max (+ current-fs 1) sn))
+ ((identical-opnd68? opnd pinc-sp) (max current-fs sn))
+ (else sn)))
+(define (resize-frame n)
+ (let ((x (- n current-fs)))
+ (adjust-current-fs x)
+ (add-n-to-loc68 (* (- pointer-size) x) sp-reg)))
+(define (shrink-frame n)
+ (cond ((< n current-fs) (resize-frame n))
+ ((> n current-fs)
+ (compiler-internal-error "shrink-frame, can't increase frame size"))))
+(define (make-top-of-frame n sn)
+ (if (and (< n current-fs) (>= n sn)) (resize-frame n)))
+(define (make-top-of-frame-if-stk-opnd68 opnd sn)
+ (if (frame-base-rel? opnd)
+ (make-top-of-frame (frame-base-rel-slot opnd) sn)))
+(define (make-top-of-frame-if-stk-opnds68 opnd1 opnd2 sn)
+ (if (frame-base-rel? opnd1)
+ (let ((slot1 (frame-base-rel-slot opnd1)))
+ (if (frame-base-rel? opnd2)
+ (make-top-of-frame (max (frame-base-rel-slot opnd2) slot1) sn)
+ (make-top-of-frame slot1 sn)))
+ (if (frame-base-rel? opnd2)
+ (make-top-of-frame (frame-base-rel-slot opnd2) sn))))
+(define (opnd68->true-opnd68 opnd sn)
+ (if (frame-base-rel? opnd)
+ (let ((slot (frame-base-rel-slot opnd)))
+ (cond ((> slot current-fs) (adjust-current-fs 1) pdec-sp)
+ ((and (= slot current-fs) (< sn current-fs))
+ (adjust-current-fs -1)
+ pinc-sp)
+ (else (make-disp* sp-reg (* pointer-size (- current-fs slot))))))
+ opnd))
+(define (move-opnd68-to-any-areg opnd keep sn)
+ (if (areg? opnd)
+ opnd
+ (let ((areg (pick-atemp keep)))
+ (make-top-of-frame-if-stk-opnd68 opnd sn)
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) areg)
+ areg)))
+(define (clo->opnd68 opnd keep sn)
+ (let ((base (clo-base opnd)) (offs (closed-var-offset (clo-index opnd))))
+ (if (lbl? base) (make-pcr (lbl-num base) offs) (clo->loc68 opnd keep sn))))
+(define (clo->loc68 opnd keep sn)
+ (let ((base (clo-base opnd)) (offs (closed-var-offset (clo-index opnd))))
+ (cond ((eq? base return-reg) (make-disp* (reg->reg68 base) offs))
+ ((obj? base)
+ (let ((areg (pick-atemp keep)))
+ (move-obj-to-loc68 (obj-val base) areg)
+ (make-disp* areg offs)))
+ (else
+ (let ((areg (pick-atemp keep)))
+ (move-opnd-to-loc68 base areg sn)
+ (make-disp* areg offs))))))
+(define (reg->reg68 reg) (reg-num->reg68 (reg-num reg)))
+(define (reg-num->reg68 num)
+ (if (= num 0) (make-areg gvm-reg0) (make-dreg (+ (- num 1) gvm-reg1))))
+(define (opnd->opnd68 opnd keep sn)
+ (cond ((lbl? opnd)
+ (let ((areg (pick-atemp keep)))
+ (emit-lea (make-pcr (lbl-num opnd) 0) areg)
+ areg))
+ ((obj? opnd)
+ (let ((val (obj-val opnd)))
+ (if (proc-obj? val)
+ (let ((num (add-object val)) (areg (pick-atemp keep)))
+ (if num (emit-move-proc num areg) (emit-move-prim val areg))
+ areg)
+ (let ((n (obj-encoding val)))
+ (if n (make-imm n) (emit-const val))))))
+ ((clo? opnd) (clo->opnd68 opnd keep sn))
+ (else (loc->loc68 opnd keep sn))))
+(define (loc->loc68 loc keep sn)
+ (cond ((reg? loc) (reg->reg68 loc))
+ ((stk? loc) (make-frame-base-rel (stk-num loc)))
+ ((glo? loc) (make-glob (glo-name loc)))
+ ((clo? loc) (clo->loc68 loc keep sn))
+ (else (compiler-internal-error "loc->loc68, unknown 'loc':" loc))))
+(define (move-opnd68-to-loc opnd loc sn)
+ (cond ((reg? loc)
+ (make-top-of-frame-if-stk-opnd68 opnd sn)
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) (reg->reg68 loc)))
+ ((stk? loc)
+ (let* ((loc-slot (stk-num loc))
+ (sn-after-opnd1 (if (< loc-slot sn) sn (- loc-slot 1))))
+ (if (> current-fs loc-slot)
+ (make-top-of-frame
+ (if (frame-base-rel? opnd)
+ (let ((opnd-slot (frame-base-rel-slot opnd)))
+ (if (>= opnd-slot (- loc-slot 1)) opnd-slot loc-slot))
+ loc-slot)
+ sn-after-opnd1))
+ (let* ((opnd1 (opnd68->true-opnd68 opnd sn-after-opnd1))
+ (opnd2 (opnd68->true-opnd68
+ (make-frame-base-rel loc-slot)
+ sn)))
+ (move-opnd68-to-loc68 opnd1 opnd2))))
+ ((glo? loc)
+ (make-top-of-frame-if-stk-opnd68 opnd sn)
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 opnd sn)
+ (make-glob (glo-name loc))))
+ ((clo? loc)
+ (let ((clo (clo->loc68
+ loc
+ (temp-in-opnd68 opnd)
+ (sn-opnd68 opnd sn))))
+ (make-top-of-frame-if-stk-opnd68 opnd sn)
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) clo)))
+ (else
+ (compiler-internal-error "move-opnd68-to-loc, unknown 'loc':" loc))))
+(define (move-opnd-to-loc68 opnd loc68 sn)
+ (if (and (lbl? opnd) (areg? loc68))
+ (emit-lea (make-pcr (lbl-num opnd) 0) loc68)
+ (let* ((sn-after-opnd68 (sn-opnd68 loc68 sn))
+ (opnd68 (opnd->opnd68
+ opnd
+ (temp-in-opnd68 loc68)
+ sn-after-opnd68)))
+ (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn)
+ (let* ((opnd68* (opnd68->true-opnd68 opnd68 sn-after-opnd68))
+ (loc68* (opnd68->true-opnd68 loc68 sn)))
+ (move-opnd68-to-loc68 opnd68* loc68*)))))
+(define (copy-opnd-to-loc opnd loc sn)
+ (if (and (lbl? opnd) (eq? loc return-reg))
+ (emit-lea (make-pcr (lbl-num opnd) 0) (reg->reg68 loc))
+ (move-opnd68-to-loc (opnd->opnd68 opnd #f (sn-opnd loc sn)) loc sn)))
+(define (touch-reg68-to-reg68 src dst)
+ (define (trap-to-touch-handler dreg lbl)
+ (if ofile-stats?
+ (emit-stat
+ '((touch 0
+ (determined-placeholder -1)
+ (undetermined-placeholder 1)))))
+ (gen-trap
+ instr-source
+ entry-frame
+ #t
+ dreg
+ (+ touch-trap (dreg-num dreg))
+ lbl))
+ (define (touch-dreg-to-reg src dst)
+ (let ((lbl1 (new-lbl!)))
+ (emit-btst src placeholder-reg)
+ (emit-bne lbl1)
+ (if ofile-stats?
+ (emit-stat
+ '((touch 0 (non-placeholder -1) (determined-placeholder 1)))))
+ (trap-to-touch-handler src lbl1)
+ (move-opnd68-to-loc68 src dst)))
+ (define (touch-areg-to-dreg src dst)
+ (let ((lbl1 (new-lbl!)))
+ (emit-move.l src dst)
+ (emit-btst dst placeholder-reg)
+ (emit-bne lbl1)
+ (if ofile-stats?
+ (emit-stat
+ '((touch 0 (non-placeholder -1) (determined-placeholder 1)))))
+ (trap-to-touch-handler dst lbl1)))
+ (if ofile-stats? (emit-stat '((touch 1 (non-placeholder 1)))))
+ (cond ((dreg? src) (touch-dreg-to-reg src dst))
+ ((dreg? dst) (touch-areg-to-dreg src dst))
+ (else (emit-move.l src dtemp1) (touch-dreg-to-reg dtemp1 dst))))
+(define (touch-opnd-to-any-reg68 opnd sn)
+ (if (reg? opnd)
+ (let ((reg (reg->reg68 opnd))) (touch-reg68-to-reg68 reg reg) reg)
+ (let ((opnd68 (opnd->opnd68 opnd #f sn)))
+ (make-top-of-frame-if-stk-opnd68 opnd68 sn)
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd68 sn) dtemp1)
+ (touch-reg68-to-reg68 dtemp1 dtemp1)
+ dtemp1)))
+(define (touch-opnd-to-loc opnd loc sn)
+ (if (reg? opnd)
+ (let ((reg68 (reg->reg68 opnd)))
+ (if (reg? loc)
+ (touch-reg68-to-reg68 reg68 (reg->reg68 loc))
+ (begin
+ (touch-reg68-to-reg68 reg68 reg68)
+ (move-opnd68-to-loc reg68 loc sn))))
+ (if (reg? loc)
+ (let ((reg68 (reg->reg68 loc)))
+ (move-opnd-to-loc68 opnd reg68 sn)
+ (touch-reg68-to-reg68 reg68 reg68))
+ (let ((reg68 (touch-opnd-to-any-reg68 opnd sn)))
+ (move-opnd68-to-loc reg68 loc sn)))))
+(define (gen-trap source frame save-live? not-save-reg num lbl)
+ (define (adjust-slots l n)
+ (cond ((= n 0) (append l '()))
+ ((< n 0) (adjust-slots (cdr l) (+ n 1)))
+ (else (adjust-slots (cons empty-var l) (- n 1)))))
+ (define (set-slot! slots i x)
+ (let loop ((l slots) (n (- (length slots) i)))
+ (if (> n 0) (loop (cdr l) (- n 1)) (set-car! l x))))
+ (let ((ret-slot (frame-first-empty-slot frame)))
+ (let loop1 ((save1 '()) (save2 #f) (regs (frame-regs frame)) (i 0))
+ (if (pair? regs)
+ (let ((var (car regs)))
+ (if (eq? var ret-var)
+ (let ((x (cons (reg->reg68 (make-reg i)) var)))
+ (if (> ret-slot current-fs)
+ (loop1 (cons x save1) save2 (cdr regs) (+ i 1))
+ (loop1 save1 x (cdr regs) (+ i 1))))
+ (if (and save-live?
+ (frame-live? var frame)
+ (not (eqv? not-save-reg (reg->reg68 (make-reg i)))))
+ (loop1 (cons (cons (reg->reg68 (make-reg i)) var) save1)
+ save2
+ (cdr regs)
+ (+ i 1))
+ (loop1 save1 save2 (cdr regs) (+ i 1)))))
+ (let ((order (sort-list save1 (lambda (x y) (< (car x) (car y))))))
+ (let ((slots (append (map cdr order)
+ (adjust-slots
+ (frame-slots frame)
+ (- current-fs (frame-size frame)))))
+ (reg-list (map car order))
+ (nb-regs (length order)))
+ (define (trap)
+ (emit-trap2 num '())
+ (gen-label-return*
+ (new-lbl!)
+ (add-first-class-label! source slots frame)
+ slots
+ 0))
+ (if save2
+ (begin
+ (emit-move.l
+ (car save2)
+ (make-disp*
+ sp-reg
+ (* pointer-size (- current-fs ret-slot))))
+ (set-slot! slots ret-slot (cdr save2))))
+ (if (> (length order) 2)
+ (begin
+ (emit-movem.l reg-list pdec-sp)
+ (trap)
+ (emit-movem.l pinc-sp reg-list))
+ (let loop2 ((l (reverse reg-list)))
+ (if (pair? l)
+ (let ((reg (car l)))
+ (emit-move.l reg pdec-sp)
+ (loop2 (cdr l))
+ (emit-move.l pinc-sp reg))
+ (trap))))
+ (if save2
+ (emit-move.l
+ (make-disp* sp-reg (* pointer-size (- current-fs ret-slot)))
+ (car save2)))
+ (emit-label lbl)))))))
+(define (gen-label-simple lbl sn)
+ (if ofile-stats?
+ (begin (stat-clear!) (stat-add! '(gvm-instr label simple) 1)))
+ (set! pointers-allocated 0)
+ (emit-label lbl))
+(define (gen-label-entry lbl nb-parms min rest? closed? sn)
+ (if ofile-stats?
+ (begin
+ (stat-clear!)
+ (stat-add!
+ (list 'gvm-instr
+ 'label
+ 'entry
+ nb-parms
+ min
+ (if rest? 'rest 'not-rest)
+ (if closed? 'closed 'not-closed))
+ 1)))
+ (set! pointers-allocated 0)
+ (let ((label-descr (add-first-class-label! instr-source '() exit-frame)))
+ (if (= lbl entry-lbl-num)
+ (emit-label lbl)
+ (emit-label-subproc lbl entry-lbl-num label-descr)))
+ (let* ((nb-parms* (if rest? (- nb-parms 1) nb-parms))
+ (dispatch-lbls (make-vector (+ (- nb-parms min) 1)))
+ (optional-lbls (make-vector (+ (- nb-parms min) 1))))
+ (let loop ((i min))
+ (if (<= i nb-parms)
+ (let ((lbl (new-lbl!)))
+ (vector-set! optional-lbls (- nb-parms i) lbl)
+ (vector-set!
+ dispatch-lbls
+ (- nb-parms i)
+ (if (or (>= i nb-parms) (<= nb-parms nb-arg-regs))
+ lbl
+ (new-lbl!)))
+ (loop (+ i 1)))))
+ (if closed?
+ (let ((closure-reg (reg-num->reg68 (+ nb-arg-regs 1))))
+ (emit-move.l pinc-sp closure-reg)
+ (emit-subq.l 6 closure-reg)
+ (if (or (and (<= min 1) (<= 1 nb-parms*))
+ (and (<= min 2) (<= 2 nb-parms*)))
+ (emit-move.w dtemp1 dtemp1))))
+ (if (and (<= min 2) (<= 2 nb-parms*))
+ (emit-beq (vector-ref dispatch-lbls (- nb-parms 2))))
+ (if (and (<= min 1) (<= 1 nb-parms*))
+ (emit-bmi (vector-ref dispatch-lbls (- nb-parms 1))))
+ (let loop ((i min))
+ (if (<= i nb-parms*)
+ (begin
+ (if (not (or (= i 1) (= i 2)))
+ (begin
+ (emit-cmp.w (make-imm (encode-arg-count i)) arg-count-reg)
+ (emit-beq (vector-ref dispatch-lbls (- nb-parms i)))))
+ (loop (+ i 1)))))
+ (cond (rest?
+ (emit-trap1
+ (if closed? rest-params-closed-trap rest-params-trap)
+ (list min nb-parms*))
+ (if (not closed?) (emit-lbl-ptr lbl))
+ (set! pointers-allocated 1)
+ (gen-guarantee-fudge)
+ (emit-bra (vector-ref optional-lbls 0)))
+ ((= min nb-parms*)
+ (emit-trap1
+ (if closed? wrong-nb-arg1-closed-trap wrong-nb-arg1-trap)
+ (list nb-parms*))
+ (if (not closed?) (emit-lbl-ptr lbl)))
+ (else
+ (emit-trap1
+ (if closed? wrong-nb-arg2-closed-trap wrong-nb-arg2-trap)
+ (list min nb-parms*))
+ (if (not closed?) (emit-lbl-ptr lbl))))
+ (if (> nb-parms nb-arg-regs)
+ (let loop1 ((i (- nb-parms 1)))
+ (if (>= i min)
+ (let ((nb-stacked (if (<= i nb-arg-regs) 0 (- i nb-arg-regs))))
+ (emit-label (vector-ref dispatch-lbls (- nb-parms i)))
+ (let loop2 ((j 1))
+ (if (and (<= j nb-arg-regs)
+ (<= j i)
+ (<= j (- (- nb-parms nb-arg-regs) nb-stacked)))
+ (begin
+ (emit-move.l (reg-num->reg68 j) pdec-sp)
+ (loop2 (+ j 1)))
+ (let loop3 ((k j))
+ (if (and (<= k nb-arg-regs) (<= k i))
+ (begin
+ (emit-move.l
+ (reg-num->reg68 k)
+ (reg-num->reg68 (+ (- k j) 1)))
+ (loop3 (+ k 1)))))))
+ (if (> i min)
+ (emit-bra (vector-ref optional-lbls (- nb-parms i))))
+ (loop1 (- i 1))))))
+ (let loop ((i min))
+ (if (<= i nb-parms)
+ (let ((val (if (= i nb-parms*) bits-null bits-unass)))
+ (emit-label (vector-ref optional-lbls (- nb-parms i)))
+ (cond ((> (- nb-parms i) nb-arg-regs)
+ (move-n-to-loc68 val pdec-sp))
+ ((< i nb-parms)
+ (move-n-to-loc68
+ val
+ (reg-num->reg68 (parm->reg-num (+ i 1) nb-parms)))))
+ (loop (+ i 1)))))))
+(define (encode-arg-count n) (cond ((= n 1) -1) ((= n 2) 0) (else (+ n 1))))
+(define (parm->reg-num i nb-parms)
+ (if (<= nb-parms nb-arg-regs) i (+ i (- nb-arg-regs nb-parms))))
+(define (no-arg-check-entry-offset proc nb-args)
+ (let ((x (proc-obj-call-pat proc)))
+ (if (and (pair? x) (null? (cdr x)))
+ (let ((arg-count (car x)))
+ (if (= arg-count nb-args)
+ (if (or (= arg-count 1) (= arg-count 2)) 10 14)
+ 0))
+ 0)))
+(define (gen-label-return lbl sn)
+ (if ofile-stats?
+ (begin (stat-clear!) (stat-add! '(gvm-instr label return) 1)))
+ (set! pointers-allocated 0)
+ (let ((slots (frame-slots exit-frame)))
+ (gen-label-return*
+ lbl
+ (add-first-class-label! instr-source slots exit-frame)
+ slots
+ 0)))
+(define (gen-label-return* lbl label-descr slots extra)
+ (let ((i (pos-in-list ret-var slots)))
+ (if i
+ (let* ((fs (length slots)) (link (- fs i)))
+ (emit-label-return lbl entry-lbl-num (+ fs extra) link label-descr))
+ (compiler-internal-error
+ "gen-label-return*, no return address in frame"))))
+(define (gen-label-task-entry lbl sn)
+ (if ofile-stats?
+ (begin (stat-clear!) (stat-add! '(gvm-instr label task-entry) 1)))
+ (set! pointers-allocated 0)
+ (emit-label lbl)
+ (if (= current-fs 0)
+ (begin
+ (emit-move.l (reg->reg68 return-reg) pdec-sp)
+ (emit-move.l sp-reg (make-pinc ltq-tail-reg)))
+ (begin
+ (emit-move.l sp-reg atemp1)
+ (emit-move.l (make-pinc atemp1) pdec-sp)
+ (let loop ((i (- current-fs 1)))
+ (if (> i 0)
+ (begin
+ (emit-move.l (make-pinc atemp1) (make-disp atemp1 -8))
+ (loop (- i 1)))))
+ (emit-move.l (reg->reg68 return-reg) (make-pdec atemp1))
+ (emit-move.l atemp1 (make-pinc ltq-tail-reg))))
+ (emit-move.l ltq-tail-reg ltq-tail-slot))
+(define (gen-label-task-return lbl sn)
+ (if ofile-stats?
+ (begin (stat-clear!) (stat-add! '(gvm-instr label task-return) 1)))
+ (set! pointers-allocated 0)
+ (let ((slots (frame-slots exit-frame)))
+ (set! current-fs (+ current-fs 1))
+ (let ((dummy-lbl (new-lbl!)) (skip-lbl (new-lbl!)))
+ (gen-label-return*
+ dummy-lbl
+ (add-first-class-label! instr-source slots exit-frame)
+ slots
+ 1)
+ (emit-bra skip-lbl)
+ (gen-label-task-return*
+ lbl
+ (add-first-class-label! instr-source slots exit-frame)
+ slots
+ 1)
+ (emit-subq.l pointer-size ltq-tail-reg)
+ (emit-label skip-lbl))))
+(define (gen-label-task-return* lbl label-descr slots extra)
+ (let ((i (pos-in-list ret-var slots)))
+ (if i
+ (let* ((fs (length slots)) (link (- fs i)))
+ (emit-label-task-return
+ lbl
+ entry-lbl-num
+ (+ fs extra)
+ link
+ label-descr))
+ (compiler-internal-error
+ "gen-label-task-return*, no return address in frame"))))
+(define (gen-apply prim opnds loc sn)
+ (if ofile-stats?
+ (begin
+ (stat-add!
+ (list 'gvm-instr
+ 'apply
+ (string->canonical-symbol (proc-obj-name prim))
+ (map opnd-stat opnds)
+ (if loc (opnd-stat loc) #f))
+ 1)
+ (for-each fetch-stat-add! opnds)
+ (if loc (store-stat-add! loc))))
+ (let ((x (proc-obj-inlinable prim)))
+ (if (not x)
+ (compiler-internal-error "gen-APPLY, unknown 'prim':" prim)
+ (if (or (needed? loc sn) (car x)) ((cdr x) opnds loc sn)))))
+(define (define-apply name side-effects? proc)
+ (let ((prim (get-prim-info name)))
+ (proc-obj-inlinable-set! prim (cons side-effects? proc))))
+(define (gen-copy opnd loc sn)
+ (if ofile-stats?
+ (begin
+ (stat-add! (list 'gvm-instr 'copy (opnd-stat opnd) (opnd-stat loc)) 1)
+ (fetch-stat-add! opnd)
+ (store-stat-add! loc)))
+ (if (needed? loc sn) (copy-opnd-to-loc opnd loc sn)))
+(define (gen-close parms sn)
+ (define (size->bytes size)
+ (* (quotient
+ (+ (* (+ size 2) pointer-size) (- cache-line-length 1))
+ cache-line-length)
+ cache-line-length))
+ (define (parms->bytes parms)
+ (if (null? parms)
+ 0
+ (+ (size->bytes (length (closure-parms-opnds (car parms))))
+ (parms->bytes (cdr parms)))))
+ (if ofile-stats?
+ (begin
+ (for-each
+ (lambda (x)
+ (stat-add!
+ (list 'gvm-instr
+ 'close
+ (opnd-stat (closure-parms-loc x))
+ (map opnd-stat (closure-parms-opnds x)))
+ 1)
+ (store-stat-add! (closure-parms-loc x))
+ (fetch-stat-add! (make-lbl (closure-parms-lbl x)))
+ (for-each fetch-stat-add! (closure-parms-opnds x)))
+ parms)))
+ (let ((total-space-needed (parms->bytes parms)) (lbl1 (new-lbl!)))
+ (emit-move.l closure-ptr-slot atemp2)
+ (move-n-to-loc68 total-space-needed dtemp1)
+ (emit-sub.l dtemp1 atemp2)
+ (emit-cmp.l closure-lim-slot atemp2)
+ (emit-bcc lbl1)
+ (gen-trap instr-source entry-frame #f #f closure-alloc-trap lbl1)
+ (emit-move.l atemp2 closure-ptr-slot)
+ (let* ((opnds* (apply append (map closure-parms-opnds parms)))
+ (sn* (sn-opnds opnds* sn)))
+ (let loop1 ((parms parms))
+ (let ((loc (closure-parms-loc (car parms)))
+ (size (length (closure-parms-opnds (car parms))))
+ (rest (cdr parms)))
+ (if (= size 1)
+ (emit-addq.l type-procedure atemp2)
+ (emit-move.w
+ (make-imm (+ 32768 (* (+ size 1) 4)))
+ (make-pinc atemp2)))
+ (move-opnd68-to-loc
+ atemp2
+ loc
+ (sn-opnds (map closure-parms-loc rest) sn*))
+ (if (null? rest)
+ (add-n-to-loc68
+ (+ (- (size->bytes size) total-space-needed) 2)
+ atemp2)
+ (begin
+ (add-n-to-loc68 (- (size->bytes size) type-procedure) atemp2)
+ (loop1 rest)))))
+ (let loop2 ((parms parms))
+ (let* ((opnds (closure-parms-opnds (car parms)))
+ (lbl (closure-parms-lbl (car parms)))
+ (size (length opnds))
+ (rest (cdr parms)))
+ (emit-lea (make-pcr lbl 0) atemp1)
+ (emit-move.l atemp1 (make-pinc atemp2))
+ (let loop3 ((opnds opnds))
+ (if (not (null? opnds))
+ (let ((sn** (sn-opnds
+ (apply append (map closure-parms-opnds rest))
+ sn)))
+ (move-opnd-to-loc68
+ (car opnds)
+ (make-pinc atemp2)
+ (sn-opnds (cdr opnds) sn**))
+ (loop3 (cdr opnds)))))
+ (if (not (null? rest))
+ (begin
+ (add-n-to-loc68
+ (- (size->bytes size) (* (+ size 1) pointer-size))
+ atemp2)
+ (loop2 rest))))))))
+(define (gen-ifjump test opnds true-lbl false-lbl poll? next-lbl)
+ (if ofile-stats?
+ (begin
+ (stat-add!
+ (list 'gvm-instr
+ 'ifjump
+ (string->canonical-symbol (proc-obj-name test))
+ (map opnd-stat opnds)
+ (if poll? 'poll 'not-poll))
+ 1)
+ (for-each fetch-stat-add! opnds)
+ (stat-dump!)))
+ (let ((proc (proc-obj-test test)))
+ (if proc
+ (gen-ifjump* proc opnds true-lbl false-lbl poll? next-lbl)
+ (compiler-internal-error "gen-IFJUMP, unknown 'test':" test))))
+(define (gen-ifjump* proc opnds true-lbl false-lbl poll? next-lbl)
+ (let ((fs (frame-size exit-frame)))
+ (define (double-branch)
+ (proc #t opnds false-lbl fs)
+ (if ofile-stats?
+ (emit-stat
+ '((gvm-instr.ifjump.fall-through 1)
+ (gvm-instr.ifjump.double-branch 1))))
+ (emit-bra true-lbl)
+ (gen-deferred-code!))
+ (gen-guarantee-fudge)
+ (if poll? (gen-poll))
+ (if next-lbl
+ (cond ((= true-lbl next-lbl)
+ (proc #t opnds false-lbl fs)
+ (if ofile-stats?
+ (emit-stat '((gvm-instr.ifjump.fall-through 1)))))
+ ((= false-lbl next-lbl)
+ (proc #f opnds true-lbl fs)
+ (if ofile-stats?
+ (emit-stat '((gvm-instr.ifjump.fall-through 1)))))
+ (else (double-branch)))
+ (double-branch))))
+(define (define-ifjump name proc)
+ (define-apply
+ name
+ #f
+ (lambda (opnds loc sn)
+ (let ((true-lbl (new-lbl!))
+ (cont-lbl (new-lbl!))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (proc #f opnds true-lbl current-fs)
+ (move-n-to-loc68 bits-false reg68)
+ (emit-bra cont-lbl)
+ (emit-label true-lbl)
+ (move-n-to-loc68 bits-true reg68)
+ (emit-label cont-lbl)
+ (move-opnd68-to-loc reg68 loc sn))))
+ (proc-obj-test-set! (get-prim-info name) proc))
+(define (gen-jump opnd nb-args poll? next-lbl)
+ (let ((fs (frame-size exit-frame)))
+ (if ofile-stats?
+ (begin
+ (stat-add!
+ (list 'gvm-instr
+ 'jump
+ (opnd-stat opnd)
+ nb-args
+ (if poll? 'poll 'not-poll))
+ 1)
+ (jump-stat-add! opnd)
+ (if (and (lbl? opnd) next-lbl (= next-lbl (lbl-num opnd)))
+ (stat-add! '(gvm-instr.jump.fall-through) 1))
+ (stat-dump!)))
+ (gen-guarantee-fudge)
+ (cond ((glo? opnd)
+ (if poll? (gen-poll))
+ (setup-jump fs nb-args)
+ (emit-jmp-glob (make-glob (glo-name opnd)))
+ (gen-deferred-code!))
+ ((and (stk? opnd) (= (stk-num opnd) (+ fs 1)) (not nb-args))
+ (if poll? (gen-poll))
+ (setup-jump (+ fs 1) nb-args)
+ (emit-rts)
+ (gen-deferred-code!))
+ ((lbl? opnd)
+ (if (and poll?
+ (= fs current-fs)
+ (not nb-args)
+ (not (and next-lbl (= next-lbl (lbl-num opnd)))))
+ (gen-poll-branch (lbl-num opnd))
+ (begin
+ (if poll? (gen-poll))
+ (setup-jump fs nb-args)
+ (if (not (and next-lbl (= next-lbl (lbl-num opnd))))
+ (emit-bra (lbl-num opnd))))))
+ ((obj? opnd)
+ (if poll? (gen-poll))
+ (let ((val (obj-val opnd)))
+ (if (proc-obj? val)
+ (let ((num (add-object val))
+ (offset (no-arg-check-entry-offset val nb-args)))
+ (setup-jump fs (if (<= offset 0) nb-args #f))
+ (if num
+ (emit-jmp-proc num offset)
+ (emit-jmp-prim val offset))
+ (gen-deferred-code!))
+ (gen-jump* (opnd->opnd68 opnd #f fs) fs nb-args))))
+ (else
+ (if poll? (gen-poll))
+ (gen-jump* (opnd->opnd68 opnd #f fs) fs nb-args)))))
+(define (gen-jump* opnd fs nb-args)
+ (if nb-args
+ (let ((lbl (new-lbl!)))
+ (make-top-of-frame-if-stk-opnd68 opnd fs)
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd fs) atemp1)
+ (shrink-frame fs)
+ (emit-move.l atemp1 dtemp1)
+ (emit-addq.w (modulo (- type-pair type-procedure) 8) dtemp1)
+ (emit-btst dtemp1 pair-reg)
+ (emit-beq lbl)
+ (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)
+ (emit-trap3 non-proc-jump-trap)
+ (emit-label lbl)
+ (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)
+ (emit-jmp (make-ind atemp1)))
+ (let ((areg (move-opnd68-to-any-areg opnd #f fs)))
+ (setup-jump fs nb-args)
+ (emit-jmp (make-ind areg))))
+ (gen-deferred-code!))
+(define (setup-jump fs nb-args)
+ (shrink-frame fs)
+ (if nb-args (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)))
+(define (gen-poll)
+ (let ((lbl (new-lbl!)))
+ (emit-dbra poll-timer-reg lbl)
+ (emit-moveq (- polling-intermittency 1) poll-timer-reg)
+ (emit-cmp.l intr-flag-slot sp-reg)
+ (emit-bcc lbl)
+ (gen-trap instr-source entry-frame #f #f intr-trap lbl)))
+(define (gen-poll-branch lbl)
+ (emit-dbra poll-timer-reg lbl)
+ (emit-moveq (- polling-intermittency 1) poll-timer-reg)
+ (emit-cmp.l intr-flag-slot sp-reg)
+ (emit-bcc lbl)
+ (gen-trap instr-source entry-frame #f #f intr-trap (new-lbl!))
+ (emit-bra lbl))
+(define (make-gen-slot-ref slot type)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (move-opnd68-to-loc
+ (make-disp* atemp1 (- (* slot pointer-size) type))
+ loc
+ sn))))
+(define (make-gen-slot-set! slot type)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let* ((first-opnd (car opnds))
+ (second-opnd (cadr opnds))
+ (sn-second-opnd (sn-opnd second-opnd sn-loc)))
+ (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)
+ (move-opnd-to-loc68
+ second-opnd
+ (make-disp* atemp1 (- (* slot pointer-size) type))
+ sn-loc)
+ (if loc
+ (if (not (eq? first-opnd loc))
+ (move-opnd68-to-loc atemp1 loc sn)))))))
+(define (gen-cons opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))
+ (gen-guarantee-space 2)
+ (if (contains-opnd? loc second-opnd)
+ (let ((sn-second-opnd (sn-opnd second-opnd sn-loc)))
+ (move-opnd-to-loc68 first-opnd (make-pdec heap-reg) sn-second-opnd)
+ (move-opnd68-to-loc68 heap-reg atemp2)
+ (move-opnd-to-loc68 second-opnd (make-pdec heap-reg) sn-loc)
+ (move-opnd68-to-loc atemp2 loc sn))
+ (let* ((sn-second-opnd (sn-opnd second-opnd sn))
+ (sn-loc (sn-opnd loc sn-second-opnd)))
+ (move-opnd-to-loc68 first-opnd (make-pdec heap-reg) sn-loc)
+ (move-opnd68-to-loc heap-reg loc sn-second-opnd)
+ (move-opnd-to-loc68 second-opnd (make-pdec heap-reg) sn))))))
+(define (make-gen-apply-c...r pattern)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (let loop ((pattern pattern))
+ (if (<= pattern 3)
+ (if (= pattern 3)
+ (move-opnd68-to-loc (make-pdec atemp1) loc sn)
+ (move-opnd68-to-loc (make-ind atemp1) loc sn))
+ (begin
+ (if (odd? pattern)
+ (emit-move.l (make-pdec atemp1) atemp1)
+ (emit-move.l (make-ind atemp1) atemp1))
+ (loop (quotient pattern 2))))))))
+(define (gen-set-car! opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let* ((first-opnd (car opnds))
+ (second-opnd (cadr opnds))
+ (sn-second-opnd (sn-opnd second-opnd sn-loc)))
+ (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)
+ (move-opnd-to-loc68 second-opnd (make-ind atemp1) sn-loc)
+ (if (and loc (not (eq? first-opnd loc)))
+ (move-opnd68-to-loc atemp1 loc sn)))))
+(define (gen-set-cdr! opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let* ((first-opnd (car opnds))
+ (second-opnd (cadr opnds))
+ (sn-second-opnd (sn-opnd second-opnd sn-loc)))
+ (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)
+ (if (and loc (not (eq? first-opnd loc)))
+ (move-opnd-to-loc68
+ second-opnd
+ (make-disp atemp1 (- pointer-size))
+ sn-loc)
+ (move-opnd-to-loc68 second-opnd (make-pdec atemp1) sn-loc))
+ (if (and loc (not (eq? first-opnd loc)))
+ (move-opnd68-to-loc atemp1 loc sn)))))
+(define (commut-oper gen opnds loc sn self? accum-self accum-other)
+ (if (null? opnds)
+ (gen (reverse accum-self) (reverse accum-other) loc sn self?)
+ (let ((opnd (car opnds)) (rest (cdr opnds)))
+ (cond ((and (not self?) (eq? opnd loc))
+ (commut-oper gen rest loc sn #t accum-self accum-other))
+ ((contains-opnd? loc opnd)
+ (commut-oper
+ gen
+ rest
+ loc
+ sn
+ self?
+ (cons opnd accum-self)
+ accum-other))
+ (else
+ (commut-oper
+ gen
+ rest
+ loc
+ sn
+ self?
+ accum-self
+ (cons opnd accum-other)))))))
+(define (gen-add-in-place opnds loc68 sn)
+ (if (not (null? opnds))
+ (let* ((first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
+ (opnd68 (opnd->opnd68
+ first-opnd
+ (temp-in-opnd68 loc68)
+ (sn-opnd68 loc68 sn))))
+ (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)
+ (if (imm? opnd68)
+ (add-n-to-loc68
+ (imm-val opnd68)
+ (opnd68->true-opnd68 loc68 sn-other-opnds))
+ (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
+ (if (or (dreg? opnd68) (reg68? loc68))
+ (emit-add.l
+ opnd68*
+ (opnd68->true-opnd68 loc68 sn-other-opnds))
+ (begin
+ (move-opnd68-to-loc68 opnd68* dtemp1)
+ (emit-add.l
+ dtemp1
+ (opnd68->true-opnd68 loc68 sn-other-opnds))))))
+ (gen-add-in-place other-opnds loc68 sn))))
+(define (gen-add self-opnds other-opnds loc sn self?)
+ (let* ((opnds (append self-opnds other-opnds))
+ (first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
+ (if (<= (length self-opnds) 1)
+ (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
+ (if self?
+ (gen-add-in-place opnds loc68 sn)
+ (begin
+ (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)
+ (gen-add-in-place other-opnds loc68 sn))))
+ (begin
+ (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
+ (gen-add-in-place other-opnds dtemp1 (sn-opnd loc sn))
+ (if self?
+ (let ((loc68 (loc->loc68 loc dtemp1 sn)))
+ (make-top-of-frame-if-stk-opnd68 loc68 sn)
+ (emit-add.l dtemp1 (opnd68->true-opnd68 loc68 sn)))
+ (move-opnd68-to-loc dtemp1 loc sn))))))
+(define (gen-sub-in-place opnds loc68 sn)
+ (if (not (null? opnds))
+ (let* ((first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
+ (opnd68 (opnd->opnd68
+ first-opnd
+ (temp-in-opnd68 loc68)
+ (sn-opnd68 loc68 sn))))
+ (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)
+ (if (imm? opnd68)
+ (add-n-to-loc68
+ (- (imm-val opnd68))
+ (opnd68->true-opnd68 loc68 sn-other-opnds))
+ (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
+ (if (or (dreg? opnd68) (reg68? loc68))
+ (emit-sub.l
+ opnd68*
+ (opnd68->true-opnd68 loc68 sn-other-opnds))
+ (begin
+ (move-opnd68-to-loc68 opnd68* dtemp1)
+ (emit-sub.l
+ dtemp1
+ (opnd68->true-opnd68 loc68 sn-other-opnds))))))
+ (gen-sub-in-place other-opnds loc68 sn))))
+(define (gen-sub first-opnd other-opnds loc sn self-opnds?)
+ (if (null? other-opnds)
+ (if (and (or (reg? loc) (stk? loc)) (not (eq? loc return-reg)))
+ (begin
+ (copy-opnd-to-loc first-opnd loc (sn-opnd loc sn))
+ (let ((loc68 (loc->loc68 loc #f sn)))
+ (make-top-of-frame-if-stk-opnd68 loc68 sn)
+ (emit-neg.l (opnd68->true-opnd68 loc68 sn))))
+ (begin
+ (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn))
+ (emit-neg.l dtemp1)
+ (move-opnd68-to-loc dtemp1 loc sn)))
+ (let* ((sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
+ (if (and (not self-opnds?) (or (reg? loc) (stk? loc)))
+ (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
+ (if (not (eq? first-opnd loc))
+ (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds))
+ (gen-sub-in-place other-opnds loc68 sn))
+ (begin
+ (move-opnd-to-loc68
+ first-opnd
+ dtemp1
+ (sn-opnd loc sn-other-opnds))
+ (gen-sub-in-place other-opnds dtemp1 (sn-opnd loc sn))
+ (move-opnd68-to-loc dtemp1 loc sn))))))
+(define (gen-mul-in-place opnds reg68 sn)
+ (if (not (null? opnds))
+ (let* ((first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 reg68) sn)))
+ (make-top-of-frame-if-stk-opnd68 opnd68 sn-other-opnds)
+ (if (imm? opnd68)
+ (mul-n-to-reg68 (quotient (imm-val opnd68) 8) reg68)
+ (begin
+ (emit-asr.l (make-imm 3) reg68)
+ (emit-muls.l (opnd68->true-opnd68 opnd68 sn-other-opnds) reg68)))
+ (gen-mul-in-place other-opnds reg68 sn))))
+(define (gen-mul self-opnds other-opnds loc sn self?)
+ (let* ((opnds (append self-opnds other-opnds))
+ (first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
+ (if (null? self-opnds)
+ (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
+ (if self?
+ (gen-mul-in-place opnds loc68 sn)
+ (begin
+ (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)
+ (gen-mul-in-place other-opnds loc68 sn))))
+ (begin
+ (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
+ (gen-mul-in-place other-opnds dtemp1 (sn-opnd loc sn))
+ (if self?
+ (let ((loc68 (loc->loc68 loc dtemp1 sn)))
+ (make-top-of-frame-if-stk-opnd68 loc68 sn)
+ (emit-asr.l (make-imm 3) dtemp1)
+ (emit-muls.l dtemp1 (opnd68->true-opnd68 loc68 sn)))
+ (move-opnd68-to-loc dtemp1 loc sn))))))
+(define (gen-div-in-place opnds reg68 sn)
+ (if (not (null? opnds))
+ (let* ((first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
+ (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 reg68) sn)))
+ (make-top-of-frame-if-stk-opnd68 opnd68 sn-other-opnds)
+ (if (imm? opnd68)
+ (let ((n (quotient (imm-val opnd68) 8)))
+ (div-n-to-reg68 n reg68)
+ (if (> (abs n) 1) (emit-and.w (make-imm -8) reg68)))
+ (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
+ (emit-divsl.l opnd68* reg68 reg68)
+ (emit-asl.l (make-imm 3) reg68)))
+ (gen-div-in-place other-opnds reg68 sn))))
+(define (gen-div first-opnd other-opnds loc sn self-opnds?)
+ (if (null? other-opnds)
+ (begin
+ (move-opnd-to-loc68 first-opnd pdec-sp (sn-opnd loc sn))
+ (emit-moveq 8 dtemp1)
+ (emit-divsl.l pinc-sp dtemp1 dtemp1)
+ (emit-asl.l (make-imm 3) dtemp1)
+ (emit-and.w (make-imm -8) dtemp1)
+ (move-opnd68-to-loc dtemp1 loc sn))
+ (let* ((sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
+ (if (and (reg? loc) (not self-opnds?) (not (eq? loc return-reg)))
+ (let ((reg68 (reg->reg68 loc)))
+ (if (not (eq? first-opnd loc))
+ (move-opnd-to-loc68 first-opnd reg68 sn-other-opnds))
+ (gen-div-in-place other-opnds reg68 sn))
+ (begin
+ (move-opnd-to-loc68
+ first-opnd
+ dtemp1
+ (sn-opnd loc sn-other-opnds))
+ (gen-div-in-place other-opnds dtemp1 (sn-opnd loc sn))
+ (move-opnd68-to-loc dtemp1 loc sn))))))
+(define (gen-rem first-opnd second-opnd loc sn)
+ (let* ((sn-loc (sn-opnd loc sn))
+ (sn-second-opnd (sn-opnd second-opnd sn-loc)))
+ (move-opnd-to-loc68 first-opnd dtemp1 sn-second-opnd)
+ (let ((opnd68 (opnd->opnd68 second-opnd #f sn-loc))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ false-reg)))
+ (make-top-of-frame-if-stk-opnd68 opnd68 sn-loc)
+ (let ((opnd68* (if (areg? opnd68)
+ (begin (emit-move.l opnd68 reg68) reg68)
+ (opnd68->true-opnd68 opnd68 sn-loc))))
+ (emit-divsl.l opnd68* reg68 dtemp1))
+ (move-opnd68-to-loc reg68 loc sn)
+ (if (not (and (reg? loc) (not (eq? loc return-reg))))
+ (emit-move.l (make-imm bits-false) false-reg)))))
+(define (gen-mod first-opnd second-opnd loc sn)
+ (let* ((sn-loc (sn-opnd loc sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-loc))
+ (sn-second-opnd (sn-opnd second-opnd sn-first-opnd))
+ (opnd68 (opnd->opnd68 second-opnd #f sn-second-opnd)))
+ (define (general-case)
+ (let ((lbl1 (new-lbl!))
+ (lbl2 (new-lbl!))
+ (lbl3 (new-lbl!))
+ (opnd68** (opnd68->true-opnd68 opnd68 sn-second-opnd))
+ (opnd68* (opnd68->true-opnd68
+ (opnd->opnd68 first-opnd #f sn-second-opnd)
+ sn-second-opnd)))
+ (move-opnd68-to-loc68 opnd68* dtemp1)
+ (move-opnd68-to-loc68 opnd68** false-reg)
+ (emit-divsl.l false-reg false-reg dtemp1)
+ (emit-move.l false-reg false-reg)
+ (emit-beq lbl3)
+ (move-opnd68-to-loc68 opnd68* dtemp1)
+ (emit-bmi lbl1)
+ (move-opnd68-to-loc68 opnd68** dtemp1)
+ (emit-bpl lbl3)
+ (emit-bra lbl2)
+ (emit-label lbl1)
+ (move-opnd68-to-loc68 opnd68** dtemp1)
+ (emit-bmi lbl3)
+ (emit-label lbl2)
+ (emit-add.l dtemp1 false-reg)
+ (emit-label lbl3)
+ (move-opnd68-to-loc false-reg loc sn)
+ (emit-move.l (make-imm bits-false) false-reg)))
+ (make-top-of-frame-if-stk-opnd68 opnd68 sn-first-opnd)
+ (if (imm? opnd68)
+ (let ((n (quotient (imm-val opnd68) 8)))
+ (if (> n 0)
+ (let ((shift (power-of-2 n)))
+ (if shift
+ (let ((reg68 (if (and (reg? loc)
+ (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (move-opnd-to-loc68 first-opnd reg68 sn-loc)
+ (emit-and.l (make-imm (* (- n 1) 8)) reg68)
+ (move-opnd68-to-loc reg68 loc sn))
+ (general-case)))
+ (general-case)))
+ (general-case))))
+(define (gen-op emit-op dst-ok?)
+ (define (gen-op-in-place opnds loc68 sn)
+ (if (not (null? opnds))
+ (let* ((first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
+ (opnd68 (opnd->opnd68
+ first-opnd
+ (temp-in-opnd68 loc68)
+ (sn-opnd68 loc68 sn))))
+ (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)
+ (if (imm? opnd68)
+ (emit-op opnd68 (opnd68->true-opnd68 loc68 sn-other-opnds))
+ (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
+ (if (or (dreg? opnd68) (dst-ok? loc68))
+ (emit-op opnd68*
+ (opnd68->true-opnd68 loc68 sn-other-opnds))
+ (begin
+ (move-opnd68-to-loc68 opnd68* dtemp1)
+ (emit-op dtemp1
+ (opnd68->true-opnd68 loc68 sn-other-opnds))))))
+ (gen-op-in-place other-opnds loc68 sn))))
+ (lambda (self-opnds other-opnds loc sn self?)
+ (let* ((opnds (append self-opnds other-opnds))
+ (first-opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn))
+ (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
+ (if (<= (length self-opnds) 1)
+ (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
+ (if self?
+ (gen-op-in-place opnds loc68 sn)
+ (begin
+ (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)
+ (gen-op-in-place other-opnds loc68 sn))))
+ (begin
+ (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
+ (gen-op-in-place other-opnds dtemp1 (sn-opnd loc sn))
+ (if self?
+ (let ((loc68 (loc->loc68 loc dtemp1 sn)))
+ (make-top-of-frame-if-stk-opnd68 loc68 sn)
+ (emit-op dtemp1 (opnd68->true-opnd68 loc68 sn)))
+ (move-opnd68-to-loc dtemp1 loc sn)))))))
+(define gen-logior (gen-op emit-or.l dreg?))
+(define gen-logxor (gen-op emit-eor.l (lambda (x) #f)))
+(define gen-logand (gen-op emit-and.l dreg?))
+(define (gen-shift right-shift)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (let* ((opnd1 (car opnds))
+ (opnd2 (cadr opnds))
+ (sn-opnd1 (sn-opnd opnd1 sn-loc))
+ (o2 (opnd->opnd68 opnd2 #f sn-opnd1)))
+ (make-top-of-frame-if-stk-opnd68 o2 sn-opnd1)
+ (if (imm? o2)
+ (let* ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1))
+ (n (quotient (imm-val o2) 8))
+ (emit-shft (if (> n 0) emit-lsl.l right-shift)))
+ (move-opnd-to-loc68 opnd1 reg68 sn-loc)
+ (let loop ((i (min (abs n) 29)))
+ (if (> i 0)
+ (begin
+ (emit-shft (make-imm (min i 8)) reg68)
+ (loop (- i 8)))))
+ (if (< n 0) (emit-and.w (make-imm -8) reg68))
+ (move-opnd68-to-loc reg68 loc sn))
+ (let* ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1))
+ (reg68* (if (and (reg? loc) (not (eq? loc return-reg)))
+ dtemp1
+ false-reg))
+ (lbl1 (new-lbl!))
+ (lbl2 (new-lbl!)))
+ (emit-move.l (opnd68->true-opnd68 o2 sn-opnd1) reg68*)
+ (move-opnd-to-loc68 opnd1 reg68 sn-loc)
+ (emit-asr.l (make-imm 3) reg68*)
+ (emit-bmi lbl1)
+ (emit-lsl.l reg68* reg68)
+ (emit-bra lbl2)
+ (emit-label lbl1)
+ (emit-neg.l reg68*)
+ (right-shift reg68* reg68)
+ (emit-and.w (make-imm -8) reg68)
+ (emit-label lbl2)
+ (move-opnd68-to-loc reg68 loc sn)
+ (if (not (and (reg? loc) (not (eq? loc return-reg))))
+ (emit-move.l (make-imm bits-false) false-reg))))))))
+(define (flo-oper oper1 oper2 opnds loc sn)
+ (gen-guarantee-space 2)
+ (move-opnd-to-loc68
+ (car opnds)
+ atemp1
+ (sn-opnds (cdr opnds) (sn-opnd loc sn)))
+ (oper1 (make-disp* atemp1 (- type-flonum)) ftemp1)
+ (let loop ((opnds (cdr opnds)))
+ (if (not (null? opnds))
+ (let* ((opnd (car opnds))
+ (other-opnds (cdr opnds))
+ (sn-other-opnds (sn-opnds other-opnds sn)))
+ (move-opnd-to-loc68 opnd atemp1 sn-other-opnds)
+ (oper2 (make-disp* atemp1 (- type-flonum)) ftemp1)
+ (loop (cdr opnds)))))
+ (add-n-to-loc68 (* -2 pointer-size) heap-reg)
+ (emit-fmov.dx ftemp1 (make-ind heap-reg))
+ (let ((reg68 (if (reg? loc) (reg->reg68 loc) atemp1)))
+ (emit-move.l heap-reg reg68)
+ (emit-addq.l type-flonum reg68))
+ (if (not (reg? loc)) (move-opnd68-to-loc atemp1 loc sn)))
+(define (gen-make-placeholder opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (let ((opnd (car opnds)))
+ (gen-guarantee-space 4)
+ (emit-clr.l (make-pdec heap-reg))
+ (move-opnd-to-loc68 opnd (make-pdec heap-reg) sn-loc)
+ (emit-move.l null-reg (make-pdec heap-reg))
+ (move-opnd68-to-loc68 heap-reg atemp2)
+ (emit-addq.l (modulo (- type-placeholder type-pair) 8) atemp2)
+ (emit-move.l atemp2 (make-pdec heap-reg))
+ (move-opnd68-to-loc atemp2 loc sn))))
+(define (gen-subprocedure-id opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))
+ (opnd (car opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (move-n-to-loc68 32768 reg68)
+ (emit-sub.w (make-disp* atemp1 -2) reg68)
+ (move-opnd68-to-loc reg68 loc sn)))
+(define (gen-subprocedure-parent opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (emit-add.w (make-disp* atemp1 -2) atemp1)
+ (add-n-to-loc68 -32768 atemp1)
+ (move-opnd68-to-loc atemp1 loc sn)))
+(define (gen-return-fs opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))
+ (opnd (car opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1))
+ (lbl (new-lbl!)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (emit-moveq 0 reg68)
+ (emit-move.w (make-disp* atemp1 -6) reg68)
+ (emit-beq lbl)
+ (emit-and.w (make-imm 32767) reg68)
+ (emit-subq.l 8 reg68)
+ (emit-label lbl)
+ (emit-addq.l 8 reg68)
+ (emit-asl.l (make-imm 1) reg68)
+ (move-opnd68-to-loc reg68 loc sn)))
+(define (gen-return-link opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))
+ (opnd (car opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1))
+ (lbl (new-lbl!)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (emit-moveq 0 reg68)
+ (emit-move.w (make-disp* atemp1 -6) reg68)
+ (emit-beq lbl)
+ (emit-and.w (make-imm 32767) reg68)
+ (emit-subq.l 8 reg68)
+ (emit-label lbl)
+ (emit-addq.l 8 reg68)
+ (emit-sub.w (make-disp* atemp1 -4) reg68)
+ (emit-asl.l (make-imm 1) reg68)
+ (move-opnd68-to-loc reg68 loc sn)))
+(define (gen-procedure-info opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (emit-add.w (make-disp* atemp1 -2) atemp1)
+ (move-opnd68-to-loc (make-disp* atemp1 (- 32768 6)) loc sn)))
+(define (gen-guarantee-space n)
+ (set! pointers-allocated (+ pointers-allocated n))
+ (if (> pointers-allocated heap-allocation-fudge)
+ (begin (gen-guarantee-fudge) (set! pointers-allocated n))))
+(define (gen-guarantee-fudge)
+ (if (> pointers-allocated 0)
+ (let ((lbl (new-lbl!)))
+ (emit-cmp.l heap-lim-slot heap-reg)
+ (emit-bcc lbl)
+ (gen-trap instr-source entry-frame #f #f heap-alloc1-trap lbl)
+ (set! pointers-allocated 0))))
+(define pointers-allocated '())
+(define (gen-type opnds loc sn)
+ (let* ((sn-loc (sn-opnd loc sn))
+ (opnd (car opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (move-opnd-to-loc68 opnd reg68 sn-loc)
+ (emit-and.l (make-imm 7) reg68)
+ (emit-asl.l (make-imm 3) reg68)
+ (move-opnd68-to-loc reg68 loc sn)))
+(define (gen-type-cast opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))
+ (let* ((sn-loc (if (and loc (not (eq? first-opnd loc))) sn-loc sn))
+ (o1 (opnd->opnd68 first-opnd #f (sn-opnd second-opnd sn-loc)))
+ (o2 (opnd->opnd68 second-opnd (temp-in-opnd68 o1) sn-loc))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o1 (sn-opnd68 o2 sn-loc))
+ reg68)
+ (emit-and.w (make-imm -8) reg68)
+ (if (imm? o2)
+ (let ((n (quotient (imm-val o2) 8)))
+ (if (> n 0) (emit-addq.w n reg68)))
+ (begin
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 o2 sn-loc) atemp1)
+ (emit-exg atemp1 reg68)
+ (emit-asr.l (make-imm 3) reg68)
+ (emit-add.l atemp1 reg68)))
+ (move-opnd68-to-loc reg68 loc sn)))))
+(define (gen-subtype opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))
+ (opnd (car opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (emit-moveq 0 reg68)
+ (emit-move.b (make-ind atemp1) reg68)
+ (move-opnd68-to-loc reg68 loc sn)))
+(define (gen-subtype-set! opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))
+ (let* ((sn-loc (if (and loc (not (eq? first-opnd loc))) sn-loc sn))
+ (o1 (opnd->opnd68 first-opnd #f (sn-opnd second-opnd sn-loc)))
+ (o2 (opnd->opnd68 second-opnd (temp-in-opnd68 o1) sn-loc)))
+ (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o1 (sn-opnd68 o2 sn-loc))
+ atemp1)
+ (if (imm? o2)
+ (emit-move.b (make-imm (imm-val o2)) (make-ind atemp1))
+ (begin
+ (move-opnd68-to-loc68 (opnd68->true-opnd68 o2 sn-loc) dtemp1)
+ (emit-move.b dtemp1 (make-ind atemp1))))
+ (if (and loc (not (eq? first-opnd loc)))
+ (move-opnd68-to-loc atemp1 loc sn))))))
+(define (vector-select kind vector string vector8 vector16)
+ (case kind
+ ((string) string)
+ ((vector8) vector8)
+ ((vector16) vector16)
+ (else vector)))
+(define (obj-vector? kind) (vector-select kind #t #f #f #f))
+(define (make-gen-vector kind)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let* ((n (length opnds))
+ (bytes (+ pointer-size
+ (* (vector-select kind 4 1 1 2)
+ (+ n (if (eq? kind 'string) 1 0)))))
+ (adjust (modulo (- bytes) 8)))
+ (gen-guarantee-space
+ (quotient (* (quotient (+ bytes (- 8 1)) 8) 8) pointer-size))
+ (if (not (= adjust 0)) (emit-subq.l adjust heap-reg))
+ (if (eq? kind 'string) (emit-move.b (make-imm 0) (make-pdec heap-reg)))
+ (let loop ((opnds (reverse opnds)))
+ (if (pair? opnds)
+ (let* ((o (car opnds)) (sn-o (sn-opnds (cdr opnds) sn-loc)))
+ (if (eq? kind 'vector)
+ (move-opnd-to-loc68 o (make-pdec heap-reg) sn-o)
+ (begin
+ (move-opnd-to-loc68 o dtemp1 sn-o)
+ (emit-asr.l (make-imm 3) dtemp1)
+ (if (eq? kind 'vector16)
+ (emit-move.w dtemp1 (make-pdec heap-reg))
+ (emit-move.b dtemp1 (make-pdec heap-reg)))))
+ (loop (cdr opnds)))))
+ (emit-move.l
+ (make-imm
+ (+ (* 256 (- bytes pointer-size))
+ (* 8 (if (eq? kind 'vector) subtype-vector subtype-string))))
+ (make-pdec heap-reg))
+ (if loc
+ (begin
+ (emit-lea (make-disp* heap-reg type-subtyped) atemp2)
+ (move-opnd68-to-loc atemp2 loc sn)))))))
+(define (make-gen-vector-length kind)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))
+ (opnd (car opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (move-opnd-to-loc68 opnd atemp1 sn-loc)
+ (move-opnd68-to-loc68 (make-disp* atemp1 (- type-subtyped)) reg68)
+ (emit-lsr.l (make-imm (vector-select kind 7 5 5 6)) reg68)
+ (if (not (eq? kind 'vector))
+ (begin
+ (emit-and.w (make-imm -8) reg68)
+ (if (eq? kind 'string) (emit-subq.l 8 reg68))))
+ (move-opnd68-to-loc reg68 loc sn))))
+(define (make-gen-vector-ref kind)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (let ((first-opnd (car opnds))
+ (second-opnd (cadr opnds))
+ (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (let* ((o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-loc)))
+ (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-loc)))
+ (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
+ (let* ((offset (if (eq? kind 'closure)
+ (- pointer-size type-procedure)
+ (- pointer-size type-subtyped)))
+ (loc68 (if (imm? o2)
+ (begin
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o1 sn-loc)
+ atemp1)
+ (make-disp*
+ atemp1
+ (+ (quotient
+ (imm-val o2)
+ (vector-select kind 2 8 8 4))
+ offset)))
+ (begin
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))
+ dtemp1)
+ (emit-asr.l
+ (make-imm (vector-select kind 1 3 3 2))
+ dtemp1)
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o1 sn-loc)
+ atemp1)
+ (if (and (identical-opnd68? reg68 dtemp1)
+ (not (obj-vector? kind)))
+ (begin
+ (emit-move.l dtemp1 atemp2)
+ (make-inx atemp1 atemp2 offset))
+ (make-inx atemp1 dtemp1 offset))))))
+ (if (not (obj-vector? kind)) (emit-moveq 0 reg68))
+ (case kind
+ ((string vector8) (emit-move.b loc68 reg68))
+ ((vector16) (emit-move.w loc68 reg68))
+ (else (emit-move.l loc68 reg68)))
+ (if (not (obj-vector? kind))
+ (begin
+ (emit-asl.l (make-imm 3) reg68)
+ (if (eq? kind 'string) (emit-addq.w type-special reg68))))
+ (move-opnd68-to-loc reg68 loc sn)))))))
+(define (make-gen-vector-set! kind)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let ((first-opnd (car opnds))
+ (second-opnd (cadr opnds))
+ (third-opnd (caddr opnds)))
+ (let* ((sn-loc (if (and loc (not (eq? first-opnd loc)))
+ (sn-opnd first-opnd sn-loc)
+ sn))
+ (sn-third-opnd (sn-opnd third-opnd sn-loc))
+ (o2 (opnd->opnd68
+ second-opnd
+ #f
+ (sn-opnd first-opnd sn-third-opnd)))
+ (o1 (opnd->opnd68
+ first-opnd
+ (temp-in-opnd68 o2)
+ sn-third-opnd)))
+ (make-top-of-frame-if-stk-opnds68 o1 o2 sn-third-opnd)
+ (let* ((offset (if (eq? kind 'closure)
+ (- pointer-size type-procedure)
+ (- pointer-size type-subtyped)))
+ (loc68 (if (imm? o2)
+ (begin
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o1 sn-third-opnd)
+ atemp1)
+ (make-disp*
+ atemp1
+ (+ (quotient
+ (imm-val o2)
+ (vector-select kind 2 8 8 4))
+ offset)))
+ (begin
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))
+ dtemp1)
+ (emit-asr.l
+ (make-imm (vector-select kind 1 3 3 2))
+ dtemp1)
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o1 sn-loc)
+ atemp1)
+ (if (obj-vector? kind)
+ (make-inx atemp1 dtemp1 offset)
+ (begin
+ (emit-move.l dtemp1 atemp2)
+ (make-inx atemp1 atemp2 offset)))))))
+ (if (obj-vector? kind)
+ (move-opnd-to-loc68 third-opnd loc68 sn-loc)
+ (begin
+ (move-opnd-to-loc68 third-opnd dtemp1 sn-loc)
+ (emit-asr.l (make-imm 3) dtemp1)
+ (if (eq? kind 'vector16)
+ (emit-move.w dtemp1 loc68)
+ (emit-move.b dtemp1 loc68))))
+ (if (and loc (not (eq? first-opnd loc)))
+ (copy-opnd-to-loc first-opnd loc sn))))))))
+(define (make-gen-vector-shrink! kind)
+ (lambda (opnds loc sn)
+ (let ((sn-loc (if loc (sn-opnd loc sn) sn)))
+ (let ((first-opnd (car opnds)) (second-opnd (cadr opnds)))
+ (let* ((sn-loc (if (and loc (not (eq? first-opnd loc)))
+ (sn-opnd first-opnd sn-loc)
+ sn))
+ (o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-loc)))
+ (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-loc)))
+ (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
+ (move-opnd68-to-loc68
+ (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))
+ dtemp1)
+ (emit-move.l (opnd68->true-opnd68 o1 sn-loc) atemp1)
+ (if (eq? kind 'string)
+ (begin
+ (emit-asr.l (make-imm 3) dtemp1)
+ (emit-move.b
+ (make-imm 0)
+ (make-inx atemp1 dtemp1 (- pointer-size type-subtyped)))
+ (emit-addq.l 1 dtemp1)
+ (emit-asl.l (make-imm 8) dtemp1))
+ (emit-asl.l (make-imm (vector-select kind 7 5 5 6)) dtemp1))
+ (emit-move.b (make-ind atemp1) dtemp1)
+ (emit-move.l dtemp1 (make-disp* atemp1 (- type-subtyped)))
+ (if (and loc (not (eq? first-opnd loc)))
+ (move-opnd68-to-loc atemp1 loc sn)))))))
+(define (gen-eq-test bits not? opnds lbl fs)
+ (gen-compare* (opnd->opnd68 (car opnds) #f fs) (make-imm bits) fs)
+ (if not? (emit-bne lbl) (emit-beq lbl)))
+(define (gen-compare opnd1 opnd2 fs)
+ (let* ((o1 (opnd->opnd68 opnd1 #f (sn-opnd opnd2 fs)))
+ (o2 (opnd->opnd68 opnd2 (temp-in-opnd68 o1) fs)))
+ (gen-compare* o1 o2 fs)))
+(define (gen-compare* o1 o2 fs)
+ (make-top-of-frame-if-stk-opnds68 o1 o2 fs)
+ (let ((order-1-2
+ (cond ((imm? o1)
+ (cmp-n-to-opnd68 (imm-val o1) (opnd68->true-opnd68 o2 fs)))
+ ((imm? o2)
+ (not (cmp-n-to-opnd68
+ (imm-val o2)
+ (opnd68->true-opnd68 o1 fs))))
+ ((reg68? o1) (emit-cmp.l (opnd68->true-opnd68 o2 fs) o1) #f)
+ ((reg68? o2) (emit-cmp.l (opnd68->true-opnd68 o1 fs) o2) #t)
+ (else
+ (emit-move.l (opnd68->true-opnd68 o1 (sn-opnd68 o2 fs)) dtemp1)
+ (emit-cmp.l (opnd68->true-opnd68 o2 fs) dtemp1)
+ #f))))
+ (shrink-frame fs)
+ order-1-2))
+(define (gen-compares branch< branch>= branch> branch<= not? opnds lbl fs)
+ (gen-compares*
+ gen-compare
+ branch<
+ branch>=
+ branch>
+ branch<=
+ not?
+ opnds
+ lbl
+ fs))
+(define (gen-compares*
+ gen-comp
+ branch<
+ branch>=
+ branch>
+ branch<=
+ not?
+ opnds
+ lbl
+ fs)
+ (define (gen-compare-sequence opnd1 opnd2 rest)
+ (if (null? rest)
+ (if (gen-comp opnd1 opnd2 fs)
+ (if not? (branch<= lbl) (branch> lbl))
+ (if not? (branch>= lbl) (branch< lbl)))
+ (let ((order-1-2
+ (gen-comp opnd1 opnd2 (sn-opnd opnd2 (sn-opnds rest fs)))))
+ (if (= current-fs fs)
+ (if not?
+ (begin
+ (if order-1-2 (branch<= lbl) (branch>= lbl))
+ (gen-compare-sequence opnd2 (car rest) (cdr rest)))
+ (let ((exit-lbl (new-lbl!)))
+ (if order-1-2 (branch<= exit-lbl) (branch>= exit-lbl))
+ (gen-compare-sequence opnd2 (car rest) (cdr rest))
+ (emit-label exit-lbl)))
+ (if not?
+ (let ((next-lbl (new-lbl!)))
+ (if order-1-2 (branch> next-lbl) (branch< next-lbl))
+ (shrink-frame fs)
+ (emit-bra lbl)
+ (emit-label next-lbl)
+ (gen-compare-sequence opnd2 (car rest) (cdr rest)))
+ (let* ((next-lbl (new-lbl!)) (exit-lbl (new-lbl!)))
+ (if order-1-2 (branch> next-lbl) (branch< next-lbl))
+ (shrink-frame fs)
+ (emit-bra exit-lbl)
+ (emit-label next-lbl)
+ (gen-compare-sequence opnd2 (car rest) (cdr rest))
+ (emit-label exit-lbl)))))))
+ (if (or (null? opnds) (null? (cdr opnds)))
+ (begin (shrink-frame fs) (if (not not?) (emit-bra lbl)))
+ (gen-compare-sequence (car opnds) (cadr opnds) (cddr opnds))))
+(define (gen-compare-flo opnd1 opnd2 fs)
+ (let* ((o1 (opnd->opnd68 opnd1 #f (sn-opnd opnd2 fs)))
+ (o2 (opnd->opnd68 opnd2 (temp-in-opnd68 o1) fs)))
+ (make-top-of-frame-if-stk-opnds68 o1 o2 fs)
+ (emit-move.l (opnd68->true-opnd68 o1 (sn-opnd68 o2 fs)) atemp1)
+ (emit-move.l (opnd68->true-opnd68 o2 fs) atemp2)
+ (emit-fmov.dx (make-disp* atemp2 (- type-flonum)) ftemp1)
+ (emit-fcmp.dx (make-disp* atemp1 (- type-flonum)) ftemp1)
+ #t))
+(define (gen-compares-flo branch< branch>= branch> branch<= not? opnds lbl fs)
+ (gen-compares*
+ gen-compare-flo
+ branch<
+ branch>=
+ branch>
+ branch<=
+ not?
+ opnds
+ lbl
+ fs))
+(define (gen-type-test tag not? opnds lbl fs)
+ (let ((opnd (car opnds)))
+ (let ((o (opnd->opnd68 opnd #f fs)))
+ (define (mask-test set-reg correction)
+ (emit-btst
+ (if (= correction 0)
+ (if (dreg? o)
+ o
+ (begin
+ (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)
+ dtemp1))
+ (begin
+ (if (not (eq? o dtemp1))
+ (emit-move.l (opnd68->true-opnd68 o fs) dtemp1))
+ (emit-addq.w correction dtemp1)
+ dtemp1))
+ set-reg))
+ (make-top-of-frame-if-stk-opnd68 o fs)
+ (cond ((= tag 0)
+ (if (eq? o dtemp1)
+ (emit-and.w (make-imm 7) dtemp1)
+ (begin
+ (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)
+ (emit-and.w (make-imm 7) dtemp1))))
+ ((= tag type-placeholder) (mask-test placeholder-reg 0))
+ (else (mask-test pair-reg (modulo (- type-pair tag) 8))))
+ (shrink-frame fs)
+ (if not? (emit-bne lbl) (emit-beq lbl)))))
+(define (gen-subtype-test type not? opnds lbl fs)
+ (let ((opnd (car opnds)))
+ (let ((o (opnd->opnd68 opnd #f fs)) (cont-lbl (new-lbl!)))
+ (make-top-of-frame-if-stk-opnd68 o fs)
+ (if (not (eq? o dtemp1)) (emit-move.l (opnd68->true-opnd68 o fs) dtemp1))
+ (emit-move.l dtemp1 atemp1)
+ (emit-addq.w (modulo (- type-pair type-subtyped) 8) dtemp1)
+ (emit-btst dtemp1 pair-reg)
+ (shrink-frame fs)
+ (if not? (emit-bne lbl) (emit-bne cont-lbl))
+ (emit-cmp.b (make-imm (* type 8)) (make-ind atemp1))
+ (if not? (emit-bne lbl) (emit-beq lbl))
+ (emit-label cont-lbl))))
+(define (gen-even-test not? opnds lbl fs)
+ (move-opnd-to-loc68 (car opnds) dtemp1 fs)
+ (emit-and.w (make-imm 8) dtemp1)
+ (shrink-frame fs)
+ (if not? (emit-bne lbl) (emit-beq lbl)))
+(define (def-spec name specializer-maker)
+ (let ((proc-name (string->canonical-symbol name)))
+ (let ((proc (prim-info proc-name)))
+ (if proc
+ (proc-obj-specialize-set! proc (specializer-maker proc proc-name))
+ (compiler-internal-error "def-spec, unknown primitive:" name)))))
+(define (safe name)
+ (lambda (proc proc-name)
+ (let ((spec (get-prim-info name))) (lambda (decls) spec))))
+(define (unsafe name)
+ (lambda (proc proc-name)
+ (let ((spec (get-prim-info name)))
+ (lambda (decls) (if (not (safe? decls)) spec proc)))))
+(define (safe-arith fix-name flo-name) (arith #t fix-name flo-name))
+(define (unsafe-arith fix-name flo-name) (arith #f fix-name flo-name))
+(define (arith fix-safe? fix-name flo-name)
+ (lambda (proc proc-name)
+ (let ((fix-spec (if fix-name (get-prim-info fix-name) proc))
+ (flo-spec (if flo-name (get-prim-info flo-name) proc)))
+ (lambda (decls)
+ (let ((arith (arith-implementation proc-name decls)))
+ (cond ((eq? arith fixnum-sym)
+ (if (or fix-safe? (not (safe? decls))) fix-spec proc))
+ ((eq? arith flonum-sym) (if (not (safe? decls)) flo-spec proc))
+ (else proc)))))))
+(define-apply "##TYPE" #f (lambda (opnds loc sn) (gen-type opnds loc sn)))
+(define-apply
+ "##TYPE-CAST"
+ #f
+ (lambda (opnds loc sn) (gen-type-cast opnds loc sn)))
+(define-apply
+ "##SUBTYPE"
+ #f
+ (lambda (opnds loc sn) (gen-subtype opnds loc sn)))
+(define-apply
+ "##SUBTYPE-SET!"
+ #t
+ (lambda (opnds loc sn) (gen-subtype-set! opnds loc sn)))
+(define-ifjump
+ "##NOT"
+ (lambda (not? opnds lbl fs) (gen-eq-test bits-false not? opnds lbl fs)))
+(define-ifjump
+ "##NULL?"
+ (lambda (not? opnds lbl fs) (gen-eq-test bits-null not? opnds lbl fs)))
+(define-ifjump
+ "##UNASSIGNED?"
+ (lambda (not? opnds lbl fs) (gen-eq-test bits-unass not? opnds lbl fs)))
+(define-ifjump
+ "##UNBOUND?"
+ (lambda (not? opnds lbl fs) (gen-eq-test bits-unbound not? opnds lbl fs)))
+(define-ifjump
+ "##EQ?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-beq emit-bne emit-beq emit-bne not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM?"
+ (lambda (not? opnds lbl fs) (gen-type-test type-fixnum not? opnds lbl fs)))
+(define-ifjump
+ "##FLONUM?"
+ (lambda (not? opnds lbl fs) (gen-type-test type-flonum not? opnds lbl fs)))
+(define-ifjump
+ "##SPECIAL?"
+ (lambda (not? opnds lbl fs) (gen-type-test type-special not? opnds lbl fs)))
+(define-ifjump
+ "##PAIR?"
+ (lambda (not? opnds lbl fs) (gen-type-test type-pair not? opnds lbl fs)))
+(define-ifjump
+ "##SUBTYPED?"
+ (lambda (not? opnds lbl fs) (gen-type-test type-subtyped not? opnds lbl fs)))
+(define-ifjump
+ "##PROCEDURE?"
+ (lambda (not? opnds lbl fs) (gen-type-test type-procedure not? opnds lbl fs)))
+(define-ifjump
+ "##PLACEHOLDER?"
+ (lambda (not? opnds lbl fs)
+ (gen-type-test type-placeholder not? opnds lbl fs)))
+(define-ifjump
+ "##VECTOR?"
+ (lambda (not? opnds lbl fs)
+ (gen-subtype-test subtype-vector not? opnds lbl fs)))
+(define-ifjump
+ "##SYMBOL?"
+ (lambda (not? opnds lbl fs)
+ (gen-subtype-test subtype-symbol not? opnds lbl fs)))
+(define-ifjump
+ "##RATNUM?"
+ (lambda (not? opnds lbl fs)
+ (gen-subtype-test subtype-ratnum not? opnds lbl fs)))
+(define-ifjump
+ "##CPXNUM?"
+ (lambda (not? opnds lbl fs)
+ (gen-subtype-test subtype-cpxnum not? opnds lbl fs)))
+(define-ifjump
+ "##STRING?"
+ (lambda (not? opnds lbl fs)
+ (gen-subtype-test subtype-string not? opnds lbl fs)))
+(define-ifjump
+ "##BIGNUM?"
+ (lambda (not? opnds lbl fs)
+ (gen-subtype-test subtype-bignum not? opnds lbl fs)))
+(define-ifjump
+ "##CHAR?"
+ (lambda (not? opnds lbl fs)
+ (let ((opnd (car opnds)))
+ (let ((o (opnd->opnd68 opnd #f fs)) (cont-lbl (new-lbl!)))
+ (make-top-of-frame-if-stk-opnd68 o fs)
+ (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)
+ (if not? (emit-bmi lbl) (emit-bmi cont-lbl))
+ (emit-addq.w (modulo (- type-pair type-special) 8) dtemp1)
+ (emit-btst dtemp1 pair-reg)
+ (shrink-frame fs)
+ (if not? (emit-bne lbl) (emit-beq lbl))
+ (emit-label cont-lbl)))))
+(define-ifjump
+ "##CLOSURE?"
+ (lambda (not? opnds lbl fs)
+ (move-opnd-to-loc68 (car opnds) atemp1 fs)
+ (shrink-frame fs)
+ (emit-cmp.w (make-imm 20153) (make-ind atemp1))
+ (if not? (emit-bne lbl) (emit-beq lbl))))
+(define-ifjump
+ "##SUBPROCEDURE?"
+ (lambda (not? opnds lbl fs)
+ (move-opnd-to-loc68 (car opnds) atemp1 fs)
+ (shrink-frame fs)
+ (emit-move.w (make-pdec atemp1) dtemp1)
+ (if not? (emit-bmi lbl) (emit-bpl lbl))))
+(define-ifjump
+ "##RETURN-DYNAMIC-ENV-BIND?"
+ (lambda (not? opnds lbl fs)
+ (move-opnd-to-loc68 (car opnds) atemp1 fs)
+ (shrink-frame fs)
+ (emit-move.w (make-disp* atemp1 -6) dtemp1)
+ (if not? (emit-bne lbl) (emit-beq lbl))))
+(define-apply
+ "##FIXNUM.+"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj '0) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ ((or (reg? loc) (stk? loc))
+ (commut-oper gen-add opnds loc sn #f '() '()))
+ (else (gen-add opnds '() loc sn #f))))))
+(define-apply
+ "##FIXNUM.-"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (gen-sub (car opnds)
+ (cdr opnds)
+ loc
+ sn
+ (any-contains-opnd? loc (cdr opnds))))))
+(define-apply
+ "##FIXNUM.*"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj '1) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ ((and (reg? loc) (not (eq? loc return-reg)))
+ (commut-oper gen-mul opnds loc sn #f '() '()))
+ (else (gen-mul opnds '() loc sn #f))))))
+(define-apply
+ "##FIXNUM.QUOTIENT"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (gen-div (car opnds)
+ (cdr opnds)
+ loc
+ sn
+ (any-contains-opnd? loc (cdr opnds))))))
+(define-apply
+ "##FIXNUM.REMAINDER"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (gen-rem (car opnds) (cadr opnds) loc sn))))
+(define-apply
+ "##FIXNUM.MODULO"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (gen-mod (car opnds) (cadr opnds) loc sn))))
+(define-apply
+ "##FIXNUM.LOGIOR"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj '0) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ ((or (reg? loc) (stk? loc))
+ (commut-oper gen-logior opnds loc sn #f '() '()))
+ (else (gen-logior opnds '() loc sn #f))))))
+(define-apply
+ "##FIXNUM.LOGXOR"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj '0) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ ((or (reg? loc) (stk? loc))
+ (commut-oper gen-logxor opnds loc sn #f '() '()))
+ (else (gen-logxor opnds '() loc sn #f))))))
+(define-apply
+ "##FIXNUM.LOGAND"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj '-1) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ ((or (reg? loc) (stk? loc))
+ (commut-oper gen-logand opnds loc sn #f '() '()))
+ (else (gen-logand opnds '() loc sn #f))))))
+(define-apply
+ "##FIXNUM.LOGNOT"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)) (opnd (car opnds)))
+ (if (and (or (reg? loc) (stk? loc)) (not (eq? loc return-reg)))
+ (begin
+ (copy-opnd-to-loc opnd loc sn-loc)
+ (let ((loc68 (loc->loc68 loc #f sn)))
+ (make-top-of-frame-if-stk-opnd68 loc68 sn)
+ (emit-not.l (opnd68->true-opnd68 loc68 sn))
+ (emit-and.w (make-imm -8) (opnd68->true-opnd68 loc68 sn))))
+ (begin
+ (move-opnd-to-loc68 opnd dtemp1 (sn-opnd loc sn))
+ (emit-not.l dtemp1)
+ (emit-and.w (make-imm -8) dtemp1)
+ (move-opnd68-to-loc dtemp1 loc sn))))))
+(define-apply "##FIXNUM.ASH" #f (gen-shift emit-asr.l))
+(define-apply "##FIXNUM.LSH" #f (gen-shift emit-lsr.l))
+(define-ifjump
+ "##FIXNUM.ZERO?"
+ (lambda (not? opnds lbl fs) (gen-eq-test 0 not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.POSITIVE?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares
+ emit-bgt
+ emit-ble
+ emit-blt
+ emit-bge
+ not?
+ (list (car opnds) (make-obj '0))
+ lbl
+ fs)))
+(define-ifjump
+ "##FIXNUM.NEGATIVE?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares
+ emit-blt
+ emit-bge
+ emit-bgt
+ emit-ble
+ not?
+ (list (car opnds) (make-obj '0))
+ lbl
+ fs)))
+(define-ifjump
+ "##FIXNUM.ODD?"
+ (lambda (not? opnds lbl fs) (gen-even-test (not not?) opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.EVEN?"
+ (lambda (not? opnds lbl fs) (gen-even-test not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.="
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-beq emit-bne emit-beq emit-bne not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.<"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-blt emit-bge emit-bgt emit-ble not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.>"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-bgt emit-ble emit-blt emit-bge not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.<="
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-ble emit-bgt emit-bge emit-blt not? opnds lbl fs)))
+(define-ifjump
+ "##FIXNUM.>="
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-bge emit-blt emit-ble emit-bgt not? opnds lbl fs)))
+(define-apply
+ "##FLONUM.->FIXNUM"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (move-opnd-to-loc68 (car opnds) atemp1 sn-loc)
+ (let ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
+ (reg->reg68 loc)
+ dtemp1)))
+ (emit-fmov.dx (make-disp* atemp1 (- type-flonum)) ftemp1)
+ (emit-fmov.l ftemp1 reg68)
+ (emit-asl.l (make-imm 3) reg68)
+ (if (not (and (reg? loc) (not (eq? loc return-reg))))
+ (move-opnd68-to-loc reg68 loc sn))))))
+(define-apply
+ "##FLONUM.<-FIXNUM"
+ #f
+ (lambda (opnds loc sn)
+ (gen-guarantee-space 2)
+ (move-opnd-to-loc68
+ (car opnds)
+ dtemp1
+ (sn-opnds (cdr opnds) (sn-opnd loc sn)))
+ (emit-asr.l (make-imm 3) dtemp1)
+ (emit-fmov.l dtemp1 ftemp1)
+ (add-n-to-loc68 (* -2 pointer-size) heap-reg)
+ (emit-fmov.dx ftemp1 (make-ind heap-reg))
+ (let ((reg68 (if (reg? loc) (reg->reg68 loc) atemp1)))
+ (emit-move.l heap-reg reg68)
+ (emit-addq.l type-flonum reg68))
+ (if (not (reg? loc)) (move-opnd68-to-loc atemp1 loc sn))))
+(define-apply
+ "##FLONUM.+"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj inexact-0) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ (else (flo-oper emit-fmov.dx emit-fadd.dx opnds loc sn))))))
+(define-apply
+ "##FLONUM.*"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (cond ((null? opnds) (copy-opnd-to-loc (make-obj inexact-+1) loc sn))
+ ((null? (cdr opnds)) (copy-opnd-to-loc (car opnds) loc sn))
+ (else (flo-oper emit-fmov.dx emit-fmul.dx opnds loc sn))))))
+(define-apply
+ "##FLONUM.-"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (if (null? (cdr opnds))
+ (flo-oper emit-fneg.dx #f opnds loc sn)
+ (flo-oper emit-fmov.dx emit-fsub.dx opnds loc sn)))))
+(define-apply
+ "##FLONUM./"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (if (null? (cdr opnds))
+ (flo-oper
+ emit-fmov.dx
+ emit-fdiv.dx
+ (cons (make-obj inexact-+1) opnds)
+ loc
+ sn)
+ (flo-oper emit-fmov.dx emit-fdiv.dx opnds loc sn)))))
+(define-apply
+ "##FLONUM.ABS"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fabs.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.TRUNCATE"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn)))
+ (flo-oper emit-fintrz.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.ROUND"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fint.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.EXP"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fetox.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.LOG"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-flogn.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.SIN"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fsin.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.COS"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fcos.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.TAN"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-ftan.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.ASIN"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fasin.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.ACOS"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-facos.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.ATAN"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fatan.dx #f opnds loc sn))))
+(define-apply
+ "##FLONUM.SQRT"
+ #f
+ (lambda (opnds loc sn)
+ (let ((sn-loc (sn-opnd loc sn))) (flo-oper emit-fsqrt.dx #f opnds loc sn))))
+(define-ifjump
+ "##FLONUM.ZERO?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fbeq
+ emit-fbne
+ emit-fbeq
+ emit-fbne
+ not?
+ (list (car opnds) (make-obj inexact-0))
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.NEGATIVE?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fblt
+ emit-fbge
+ emit-fbgt
+ emit-fble
+ not?
+ (list (car opnds) (make-obj inexact-0))
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.POSITIVE?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fbgt
+ emit-fble
+ emit-fblt
+ emit-fbge
+ not?
+ (list (car opnds) (make-obj inexact-0))
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.="
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fbeq
+ emit-fbne
+ emit-fbeq
+ emit-fbne
+ not?
+ opnds
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.<"
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fblt
+ emit-fbge
+ emit-fbgt
+ emit-fble
+ not?
+ opnds
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.>"
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fbgt
+ emit-fble
+ emit-fblt
+ emit-fbge
+ not?
+ opnds
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.<="
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fble
+ emit-fbgt
+ emit-fbge
+ emit-fblt
+ not?
+ opnds
+ lbl
+ fs)))
+(define-ifjump
+ "##FLONUM.>="
+ (lambda (not? opnds lbl fs)
+ (gen-compares-flo
+ emit-fbge
+ emit-fblt
+ emit-fble
+ emit-fbgt
+ not?
+ opnds
+ lbl
+ fs)))
+(define-ifjump
+ "##CHAR=?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-beq emit-bne emit-beq emit-bne not? opnds lbl fs)))
+(define-ifjump
+ "##CHAR<?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-blt emit-bge emit-bgt emit-ble not? opnds lbl fs)))
+(define-ifjump
+ "##CHAR>?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-bgt emit-ble emit-blt emit-bge not? opnds lbl fs)))
+(define-ifjump
+ "##CHAR<=?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-ble emit-bgt emit-bge emit-blt not? opnds lbl fs)))
+(define-ifjump
+ "##CHAR>=?"
+ (lambda (not? opnds lbl fs)
+ (gen-compares emit-bge emit-blt emit-ble emit-bgt not? opnds lbl fs)))
+(define-apply "##CONS" #f (lambda (opnds loc sn) (gen-cons opnds loc sn)))
+(define-apply
+ "##SET-CAR!"
+ #t
+ (lambda (opnds loc sn) (gen-set-car! opnds loc sn)))
+(define-apply
+ "##SET-CDR!"
+ #t
+ (lambda (opnds loc sn) (gen-set-cdr! opnds loc sn)))
+(define-apply "##CAR" #f (make-gen-apply-c...r 2))
+(define-apply "##CDR" #f (make-gen-apply-c...r 3))
+(define-apply "##CAAR" #f (make-gen-apply-c...r 4))
+(define-apply "##CADR" #f (make-gen-apply-c...r 5))
+(define-apply "##CDAR" #f (make-gen-apply-c...r 6))
+(define-apply "##CDDR" #f (make-gen-apply-c...r 7))
+(define-apply "##CAAAR" #f (make-gen-apply-c...r 8))
+(define-apply "##CAADR" #f (make-gen-apply-c...r 9))
+(define-apply "##CADAR" #f (make-gen-apply-c...r 10))
+(define-apply "##CADDR" #f (make-gen-apply-c...r 11))
+(define-apply "##CDAAR" #f (make-gen-apply-c...r 12))
+(define-apply "##CDADR" #f (make-gen-apply-c...r 13))
+(define-apply "##CDDAR" #f (make-gen-apply-c...r 14))
+(define-apply "##CDDDR" #f (make-gen-apply-c...r 15))
+(define-apply "##CAAAAR" #f (make-gen-apply-c...r 16))
+(define-apply "##CAAADR" #f (make-gen-apply-c...r 17))
+(define-apply "##CAADAR" #f (make-gen-apply-c...r 18))
+(define-apply "##CAADDR" #f (make-gen-apply-c...r 19))
+(define-apply "##CADAAR" #f (make-gen-apply-c...r 20))
+(define-apply "##CADADR" #f (make-gen-apply-c...r 21))
+(define-apply "##CADDAR" #f (make-gen-apply-c...r 22))
+(define-apply "##CADDDR" #f (make-gen-apply-c...r 23))
+(define-apply "##CDAAAR" #f (make-gen-apply-c...r 24))
+(define-apply "##CDAADR" #f (make-gen-apply-c...r 25))
+(define-apply "##CDADAR" #f (make-gen-apply-c...r 26))
+(define-apply "##CDADDR" #f (make-gen-apply-c...r 27))
+(define-apply "##CDDAAR" #f (make-gen-apply-c...r 28))
+(define-apply "##CDDADR" #f (make-gen-apply-c...r 29))
+(define-apply "##CDDDAR" #f (make-gen-apply-c...r 30))
+(define-apply "##CDDDDR" #f (make-gen-apply-c...r 31))
+(define-apply
+ "##MAKE-CELL"
+ #f
+ (lambda (opnds loc sn) (gen-cons (list (car opnds) (make-obj '())) loc sn)))
+(define-apply "##CELL-REF" #f (make-gen-apply-c...r 2))
+(define-apply
+ "##CELL-SET!"
+ #t
+ (lambda (opnds loc sn) (gen-set-car! opnds loc sn)))
+(define-apply "##VECTOR" #f (make-gen-vector 'vector))
+(define-apply "##VECTOR-LENGTH" #f (make-gen-vector-length 'vector))
+(define-apply "##VECTOR-REF" #f (make-gen-vector-ref 'vector))
+(define-apply "##VECTOR-SET!" #t (make-gen-vector-set! 'vector))
+(define-apply "##VECTOR-SHRINK!" #t (make-gen-vector-shrink! 'vector))
+(define-apply "##STRING" #f (make-gen-vector 'string))
+(define-apply "##STRING-LENGTH" #f (make-gen-vector-length 'string))
+(define-apply "##STRING-REF" #f (make-gen-vector-ref 'string))
+(define-apply "##STRING-SET!" #t (make-gen-vector-set! 'string))
+(define-apply "##STRING-SHRINK!" #t (make-gen-vector-shrink! 'string))
+(define-apply "##VECTOR8" #f (make-gen-vector 'vector8))
+(define-apply "##VECTOR8-LENGTH" #f (make-gen-vector-length 'vector8))
+(define-apply "##VECTOR8-REF" #f (make-gen-vector-ref 'vector8))
+(define-apply "##VECTOR8-SET!" #t (make-gen-vector-set! 'vector8))
+(define-apply "##VECTOR8-SHRINK!" #t (make-gen-vector-shrink! 'vector8))
+(define-apply "##VECTOR16" #f (make-gen-vector 'vector16))
+(define-apply "##VECTOR16-LENGTH" #f (make-gen-vector-length 'vector16))
+(define-apply "##VECTOR16-REF" #f (make-gen-vector-ref 'vector16))
+(define-apply "##VECTOR16-SET!" #t (make-gen-vector-set! 'vector16))
+(define-apply "##VECTOR16-SHRINK!" #t (make-gen-vector-shrink! 'vector16))
+(define-apply "##CLOSURE-CODE" #f (make-gen-slot-ref 1 type-procedure))
+(define-apply "##CLOSURE-REF" #f (make-gen-vector-ref 'closure))
+(define-apply "##CLOSURE-SET!" #t (make-gen-vector-set! 'closure))
+(define-apply
+ "##SUBPROCEDURE-ID"
+ #f
+ (lambda (opnds loc sn) (gen-subprocedure-id opnds loc sn)))
+(define-apply
+ "##SUBPROCEDURE-PARENT"
+ #f
+ (lambda (opnds loc sn) (gen-subprocedure-parent opnds loc sn)))
+(define-apply
+ "##RETURN-FS"
+ #f
+ (lambda (opnds loc sn) (gen-return-fs opnds loc sn)))
+(define-apply
+ "##RETURN-LINK"
+ #f
+ (lambda (opnds loc sn) (gen-return-link opnds loc sn)))
+(define-apply
+ "##PROCEDURE-INFO"
+ #f
+ (lambda (opnds loc sn) (gen-procedure-info opnds loc sn)))
+(define-apply
+ "##PSTATE"
+ #f
+ (lambda (opnds loc sn) (move-opnd68-to-loc pstate-reg loc sn)))
+(define-apply
+ "##MAKE-PLACEHOLDER"
+ #f
+ (lambda (opnds loc sn) (gen-make-placeholder opnds loc sn)))
+(define-apply
+ "##TOUCH"
+ #t
+ (lambda (opnds loc sn)
+ (let ((opnd (car opnds)))
+ (if loc
+ (touch-opnd-to-loc opnd loc sn)
+ (touch-opnd-to-any-reg68 opnd sn)))))
+(def-spec "NOT" (safe "##NOT"))
+(def-spec "NULL?" (safe "##NULL?"))
+(def-spec "EQ?" (safe "##EQ?"))
+(def-spec "PAIR?" (safe "##PAIR?"))
+(def-spec "PROCEDURE?" (safe "##PROCEDURE?"))
+(def-spec "VECTOR?" (safe "##VECTOR?"))
+(def-spec "SYMBOL?" (safe "##SYMBOL?"))
+(def-spec "STRING?" (safe "##STRING?"))
+(def-spec "CHAR?" (safe "##CHAR?"))
+(def-spec "ZERO?" (safe-arith "##FIXNUM.ZERO?" "##FLONUM.ZERO?"))
+(def-spec "POSITIVE?" (safe-arith "##FIXNUM.POSITIVE?" "##FLONUM.POSITIVE?"))
+(def-spec "NEGATIVE?" (safe-arith "##FIXNUM.NEGATIVE?" "##FLONUM.NEGATIVE?"))
+(def-spec "ODD?" (safe-arith "##FIXNUM.ODD?" #f))
+(def-spec "EVEN?" (safe-arith "##FIXNUM.EVEN?" #f))
+(def-spec "+" (unsafe-arith "##FIXNUM.+" "##FLONUM.+"))
+(def-spec "*" (unsafe-arith "##FIXNUM.*" "##FLONUM.*"))
+(def-spec "-" (unsafe-arith "##FIXNUM.-" "##FLONUM.-"))
+(def-spec "/" (unsafe-arith #f "##FLONUM./"))
+(def-spec "QUOTIENT" (unsafe-arith "##FIXNUM.QUOTIENT" #f))
+(def-spec "REMAINDER" (unsafe-arith "##FIXNUM.REMAINDER" #f))
+(def-spec "MODULO" (unsafe-arith "##FIXNUM.MODULO" #f))
+(def-spec "=" (safe-arith "##FIXNUM.=" "##FLONUM.="))
+(def-spec "<" (safe-arith "##FIXNUM.<" "##FLONUM.<"))
+(def-spec ">" (safe-arith "##FIXNUM.>" "##FLONUM.>"))
+(def-spec "<=" (safe-arith "##FIXNUM.<=" "##FLONUM.<="))
+(def-spec ">=" (safe-arith "##FIXNUM.>=" "##FLONUM.>="))
+(def-spec "ABS" (unsafe-arith #f "##FLONUM.ABS"))
+(def-spec "TRUNCATE" (unsafe-arith #f "##FLONUM.TRUNCATE"))
+(def-spec "EXP" (unsafe-arith #f "##FLONUM.EXP"))
+(def-spec "LOG" (unsafe-arith #f "##FLONUM.LOG"))
+(def-spec "SIN" (unsafe-arith #f "##FLONUM.SIN"))
+(def-spec "COS" (unsafe-arith #f "##FLONUM.COS"))
+(def-spec "TAN" (unsafe-arith #f "##FLONUM.TAN"))
+(def-spec "ASIN" (unsafe-arith #f "##FLONUM.ASIN"))
+(def-spec "ACOS" (unsafe-arith #f "##FLONUM.ACOS"))
+(def-spec "ATAN" (unsafe-arith #f "##FLONUM.ATAN"))
+(def-spec "SQRT" (unsafe-arith #f "##FLONUM.SQRT"))
+(def-spec "CHAR=?" (safe "##CHAR=?"))
+(def-spec "CHAR<?" (safe "##CHAR<?"))
+(def-spec "CHAR>?" (safe "##CHAR>?"))
+(def-spec "CHAR<=?" (safe "##CHAR<=?"))
+(def-spec "CHAR>=?" (safe "##CHAR>=?"))
+(def-spec "CONS" (safe "##CONS"))
+(def-spec "SET-CAR!" (unsafe "##SET-CAR!"))
+(def-spec "SET-CDR!" (unsafe "##SET-CDR!"))
+(def-spec "CAR" (unsafe "##CAR"))
+(def-spec "CDR" (unsafe "##CDR"))
+(def-spec "CAAR" (unsafe "##CAAR"))
+(def-spec "CADR" (unsafe "##CADR"))
+(def-spec "CDAR" (unsafe "##CDAR"))
+(def-spec "CDDR" (unsafe "##CDDR"))
+(def-spec "CAAAR" (unsafe "##CAAAR"))
+(def-spec "CAADR" (unsafe "##CAADR"))
+(def-spec "CADAR" (unsafe "##CADAR"))
+(def-spec "CADDR" (unsafe "##CADDR"))
+(def-spec "CDAAR" (unsafe "##CDAAR"))
+(def-spec "CDADR" (unsafe "##CDADR"))
+(def-spec "CDDAR" (unsafe "##CDDAR"))
+(def-spec "CDDDR" (unsafe "##CDDDR"))
+(def-spec "CAAAAR" (unsafe "##CAAAAR"))
+(def-spec "CAAADR" (unsafe "##CAAADR"))
+(def-spec "CAADAR" (unsafe "##CAADAR"))
+(def-spec "CAADDR" (unsafe "##CAADDR"))
+(def-spec "CADAAR" (unsafe "##CADAAR"))
+(def-spec "CADADR" (unsafe "##CADADR"))
+(def-spec "CADDAR" (unsafe "##CADDAR"))
+(def-spec "CADDDR" (unsafe "##CADDDR"))
+(def-spec "CDAAAR" (unsafe "##CDAAAR"))
+(def-spec "CDAADR" (unsafe "##CDAADR"))
+(def-spec "CDADAR" (unsafe "##CDADAR"))
+(def-spec "CDADDR" (unsafe "##CDADDR"))
+(def-spec "CDDAAR" (unsafe "##CDDAAR"))
+(def-spec "CDDADR" (unsafe "##CDDADR"))
+(def-spec "CDDDAR" (unsafe "##CDDDAR"))
+(def-spec "CDDDDR" (unsafe "##CDDDDR"))
+(def-spec "VECTOR" (safe "##VECTOR"))
+(def-spec "VECTOR-LENGTH" (unsafe "##VECTOR-LENGTH"))
+(def-spec "VECTOR-REF" (unsafe "##VECTOR-REF"))
+(def-spec "VECTOR-SET!" (unsafe "##VECTOR-SET!"))
+(def-spec "STRING" (safe "##STRING"))
+(def-spec "STRING-LENGTH" (unsafe "##STRING-LENGTH"))
+(def-spec "STRING-REF" (unsafe "##STRING-REF"))
+(def-spec "STRING-SET!" (unsafe "##STRING-SET!"))
+(def-spec "TOUCH" (safe "##TOUCH"))
+(let ((targ (make-target 4 'm68000)))
+ (target-begin!-set! targ (lambda (info-port) (begin! info-port targ)))
+ (put-target targ))
+
+(define input-source-code '
+(begin
+(declare (standard-bindings) (fixnum) (not safe) (block))
+
+(define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1))
+ (fib (- n 2)))))
+
+(define (tak x y z)
+ (if (not (< y x))
+ z
+ (tak (tak (- x 1) y z)
+ (tak (- y 1) z x)
+ (tak (- z 1) x y))))
+
+(define (ack m n)
+ (cond ((= m 0) (+ n 1))
+ ((= n 0) (ack (- m 1) 1))
+ (else (ack (- m 1) (ack m (- n 1))))))
+
+(define (create-x n)
+ (define result (make-vector n))
+ (do ((i 0 (+ i 1)))
+ ((>= i n) result)
+ (vector-set! result i i)))
+
+(define (create-y x)
+ (let* ((n (vector-length x))
+ (result (make-vector n)))
+ (do ((i (- n 1) (- i 1)))
+ ((< i 0) result)
+ (vector-set! result i (vector-ref x i)))))
+
+(define (my-try n)
+ (vector-length (create-y (create-x n))))
+
+(define (go n)
+ (let loop ((repeat 100)
+ (result 0))
+ (if (> repeat 0)
+ (loop (- repeat 1) (my-try n))
+ result)))
+
+(+ (fib 20)
+ (tak 18 12 6)
+ (ack 3 9)
+ (go 200000))
+))
+
+(define output-expected '(
+"|------------------------------------------------------"
+"| #[primitive #!program] ="
+"L1:"
+" cmpw #1,d0"
+" beq L1000"
+" TRAP1(9,0)"
+" LBL_PTR(L1)"
+"L1000:"
+" MOVE_PROC(1,a1)"
+" movl a1,GLOB(fib)"
+" MOVE_PROC(2,a1)"
+" movl a1,GLOB(tak)"
+" MOVE_PROC(3,a1)"
+" movl a1,GLOB(ack)"
+" MOVE_PROC(4,a1)"
+" movl a1,GLOB(create-x)"
+" MOVE_PROC(5,a1)"
+" movl a1,GLOB(create-y)"
+" MOVE_PROC(6,a1)"
+" movl a1,GLOB(my-try)"
+" MOVE_PROC(7,a1)"
+" movl a1,GLOB(go)"
+" movl a0,sp@-"
+" movl #160,d1"
+" lea L2,a0"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1002:"
+"L1001:"
+" JMP_PROC(1,10)"
+" RETURN(L1,1,1)"
+"L2:"
+" movl d1,sp@-"
+" moveq #48,d3"
+" moveq #96,d2"
+" movl #144,d1"
+" lea L3,a0"
+" JMP_PROC(2,14)"
+" RETURN(L1,2,1)"
+"L3:"
+" movl d1,sp@-"
+" moveq #72,d2"
+" moveq #24,d1"
+" lea L4,a0"
+" JMP_PROC(3,10)"
+" RETURN(L1,3,1)"
+"L4:"
+" movl d1,sp@-"
+" movl #1600000,d1"
+" lea L5,a0"
+" JMP_PROC(7,10)"
+" RETURN(L1,4,1)"
+"L5:"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" TRAP2(24)"
+" RETURN(L1,4,1)"
+"L1004:"
+"L1003:"
+"L6:"
+" addl sp@(8),d1"
+" addl sp@(4),d1"
+" addl sp@+,d1"
+" addql #8,sp"
+" rts"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive fib] ="
+"L1:"
+" bmi L1000"
+" TRAP1(9,1)"
+" LBL_PTR(L1)"
+"L1000:"
+" moveq #16,d0"
+" cmpl d1,d0"
+" ble L3"
+" bra L4"
+" RETURN(L1,2,1)"
+"L2:"
+" movl d1,sp@-"
+" movl sp@(4),d1"
+" moveq #-16,d0"
+" addl d0,d1"
+" lea L5,a0"
+" moveq #16,d0"
+" cmpl d1,d0"
+" bgt L4"
+"L3:"
+" movl a0,sp@-"
+" movl d1,sp@-"
+" subql #8,d1"
+" lea L2,a0"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" TRAP2(24)"
+" RETURN(L1,2,1)"
+"L1002:"
+"L1001:"
+" moveq #16,d0"
+" cmpl d1,d0"
+" ble L3"
+"L4:"
+" jmp a0@"
+" RETURN(L1,3,1)"
+"L5:"
+" addl sp@+,d1"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" TRAP2(24)"
+" RETURN(L1,2,1)"
+"L1004:"
+"L1003:"
+" addql #4,sp"
+" rts"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive tak] ="
+"L1:"
+" cmpw #4,d0"
+" beq L1000"
+" TRAP1(9,3)"
+" LBL_PTR(L1)"
+"L1000:"
+" cmpl d1,d2"
+" bge L4"
+" bra L3"
+" RETURN(L1,6,1)"
+"L2:"
+" movl d1,d3"
+" movl sp@(20),a0"
+" movl sp@+,d2"
+" movl sp@+,d1"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" movl a0,sp@(12)"
+" TRAP2(24)"
+" RETURN(L1,4,1)"
+"L1002:"
+" movl sp@(12),a0"
+"L1001:"
+" cmpl d1,d2"
+" lea sp@(16),sp"
+" bge L4"
+"L3:"
+" movl a0,sp@-"
+" movl d1,sp@-"
+" movl d2,sp@-"
+" movl d3,sp@-"
+" subql #8,d1"
+" lea L5,a0"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" TRAP2(24)"
+" RETURN(L1,4,1)"
+"L1004:"
+"L1003:"
+" cmpl d1,d2"
+" blt L3"
+"L4:"
+" movl d3,d1"
+" jmp a0@"
+" RETURN(L1,4,1)"
+"L5:"
+" movl d1,sp@-"
+" movl sp@(12),d3"
+" movl sp@(4),d2"
+" movl sp@(8),d1"
+" subql #8,d1"
+" lea L6,a0"
+" cmpl d1,d2"
+" bge L4"
+" bra L3"
+" RETURN(L1,5,1)"
+"L6:"
+" movl d1,sp@-"
+" movl sp@(12),d3"
+" movl sp@(16),d2"
+" movl sp@(8),d1"
+" subql #8,d1"
+" lea L2,a0"
+" cmpl d1,d2"
+" bge L4"
+" bra L3"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive ack] ="
+"L1:"
+" beq L1000"
+" TRAP1(9,2)"
+" LBL_PTR(L1)"
+"L1000:"
+" movl d1,d0"
+" bne L3"
+" bra L5"
+" RETURN(L1,2,1)"
+"L2:"
+" movl d1,d2"
+" movl sp@+,d1"
+" subql #8,d1"
+" movl sp@+,a0"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1002:"
+" movl sp@+,a0"
+"L1001:"
+" movl d1,d0"
+" beq L5"
+"L3:"
+" movl d2,d0"
+" bne L6"
+"L4:"
+" subql #8,d1"
+" moveq #8,d2"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1004:"
+" movl sp@+,a0"
+"L1003:"
+" movl d1,d0"
+" bne L3"
+"L5:"
+" movl d2,d1"
+" addql #8,d1"
+" jmp a0@"
+"L6:"
+" movl a0,sp@-"
+" movl d1,sp@-"
+" movl d2,d1"
+" subql #8,d1"
+" movl d1,d2"
+" movl sp@,d1"
+" lea L2,a0"
+" dbra d5,L1005"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1005"
+" TRAP2(24)"
+" RETURN(L1,2,1)"
+"L1006:"
+"L1005:"
+" movl d1,d0"
+" bne L3"
+" bra L5"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive create-x] ="
+"L1:"
+" bmi L1000"
+" TRAP1(9,1)"
+" LBL_PTR(L1)"
+"L1000:"
+" movl a0,sp@-"
+" movl d1,sp@-"
+" lea L2,a0"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" TRAP2(24)"
+" RETURN(L1,2,1)"
+"L1002:"
+"L1001:"
+" moveq #-1,d0"
+" JMP_PRIM(make-vector,0)"
+" RETURN(L1,2,1)"
+"L2:"
+" movl d1,d2"
+" movl sp@+,d1"
+" moveq #0,d3"
+" movl sp@+,a0"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1004:"
+" movl sp@+,a0"
+"L1003:"
+" cmpl d1,d3"
+" bge L4"
+"L3:"
+" movl d3,d0"
+" asrl #1,d0"
+" movl d2,a1"
+" movl d3,a1@(1,d0:l)"
+" addql #8,d3"
+" dbra d5,L1005"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1005"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1006:"
+" movl sp@+,a0"
+"L1005:"
+" cmpl d1,d3"
+" blt L3"
+"L4:"
+" movl d2,d1"
+" jmp a0@"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive create-y] ="
+"L1:"
+" bmi L1000"
+" TRAP1(9,1)"
+" LBL_PTR(L1)"
+"L1000:"
+" movl d1,a1"
+" movl a1@(-3),d2"
+" lsrl #7,d2"
+" movl a0,sp@-"
+" movl d1,sp@-"
+" movl d2,sp@-"
+" movl d2,d1"
+" lea L2,a0"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" TRAP2(24)"
+" RETURN(L1,3,1)"
+"L1002:"
+"L1001:"
+" moveq #-1,d0"
+" JMP_PRIM(make-vector,0)"
+" RETURN(L1,3,1)"
+"L2:"
+" movl sp@+,d2"
+" subql #8,d2"
+" movl d2,d3"
+" movl d1,d2"
+" movl sp@+,d1"
+" movl sp@+,a0"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1004:"
+" movl sp@+,a0"
+"L1003:"
+" movl d3,d0"
+" blt L4"
+"L3:"
+" movl d3,d0"
+" asrl #1,d0"
+" movl d1,a1"
+" movl a1@(1,d0:l),d4"
+" movl d3,d0"
+" asrl #1,d0"
+" movl d2,a1"
+" movl d4,a1@(1,d0:l)"
+" subql #8,d3"
+" dbra d5,L1005"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1005"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1006:"
+" movl sp@+,a0"
+"L1005:"
+" movl d3,d0"
+" bge L3"
+"L4:"
+" movl d2,d1"
+" jmp a0@"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive my-try] ="
+"L1:"
+" bmi L1000"
+" TRAP1(9,1)"
+" LBL_PTR(L1)"
+"L1000:"
+" movl a0,sp@-"
+" lea L2,a0"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1002:"
+"L1001:"
+" JMP_PROC(4,10)"
+" RETURN(L1,1,1)"
+"L2:"
+" lea L3,a0"
+" JMP_PROC(5,10)"
+" RETURN(L1,1,1)"
+"L3:"
+" movl d1,a1"
+" movl a1@(-3),d1"
+" lsrl #7,d1"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1004:"
+"L1003:"
+" rts"
+"L0:"
+"|------------------------------------------------------"
+"| #[primitive go] ="
+"L1:"
+" bmi L1000"
+" TRAP1(9,1)"
+" LBL_PTR(L1)"
+"L1000:"
+" moveq #0,d3"
+" movl #800,d2"
+" dbra d5,L1001"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1001"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1002:"
+" movl sp@+,a0"
+"L1001:"
+" movl d2,d0"
+" ble L4"
+" bra L3"
+" RETURN(L1,3,1)"
+"L2:"
+" movl d1,d3"
+" movl sp@+,d1"
+" subql #8,d1"
+" movl d1,d2"
+" movl sp@+,d1"
+" movl sp@+,a0"
+" dbra d5,L1003"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1003"
+" movl a0,sp@-"
+" TRAP2(24)"
+" RETURN(L1,1,1)"
+"L1004:"
+" movl sp@+,a0"
+"L1003:"
+" movl d2,d0"
+" ble L4"
+"L3:"
+" movl a0,sp@-"
+" movl d1,sp@-"
+" movl d2,sp@-"
+" lea L2,a0"
+" dbra d5,L1005"
+" moveq #9,d5"
+" cmpl a5@,sp"
+" bcc L1005"
+" TRAP2(24)"
+" RETURN(L1,3,1)"
+"L1006:"
+"L1005:"
+" JMP_PROC(6,10)"
+"L4:"
+" movl d3,d1"
+" jmp a0@"
+"L0:"
+""))
+
+(define (main . args)
+ (run-benchmark
+ "compiler"
+ compiler-iters
+ (lambda (result)
+ (equal? result output-expected))
+ (lambda (expr target opt) (lambda () (ce expr target opt) (asm-output-get)))
+ input-source-code
+ 'm68000
+ 'asm))
+
+(main)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index daf6e9b1..057b3dd8 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -208,7 +208,8 @@ $compile -e embedded2.scm
./a.out
echo "======================================== timing compilation ..."
-time $compile silex.scm -t -S -O3
+time $compile compiler.scm -t -S -O5 -debug pbo -vv
+time ./a.out
echo "======================================== running floating-point benchmark ..."
echo "boxed:"
diff --git a/tests/silex.scm b/tests/silex.scm
deleted file mode 100644
index df550540..00000000
--- a/tests/silex.scm
+++ /dev/null
@@ -1,6717 +0,0 @@
-;; Copyright (C) 1997 Danny Dube, Universite de Montreal.
-;; All rights reserved.
-
-;; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-;; conditions are met:
-
-;; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-;; disclaimer.
-;; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-;; disclaimer in the documentation and/or other materials provided with the distribution.
-;; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-;; products derived from this software without specific prior written permission.
-
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-;; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-;; POSSIBILITY OF SUCH DAMAGE.
-
-
-(declare
- (fixnum)
- (no-procedure-checks-for-usual-bindings) )
-
-
-(require-library srfi-13)
-
-
-(module silex *
- (import scheme srfi-13) ; srfi-13 for string-downcase
-
-;----------------------------------------------------------------------------------------------------
-
-(define (string-append-list lst)
- (let loop1 ((n 0) (x lst) (y '()))
- (if (pair? x)
- (let ((s (car x)))
- (loop1 (+ n (string-length s)) (cdr x) (cons s y)))
- (let ((result (make-string n #\space)))
- (let loop2 ((k (- n 1)) (y y))
- (if (pair? y)
- (let ((s (car y)))
- (let loop3 ((i k) (j (- (string-length s) 1)))
- (if (not (< j 0))
- (begin
- (string-set! result i (string-ref s j))
- (loop3 (- i 1) (- j 1)))
- (loop2 i (cdr y)))))
- result))))))
-
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-; Module util.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Quelques definitions de constantes
-;
-
-(define eof-tok 0)
-(define hblank-tok 1)
-(define vblank-tok 2)
-(define pipe-tok 3)
-(define question-tok 4)
-(define plus-tok 5)
-(define star-tok 6)
-(define lpar-tok 7)
-(define rpar-tok 8)
-(define dot-tok 9)
-(define lbrack-tok 10)
-(define lbrack-rbrack-tok 11)
-(define lbrack-caret-tok 12)
-(define lbrack-minus-tok 13)
-(define subst-tok 14)
-(define power-tok 15)
-(define doublequote-tok 16)
-(define char-tok 17)
-(define caret-tok 18)
-(define dollar-tok 19)
-(define <<EOF>>-tok 20)
-(define <<ERROR>>-tok 21)
-(define percent-percent-tok 22)
-(define id-tok 23)
-(define rbrack-tok 24)
-(define minus-tok 25)
-(define illegal-tok 26)
-; Tokens agreges
-(define class-tok 27)
-(define string-tok 28)
-
-(define number-of-tokens 29)
-
-(define newline-ch (char->integer #\newline))
-(define tab-ch (char->integer #\ ))
-(define dollar-ch (char->integer #\$))
-(define minus-ch (char->integer #\-))
-(define rbrack-ch (char->integer #\]))
-(define caret-ch (char->integer #\^))
-
-(define dot-class (list (cons 'inf- (- newline-ch 1))
- (cons (+ newline-ch 1) 'inf+)))
-
-(define default-action
- (string-append " (yycontinue)" (string #\newline)))
-(define default-<<EOF>>-action
- (string-append " '(0)" (string #\newline)))
-(define default-<<ERROR>>-action
- (string-append " (begin"
- (string #\newline)
- " (display \"Error: Invalid token.\")"
- (string #\newline)
- " (newline)"
- (string #\newline)
- " 'error)"
- (string #\newline)))
-
-
-
-
-;
-; Fabrication de tables de dispatch
-;
-
-(define make-dispatch-table
- (lambda (size alist default)
- (let ((v (make-vector size default)))
- (let loop ((alist alist))
- (if (null? alist)
- v
- (begin
- (vector-set! v (caar alist) (cdar alist))
- (loop (cdr alist))))))))
-
-
-
-
-;
-; Fonctions de manipulation des tokens
-;
-
-(define make-tok
- (lambda (tok-type lexeme line column . attr)
- (cond ((null? attr)
- (vector tok-type line column lexeme))
- ((null? (cdr attr))
- (vector tok-type line column lexeme (car attr)))
- (else
- (vector tok-type line column lexeme (car attr) (cadr attr))))))
-
-(define get-tok-type (lambda (tok) (vector-ref tok 0)))
-(define get-tok-line (lambda (tok) (vector-ref tok 1)))
-(define get-tok-column (lambda (tok) (vector-ref tok 2)))
-(define get-tok-lexeme (lambda (tok) (vector-ref tok 3)))
-(define get-tok-attr (lambda (tok) (vector-ref tok 4)))
-(define get-tok-2nd-attr (lambda (tok) (vector-ref tok 5)))
-
-
-
-
-;
-; Fonctions de manipulations des regles
-;
-
-(define make-rule
- (lambda (line eof? error? bol? eol? regexp action)
- (vector line eof? error? bol? eol? regexp action #f)))
-
-(define get-rule-line (lambda (rule) (vector-ref rule 0)))
-(define get-rule-eof? (lambda (rule) (vector-ref rule 1)))
-(define get-rule-error? (lambda (rule) (vector-ref rule 2)))
-(define get-rule-bol? (lambda (rule) (vector-ref rule 3)))
-(define get-rule-eol? (lambda (rule) (vector-ref rule 4)))
-(define get-rule-regexp (lambda (rule) (vector-ref rule 5)))
-(define get-rule-action (lambda (rule) (vector-ref rule 6)))
-(define get-rule-yytext? (lambda (rule) (vector-ref rule 7)))
-
-(define set-rule-regexp (lambda (rule regexp) (vector-set! rule 5 regexp)))
-(define set-rule-action (lambda (rule action) (vector-set! rule 6 action)))
-(define set-rule-yytext? (lambda (rule yytext?) (vector-set! rule 7 yytext?)))
-
-
-
-
-;
-; Noeuds des regexp
-;
-
-(define epsilon-re 0)
-(define or-re 1)
-(define conc-re 2)
-(define star-re 3)
-(define plus-re 4)
-(define question-re 5)
-(define class-re 6)
-(define char-re 7)
-
-(define make-re
- (lambda (re-type . lattr)
- (cond ((null? lattr)
- (vector re-type))
- ((null? (cdr lattr))
- (vector re-type (car lattr)))
- ((null? (cddr lattr))
- (vector re-type (car lattr) (cadr lattr))))))
-
-(define get-re-type (lambda (re) (vector-ref re 0)))
-(define get-re-attr1 (lambda (re) (vector-ref re 1)))
-(define get-re-attr2 (lambda (re) (vector-ref re 2)))
-
-
-
-
-;
-; Fonctions de manipulation des ensembles d'etats
-;
-
-; Intersection de deux ensembles d'etats
-(define ss-inter
- (lambda (ss1 ss2)
- (cond ((null? ss1)
- '())
- ((null? ss2)
- '())
- (else
- (let ((t1 (car ss1))
- (t2 (car ss2)))
- (cond ((< t1 t2)
- (ss-inter (cdr ss1) ss2))
- ((= t1 t2)
- (cons t1 (ss-inter (cdr ss1) (cdr ss2))))
- (else
- (ss-inter ss1 (cdr ss2)))))))))
-
-; Difference entre deux ensembles d'etats
-(define ss-diff
- (lambda (ss1 ss2)
- (cond ((null? ss1)
- '())
- ((null? ss2)
- ss1)
- (else
- (let ((t1 (car ss1))
- (t2 (car ss2)))
- (cond ((< t1 t2)
- (cons t1 (ss-diff (cdr ss1) ss2)))
- ((= t1 t2)
- (ss-diff (cdr ss1) (cdr ss2)))
- (else
- (ss-diff ss1 (cdr ss2)))))))))
-
-; Union de deux ensembles d'etats
-(define ss-union
- (lambda (ss1 ss2)
- (cond ((null? ss1)
- ss2)
- ((null? ss2)
- ss1)
- (else
- (let ((t1 (car ss1))
- (t2 (car ss2)))
- (cond ((< t1 t2)
- (cons t1 (ss-union (cdr ss1) ss2)))
- ((= t1 t2)
- (cons t1 (ss-union (cdr ss1) (cdr ss2))))
- (else
- (cons t2 (ss-union ss1 (cdr ss2))))))))))
-
-; Decoupage de deux ensembles d'etats
-(define ss-sep
- (lambda (ss1 ss2)
- (let loop ((ss1 ss1) (ss2 ss2) (l '()) (c '()) (r '()))
- (if (null? ss1)
- (if (null? ss2)
- (vector (reverse l) (reverse c) (reverse r))
- (loop ss1 (cdr ss2) l c (cons (car ss2) r)))
- (if (null? ss2)
- (loop (cdr ss1) ss2 (cons (car ss1) l) c r)
- (let ((t1 (car ss1))
- (t2 (car ss2)))
- (cond ((< t1 t2)
- (loop (cdr ss1) ss2 (cons t1 l) c r))
- ((= t1 t2)
- (loop (cdr ss1) (cdr ss2) l (cons t1 c) r))
- (else
- (loop ss1 (cdr ss2) l c (cons t2 r))))))))))
-
-
-
-
-;
-; Fonctions de manipulation des classes de caracteres
-;
-
-; Comparaisons de bornes d'intervalles
-(define class-= eqv?)
-
-(define class-<=
- (lambda (b1 b2)
- (cond ((eq? b1 'inf-) #t)
- ((eq? b2 'inf+) #t)
- ((eq? b1 'inf+) #f)
- ((eq? b2 'inf-) #f)
- (else (<= b1 b2)))))
-
-(define class->=
- (lambda (b1 b2)
- (cond ((eq? b1 'inf+) #t)
- ((eq? b2 'inf-) #t)
- ((eq? b1 'inf-) #f)
- ((eq? b2 'inf+) #f)
- (else (>= b1 b2)))))
-
-(define class-<
- (lambda (b1 b2)
- (cond ((eq? b1 'inf+) #f)
- ((eq? b2 'inf-) #f)
- ((eq? b1 'inf-) #t)
- ((eq? b2 'inf+) #t)
- (else (< b1 b2)))))
-
-(define class->
- (lambda (b1 b2)
- (cond ((eq? b1 'inf-) #f)
- ((eq? b2 'inf+) #f)
- ((eq? b1 'inf+) #t)
- ((eq? b2 'inf-) #t)
- (else (> b1 b2)))))
-
-; Complementation d'une classe
-(define class-compl
- (lambda (c)
- (let loop ((c c) (start 'inf-))
- (if (null? c)
- (list (cons start 'inf+))
- (let* ((r (car c))
- (rstart (car r))
- (rend (cdr r)))
- (if (class-< start rstart)
- (cons (cons start (- rstart 1))
- (loop c rstart))
- (if (class-< rend 'inf+)
- (loop (cdr c) (+ rend 1))
- '())))))))
-
-; Union de deux classes de caracteres
-(define class-union
- (lambda (c1 c2)
- (let loop ((c1 c1) (c2 c2) (u '()))
- (if (null? c1)
- (if (null? c2)
- (reverse u)
- (loop c1 (cdr c2) (cons (car c2) u)))
- (if (null? c2)
- (loop (cdr c1) c2 (cons (car c1) u))
- (let* ((r1 (car c1))
- (r2 (car c2))
- (r1start (car r1))
- (r1end (cdr r1))
- (r2start (car r2))
- (r2end (cdr r2)))
- (if (class-<= r1start r2start)
- (cond ((class-= r1end 'inf+)
- (loop c1 (cdr c2) u))
- ((class-< (+ r1end 1) r2start)
- (loop (cdr c1) c2 (cons r1 u)))
- ((class-<= r1end r2end)
- (loop (cdr c1)
- (cons (cons r1start r2end) (cdr c2))
- u))
- (else
- (loop c1 (cdr c2) u)))
- (cond ((class-= r2end 'inf+)
- (loop (cdr c1) c2 u))
- ((class-> r1start (+ r2end 1))
- (loop c1 (cdr c2) (cons r2 u)))
- ((class->= r1end r2end)
- (loop (cons (cons r2start r1end) (cdr c1))
- (cdr c2)
- u))
- (else
- (loop (cdr c1) c2 u))))))))))
-
-; Decoupage de deux classes de caracteres
-(define class-sep
- (lambda (c1 c2)
- (let loop ((c1 c1) (c2 c2) (l '()) (c '()) (r '()))
- (if (null? c1)
- (if (null? c2)
- (vector (reverse l) (reverse c) (reverse r))
- (loop c1 (cdr c2) l c (cons (car c2) r)))
- (if (null? c2)
- (loop (cdr c1) c2 (cons (car c1) l) c r)
- (let* ((r1 (car c1))
- (r2 (car c2))
- (r1start (car r1))
- (r1end (cdr r1))
- (r2start (car r2))
- (r2end (cdr r2)))
- (cond ((class-< r1start r2start)
- (if (class-< r1end r2start)
- (loop (cdr c1) c2 (cons r1 l) c r)
- (loop (cons (cons r2start r1end) (cdr c1)) c2
- (cons (cons r1start (- r2start 1)) l) c r)))
- ((class-> r1start r2start)
- (if (class-> r1start r2end)
- (loop c1 (cdr c2) l c (cons r2 r))
- (loop c1 (cons (cons r1start r2end) (cdr c2))
- l c (cons (cons r2start (- r1start 1)) r))))
- (else
- (cond ((class-< r1end r2end)
- (loop (cdr c1)
- (cons (cons (+ r1end 1) r2end) (cdr c2))
- l (cons r1 c) r))
- ((class-= r1end r2end)
- (loop (cdr c1) (cdr c2) l (cons r1 c) r))
- (else
- (loop (cons (cons (+ r2end 1) r1end) (cdr c1))
- (cdr c2)
- l (cons r2 c) r)))))))))))
-
-; Transformer une classe (finie) de caracteres en une liste de ...
-(define class->char-list
- (lambda (c)
- (let loop1 ((c c))
- (if (null? c)
- '()
- (let* ((r (car c))
- (rend (cdr r))
- (tail (loop1 (cdr c))))
- (let loop2 ((rstart (car r)))
- (if (<= rstart rend)
- (cons (integer->char rstart) (loop2 (+ rstart 1)))
- tail)))))))
-
-; Transformer une classe de caracteres en une liste poss. compl.
-; 1er element = #t -> classe complementee
-(define class->tagged-char-list
- (lambda (c)
- (let* ((finite? (or (null? c) (number? (caar c))))
- (c2 (if finite? c (class-compl c)))
- (c-l (class->char-list c2)))
- (cons (not finite?) c-l))))
-
-
-
-
-;
-; Fonction digraph
-;
-
-; Fonction "digraph".
-; Etant donne un graphe dirige dont les noeuds comportent une valeur,
-; calcule pour chaque noeud la "somme" des valeurs contenues dans le
-; noeud lui-meme et ceux atteignables a partir de celui-ci. La "somme"
-; consiste a appliquer un operateur commutatif et associatif aux valeurs
-; lorsqu'elles sont additionnees.
-; L'entree consiste en un vecteur de voisinages externes, un autre de
-; valeurs initiales et d'un operateur.
-; La sortie est un vecteur de valeurs finales.
-(define digraph
- (lambda (arcs init op)
- (let* ((nbnodes (vector-length arcs))
- (infinity nbnodes)
- (prio (make-vector nbnodes -1))
- (stack (make-vector nbnodes #f))
- (sp 0)
- (final (make-vector nbnodes #f)))
- (letrec ((store-final
- (lambda (self-sp value)
- (let loop ()
- (if (> sp self-sp)
- (let ((voisin (vector-ref stack (- sp 1))))
- (vector-set! prio voisin infinity)
- (set! sp (- sp 1))
- (vector-set! final voisin value)
- (loop))))))
- (visit-node
- (lambda (n)
- (let ((self-sp sp))
- (vector-set! prio n self-sp)
- (vector-set! stack sp n)
- (set! sp (+ sp 1))
- (vector-set! final n (vector-ref init n))
- (let loop ((vois (vector-ref arcs n)))
- (if (pair? vois)
- (let* ((v (car vois))
- (vprio (vector-ref prio v)))
- (if (= vprio -1)
- (visit-node v))
- (vector-set! prio n (min (vector-ref prio n)
- (vector-ref prio v)))
- (vector-set! final n (op (vector-ref final n)
- (vector-ref final v)))
- (loop (cdr vois)))))
- (if (= (vector-ref prio n) self-sp)
- (store-final self-sp (vector-ref final n)))))))
- (let loop ((n 0))
- (if (< n nbnodes)
- (begin
- (if (= (vector-ref prio n) -1)
- (visit-node n))
- (loop (+ n 1)))))
- final))))
-
-
-
-
-;
-; Fonction de tri
-;
-
-(define merge-sort-merge
- (lambda (l1 l2 cmp-<=)
- (cond ((null? l1)
- l2)
- ((null? l2)
- l1)
- (else
- (let ((h1 (car l1))
- (h2 (car l2)))
- (if (cmp-<= h1 h2)
- (cons h1 (merge-sort-merge (cdr l1) l2 cmp-<=))
- (cons h2 (merge-sort-merge l1 (cdr l2) cmp-<=))))))))
-
-(define merge-sort
- (lambda (l cmp-<=)
- (if (null? l)
- l
- (let loop1 ((ll (map list l)))
- (if (null? (cdr ll))
- (car ll)
- (loop1
- (let loop2 ((ll ll))
- (cond ((null? ll)
- ll)
- ((null? (cdr ll))
- ll)
- (else
- (cons (merge-sort-merge (car ll) (cadr ll) cmp-<=)
- (loop2 (cddr ll))))))))))))
-
-; Module action.l.scm.
-;
-; Table generated from the file action.l by SILex 1.0
-;
-
-(define action-tables
- (vector
- 'all
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok eof-tok yytext yyline yycolumn)
- ))
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (begin
- (display "Error: Invalid token.")
- (newline)
- 'error)
- ))
- (vector
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok hblank-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok vblank-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok char-tok yytext yyline yycolumn)
- )))
- 'tagged-chars-lists
- 0
- 0
- '#((((#f #\ #\space) . 4)
- ((#f #\;) . 3)
- ((#f #\newline) . 2)
- ((#t #\ #\newline #\space #\;) . 1))
- (((#t #\newline) . 1))
- ()
- (((#t #\newline) . 3))
- (((#f #\ #\space) . 4)
- ((#f #\;) . 3)
- ((#t #\ #\newline #\space #\;) . 1)))
- '#((#f . #f) (2 . 2) (1 . 1) (0 . 0) (0 . 0))))
-
-; Module class.l.scm.
-;
-; Table generated from the file class.l by SILex 1.0
-;
-
-(define class-tables
- (vector
- 'all
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok eof-tok yytext yyline yycolumn)
- ))
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (begin
- (display "Error: Invalid token.")
- (newline)
- 'error)
- ))
- (vector
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok rbrack-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok minus-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-spec-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-digits-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-digits-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-quoted-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-ordinary-char yytext yyline yycolumn)
- )))
- 'tagged-chars-lists
- 0
- 0
- '#((((#f #\]) . 4) ((#f #\-) . 3) ((#f #\\) . 2) ((#t #\- #\\ #\]) . 1))
- ()
- (((#f #\n) . 8)
- ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 7)
- ((#f #\-) . 6)
- ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 5))
- ()
- ()
- ()
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10))
- ()
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10)))
- '#((#f . #f) (6 . 6) (6 . 6) (1 . 1) (0 . 0) (5 . 5) (5 . 5)
- (3 . 3) (2 . 2) (4 . 4) (3 . 3))))
-
-; Module macro.l.scm.
-;
-; Table generated from the file macro.l by SILex 1.0
-;
-
-(define macro-tables
- (vector
- 'all
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok eof-tok yytext yyline yycolumn)
- ))
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (begin
- (display "Error: Invalid token.")
- (newline)
- 'error)
- ))
- (vector
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok hblank-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok vblank-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok percent-percent-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-id yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok illegal-tok yytext yyline yycolumn)
- )))
- 'tagged-chars-lists
- 0
- 0
- '#((((#f #\ #\space) . 8)
- ((#f #\;) . 7)
- ((#f #\newline) . 6)
- ((#f #\%) . 5)
- ((#f #\! #\$ #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E
- #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U
- #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i
- #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y
- #\z #\~)
- .
- 4)
- ((#f #\+ #\-) . 3)
- ((#f #\.) . 2)
- ((#t #\ #\newline #\space #\! #\$
- #\% #\& #\* #\+ #\- #\.
- #\/ #\: #\; #\< #\= #\>
- #\? #\A #\B #\C #\D #\E
- #\F #\G #\H #\I #\J #\K
- #\L #\M #\N #\O #\P #\Q
- #\R #\S #\T #\U #\V #\W
- #\X #\Y #\Z #\^ #\_ #\a
- #\b #\c #\d #\e #\f #\g
- #\h #\i #\j #\k #\l #\m
- #\n #\o #\p #\q #\r #\s
- #\t #\u #\v #\w #\x #\y
- #\z #\~)
- .
- 1))
- ()
- (((#f #\.) . 9))
- ()
- (((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
- #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
- #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
- #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
- #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
- .
- 10))
- (((#f #\%) . 11)
- ((#f #\! #\$ #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6
- #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G #\H
- #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X
- #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l
- #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
- .
- 10))
- ()
- (((#t #\newline) . 12))
- ()
- (((#f #\.) . 13))
- (((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
- #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
- #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
- #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
- #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
- .
- 10))
- (((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
- #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
- #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
- #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
- #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
- .
- 10))
- (((#t #\newline) . 12))
- ())
- '#((#f . #f) (4 . 4) (4 . 4) (3 . 3) (3 . 3) (3 . 3) (1 . 1)
- (0 . 0) (0 . 0) (#f . #f) (3 . 3) (2 . 2) (0 . 0) (3 . 3))))
-
-; Module regexp.l.scm.
-;
-; Table generated from the file regexp.l by SILex 1.0
-;
-
-(define regexp-tables
- (vector
- 'all
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok eof-tok yytext yyline yycolumn)
- ))
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (begin
- (display "Error: Invalid token.")
- (newline)
- 'error)
- ))
- (vector
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok hblank-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok vblank-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok pipe-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok question-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok plus-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok star-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok lpar-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok rpar-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok dot-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok lbrack-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok lbrack-rbrack-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok lbrack-caret-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok lbrack-minus-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-id-ref yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-power-m yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-power-m-inf yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-power-m-n yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok illegal-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok doublequote-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-spec-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-digits-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-digits-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-quoted-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok caret-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok dollar-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-ordinary-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok <<EOF>>-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok <<ERROR>>-tok yytext yyline yycolumn)
- )))
- 'tagged-chars-lists
- 0
- 0
- '#((((#f #\ #\space) . 18)
- ((#f #\;) . 17)
- ((#f #\newline) . 16)
- ((#f #\|) . 15)
- ((#f #\?) . 14)
- ((#f #\+) . 13)
- ((#f #\*) . 12)
- ((#f #\() . 11)
- ((#f #\)) . 10)
- ((#f #\.) . 9)
- ((#f #\[) . 8)
- ((#f #\{) . 7)
- ((#f #\") . 6)
- ((#f #\\) . 5)
- ((#f #\^) . 4)
- ((#f #\$) . 3)
- ((#t #\ #\newline #\space #\" #\$
- #\( #\) #\* #\+ #\. #\;
- #\< #\? #\[ #\\ #\^ #\{
- #\|)
- .
- 2)
- ((#f #\<) . 1))
- (((#f #\<) . 19))
- ()
- ()
- ()
- (((#f #\n) . 23)
- ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 22)
- ((#f #\-) . 21)
- ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 20))
- ()
- (((#f #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D
- #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
- #\U #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h
- #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
- #\y #\z #\~)
- .
- 27)
- ((#f #\+ #\-) . 26)
- ((#f #\.) . 25)
- ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24))
- (((#f #\]) . 30) ((#f #\^) . 29) ((#f #\-) . 28))
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- ()
- (((#t #\newline) . 31))
- ()
- (((#f #\E) . 32))
- ()
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
- ()
- (((#f #\}) . 36)
- ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24)
- ((#f #\,) . 35))
- (((#f #\.) . 37))
- (((#f #\}) . 38))
- (((#f #\}) . 38)
- ((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
- #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
- #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
- #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
- #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
- .
- 27))
- ()
- ()
- ()
- (((#t #\newline) . 31))
- (((#f #\O) . 40) ((#f #\R) . 39))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
- (((#f #\}) . 42) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
- ()
- (((#f #\.) . 26))
- ()
- (((#f #\R) . 43))
- (((#f #\F) . 44))
- (((#f #\}) . 45) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
- ()
- (((#f #\O) . 46))
- (((#f #\>) . 47))
- ()
- (((#f #\R) . 48))
- (((#f #\>) . 49))
- (((#f #\>) . 50))
- ()
- (((#f #\>) . 51))
- ())
- '#((#f . #f) (25 . 25) (25 . 25) (24 . 24) (23 . 23) (25 . 25) (18 . 18)
- (17 . 17) (9 . 9) (8 . 8) (7 . 7) (6 . 6) (5 . 5) (4 . 4)
- (3 . 3) (2 . 2) (1 . 1) (0 . 0) (0 . 0) (#f . #f) (22 . 22)
- (22 . 22) (20 . 20) (19 . 19) (#f . #f) (#f . #f) (#f . #f) (#f . #f)
- (12 . 12) (11 . 11) (10 . 10) (0 . 0) (#f . #f) (21 . 21) (20 . 20)
- (#f . #f) (14 . 14) (#f . #f) (13 . 13) (#f . #f) (#f . #f) (#f . #f)
- (15 . 15) (#f . #f) (#f . #f) (16 . 16) (#f . #f) (#f . #f) (#f . #f)
- (26 . 26) (#f . #f) (27 . 27))))
-
-; Module string.l.scm.
-;
-; Table generated from the file string.l by SILex 1.0
-;
-
-(define string-tables
- (vector
- 'all
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok eof-tok yytext yyline yycolumn)
- ))
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (begin
- (display "Error: Invalid token.")
- (newline)
- 'error)
- ))
- (vector
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (make-tok doublequote-tok yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-spec-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-digits-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-digits-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-quoted-char yytext yyline yycolumn)
- ))
- #t
- (lambda (yycontinue yygetc yyungetc)
- (lambda (yytext yyline yycolumn yyoffset)
- (parse-ordinary-char yytext yyline yycolumn)
- )))
- 'tagged-chars-lists
- 0
- 0
- '#((((#f #\") . 3) ((#f #\\) . 2) ((#t #\" #\\) . 1))
- ()
- (((#f #\n) . 7)
- ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 6)
- ((#f #\-) . 5)
- ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 4))
- ()
- ()
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
- ()
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
- (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9)))
- '#((#f . #f) (5 . 5) (5 . 5) (0 . 0) (4 . 4) (4 . 4) (2 . 2)
- (1 . 1) (3 . 3) (2 . 2))))
-
-; Module multilex.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Gestion des Input Systems
-; Fonctions a utiliser par l'usager:
-; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
-; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
-;
-
-; Taille initiale par defaut du buffer d'entree
-(define lexer-init-buffer-len 1024)
-
-; Numero du caractere newline
-(define lexer-integer-newline (char->integer #\newline))
-
-; Constructeur d'IS brut
-(define lexer-raw-IS-maker
- (lambda (buffer read-ptr input-f counters)
- (let ((input-f input-f) ; Entree reelle
- (buffer buffer) ; Buffer
- (buflen (string-length buffer))
- (read-ptr read-ptr)
- (start-ptr 1) ; Marque de debut de lexeme
- (start-line 1)
- (start-column 1)
- (start-offset 0)
- (end-ptr 1) ; Marque de fin de lexeme
- (point-ptr 1) ; Le point
- (user-ptr 1) ; Marque de l'usager
- (user-line 1)
- (user-column 1)
- (user-offset 0)
- (user-up-to-date? #t)) ; Concerne la colonne seul.
- (letrec
- ((start-go-to-end-none ; Fonctions de depl. des marques
- (lambda ()
- (set! start-ptr end-ptr)))
- (start-go-to-end-line
- (lambda ()
- (let loop ((ptr start-ptr) (line start-line))
- (if (= ptr end-ptr)
- (begin
- (set! start-ptr ptr)
- (set! start-line line))
- (if (char=? (string-ref buffer ptr) #\newline)
- (loop (+ ptr 1) (+ line 1))
- (loop (+ ptr 1) line))))))
- (start-go-to-end-all
- (lambda ()
- (set! start-offset (+ start-offset (- end-ptr start-ptr)))
- (let loop ((ptr start-ptr)
- (line start-line)
- (column start-column))
- (if (= ptr end-ptr)
- (begin
- (set! start-ptr ptr)
- (set! start-line line)
- (set! start-column column))
- (if (char=? (string-ref buffer ptr) #\newline)
- (loop (+ ptr 1) (+ line 1) 1)
- (loop (+ ptr 1) line (+ column 1)))))))
- (start-go-to-user-none
- (lambda ()
- (set! start-ptr user-ptr)))
- (start-go-to-user-line
- (lambda ()
- (set! start-ptr user-ptr)
- (set! start-line user-line)))
- (start-go-to-user-all
- (lambda ()
- (set! start-line user-line)
- (set! start-offset user-offset)
- (if user-up-to-date?
- (begin
- (set! start-ptr user-ptr)
- (set! start-column user-column))
- (let loop ((ptr start-ptr) (column start-column))
- (if (= ptr user-ptr)
- (begin
- (set! start-ptr ptr)
- (set! start-column column))
- (if (char=? (string-ref buffer ptr) #\newline)
- (loop (+ ptr 1) 1)
- (loop (+ ptr 1) (+ column 1))))))))
- (end-go-to-point
- (lambda ()
- (set! end-ptr point-ptr)))
- (point-go-to-start
- (lambda ()
- (set! point-ptr start-ptr)))
- (user-go-to-start-none
- (lambda ()
- (set! user-ptr start-ptr)))
- (user-go-to-start-line
- (lambda ()
- (set! user-ptr start-ptr)
- (set! user-line start-line)))
- (user-go-to-start-all
- (lambda ()
- (set! user-ptr start-ptr)
- (set! user-line start-line)
- (set! user-column start-column)
- (set! user-offset start-offset)
- (set! user-up-to-date? #t)))
- (init-lexeme-none ; Debute un nouveau lexeme
- (lambda ()
- (if (< start-ptr user-ptr)
- (start-go-to-user-none))
- (point-go-to-start)))
- (init-lexeme-line
- (lambda ()
- (if (< start-ptr user-ptr)
- (start-go-to-user-line))
- (point-go-to-start)))
- (init-lexeme-all
- (lambda ()
- (if (< start-ptr user-ptr)
- (start-go-to-user-all))
- (point-go-to-start)))
- (get-start-line ; Obtention des stats du debut du lxm
- (lambda ()
- start-line))
- (get-start-column
- (lambda ()
- start-column))
- (get-start-offset
- (lambda ()
- start-offset))
- (peek-left-context ; Obtention de caracteres (#f si EOF)
- (lambda ()
- (char->integer (string-ref buffer (- start-ptr 1)))))
- (peek-char
- (lambda ()
- (if (< point-ptr read-ptr)
- (char->integer (string-ref buffer point-ptr))
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer point-ptr c)
- (set! read-ptr (+ point-ptr 1))
- (char->integer c))
- (begin
- (set! input-f (lambda () 'eof))
- #f))))))
- (read-char
- (lambda ()
- (if (< point-ptr read-ptr)
- (let ((c (string-ref buffer point-ptr)))
- (set! point-ptr (+ point-ptr 1))
- (char->integer c))
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer point-ptr c)
- (set! read-ptr (+ point-ptr 1))
- (set! point-ptr read-ptr)
- (char->integer c))
- (begin
- (set! input-f (lambda () 'eof))
- #f))))))
- (get-start-end-text ; Obtention du lexeme
- (lambda ()
- (substring buffer start-ptr end-ptr)))
- (get-user-line-line ; Fonctions pour l'usager
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-line))
- user-line))
- (get-user-line-all
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-all))
- user-line))
- (get-user-column-all
- (lambda ()
- (cond ((< user-ptr start-ptr)
- (user-go-to-start-all)
- user-column)
- (user-up-to-date?
- user-column)
- (else
- (let loop ((ptr start-ptr) (column start-column))
- (if (= ptr user-ptr)
- (begin
- (set! user-column column)
- (set! user-up-to-date? #t)
- column)
- (if (char=? (string-ref buffer ptr) #\newline)
- (loop (+ ptr 1) 1)
- (loop (+ ptr 1) (+ column 1)))))))))
- (get-user-offset-all
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-all))
- user-offset))
- (user-getc-none
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-none))
- (if (< user-ptr read-ptr)
- (let ((c (string-ref buffer user-ptr)))
- (set! user-ptr (+ user-ptr 1))
- c)
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer user-ptr c)
- (set! read-ptr (+ read-ptr 1))
- (set! user-ptr read-ptr)
- c)
- (begin
- (set! input-f (lambda () 'eof))
- 'eof))))))
- (user-getc-line
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-line))
- (if (< user-ptr read-ptr)
- (let ((c (string-ref buffer user-ptr)))
- (set! user-ptr (+ user-ptr 1))
- (if (char=? c #\newline)
- (set! user-line (+ user-line 1)))
- c)
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer user-ptr c)
- (set! read-ptr (+ read-ptr 1))
- (set! user-ptr read-ptr)
- (if (char=? c #\newline)
- (set! user-line (+ user-line 1)))
- c)
- (begin
- (set! input-f (lambda () 'eof))
- 'eof))))))
- (user-getc-all
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-all))
- (if (< user-ptr read-ptr)
- (let ((c (string-ref buffer user-ptr)))
- (set! user-ptr (+ user-ptr 1))
- (if (char=? c #\newline)
- (begin
- (set! user-line (+ user-line 1))
- (set! user-column 1))
- (set! user-column (+ user-column 1)))
- (set! user-offset (+ user-offset 1))
- c)
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer user-ptr c)
- (set! read-ptr (+ read-ptr 1))
- (set! user-ptr read-ptr)
- (if (char=? c #\newline)
- (begin
- (set! user-line (+ user-line 1))
- (set! user-column 1))
- (set! user-column (+ user-column 1)))
- (set! user-offset (+ user-offset 1))
- c)
- (begin
- (set! input-f (lambda () 'eof))
- 'eof))))))
- (user-ungetc-none
- (lambda ()
- (if (> user-ptr start-ptr)
- (set! user-ptr (- user-ptr 1)))))
- (user-ungetc-line
- (lambda ()
- (if (> user-ptr start-ptr)
- (begin
- (set! user-ptr (- user-ptr 1))
- (let ((c (string-ref buffer user-ptr)))
- (if (char=? c #\newline)
- (set! user-line (- user-line 1))))))))
- (user-ungetc-all
- (lambda ()
- (if (> user-ptr start-ptr)
- (begin
- (set! user-ptr (- user-ptr 1))
- (let ((c (string-ref buffer user-ptr)))
- (if (char=? c #\newline)
- (begin
- (set! user-line (- user-line 1))
- (set! user-up-to-date? #f))
- (set! user-column (- user-column 1)))
- (set! user-offset (- user-offset 1)))))))
- (reorganize-buffer ; Decaler ou agrandir le buffer
- (lambda ()
- (if (< (* 2 start-ptr) buflen)
- (let* ((newlen (* 2 buflen))
- (newbuf (make-string newlen))
- (delta (- start-ptr 1)))
- (let loop ((from (- start-ptr 1)))
- (if (< from buflen)
- (begin
- (string-set! newbuf
- (- from delta)
- (string-ref buffer from))
- (loop (+ from 1)))))
- (set! buffer newbuf)
- (set! buflen newlen)
- (set! read-ptr (- read-ptr delta))
- (set! start-ptr (- start-ptr delta))
- (set! end-ptr (- end-ptr delta))
- (set! point-ptr (- point-ptr delta))
- (set! user-ptr (- user-ptr delta)))
- (let ((delta (- start-ptr 1)))
- (let loop ((from (- start-ptr 1)))
- (if (< from buflen)
- (begin
- (string-set! buffer
- (- from delta)
- (string-ref buffer from))
- (loop (+ from 1)))))
- (set! read-ptr (- read-ptr delta))
- (set! start-ptr (- start-ptr delta))
- (set! end-ptr (- end-ptr delta))
- (set! point-ptr (- point-ptr delta))
- (set! user-ptr (- user-ptr delta)))))))
- (list (cons 'start-go-to-end
- (cond ((eq? counters 'none) start-go-to-end-none)
- ((eq? counters 'line) start-go-to-end-line)
- ((eq? counters 'all ) start-go-to-end-all)))
- (cons 'end-go-to-point
- end-go-to-point)
- (cons 'init-lexeme
- (cond ((eq? counters 'none) init-lexeme-none)
- ((eq? counters 'line) init-lexeme-line)
- ((eq? counters 'all ) init-lexeme-all)))
- (cons 'get-start-line
- get-start-line)
- (cons 'get-start-column
- get-start-column)
- (cons 'get-start-offset
- get-start-offset)
- (cons 'peek-left-context
- peek-left-context)
- (cons 'peek-char
- peek-char)
- (cons 'read-char
- read-char)
- (cons 'get-start-end-text
- get-start-end-text)
- (cons 'get-user-line
- (cond ((eq? counters 'none) #f)
- ((eq? counters 'line) get-user-line-line)
- ((eq? counters 'all ) get-user-line-all)))
- (cons 'get-user-column
- (cond ((eq? counters 'none) #f)
- ((eq? counters 'line) #f)
- ((eq? counters 'all ) get-user-column-all)))
- (cons 'get-user-offset
- (cond ((eq? counters 'none) #f)
- ((eq? counters 'line) #f)
- ((eq? counters 'all ) get-user-offset-all)))
- (cons 'user-getc
- (cond ((eq? counters 'none) user-getc-none)
- ((eq? counters 'line) user-getc-line)
- ((eq? counters 'all ) user-getc-all)))
- (cons 'user-ungetc
- (cond ((eq? counters 'none) user-ungetc-none)
- ((eq? counters 'line) user-ungetc-line)
- ((eq? counters 'all ) user-ungetc-all))))))))
-
-; Construit un Input System
-; Le premier parametre doit etre parmi "port", "procedure" ou "string"
-; Prend un parametre facultatif qui doit etre parmi
-; "none", "line" ou "all"
-(define lexer-make-IS
- (lambda (input-type input . largs)
- (let ((counters-type (cond ((null? largs)
- 'line)
- ((memq (car largs) '(none line all))
- (car largs))
- (else
- 'line))))
- (cond ((and (eq? input-type 'port) (input-port? input))
- (let* ((buffer (make-string lexer-init-buffer-len #\newline))
- (read-ptr 1)
- (input-f (lambda () (read-char input))))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
- ((and (eq? input-type 'procedure) (procedure? input))
- (let* ((buffer (make-string lexer-init-buffer-len #\newline))
- (read-ptr 1)
- (input-f input))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
- ((and (eq? input-type 'string) (string? input))
- (let* ((buffer (string-append (string #\newline) input))
- (read-ptr (string-length buffer))
- (input-f (lambda () 'eof)))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
- (else
- (let* ((buffer (string #\newline))
- (read-ptr 1)
- (input-f (lambda () 'eof)))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
-
-; Les fonctions:
-; lexer-get-func-getc, lexer-get-func-ungetc,
-; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
-(define lexer-get-func-getc
- (lambda (IS) (cdr (assq 'user-getc IS))))
-(define lexer-get-func-ungetc
- (lambda (IS) (cdr (assq 'user-ungetc IS))))
-(define lexer-get-func-line
- (lambda (IS) (cdr (assq 'get-user-line IS))))
-(define lexer-get-func-column
- (lambda (IS) (cdr (assq 'get-user-column IS))))
-(define lexer-get-func-offset
- (lambda (IS) (cdr (assq 'get-user-offset IS))))
-
-;
-; Gestion des lexers
-;
-
-; Fabrication de lexer a partir d'arbres de decision
-(define lexer-make-tree-lexer
- (lambda (tables IS)
- (letrec
- (; Contenu de la table
- (counters-type (vector-ref tables 0))
- (<<EOF>>-pre-action (vector-ref tables 1))
- (<<ERROR>>-pre-action (vector-ref tables 2))
- (rules-pre-actions (vector-ref tables 3))
- (table-nl-start (vector-ref tables 5))
- (table-no-nl-start (vector-ref tables 6))
- (trees-v (vector-ref tables 7))
- (acc-v (vector-ref tables 8))
-
- ; Contenu du IS
- (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
- (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
- (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
- (IS-get-start-line (cdr (assq 'get-start-line IS)))
- (IS-get-start-column (cdr (assq 'get-start-column IS)))
- (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
- (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
- (IS-peek-char (cdr (assq 'peek-char IS)))
- (IS-read-char (cdr (assq 'read-char IS)))
- (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
- (IS-get-user-line (cdr (assq 'get-user-line IS)))
- (IS-get-user-column (cdr (assq 'get-user-column IS)))
- (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
- (IS-user-getc (cdr (assq 'user-getc IS)))
- (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
-
- ; Resultats
- (<<EOF>>-action #f)
- (<<ERROR>>-action #f)
- (rules-actions #f)
- (states #f)
- (final-lexer #f)
-
- ; Gestion des hooks
- (hook-list '())
- (add-hook
- (lambda (thunk)
- (set! hook-list (cons thunk hook-list))))
- (apply-hooks
- (lambda ()
- (let loop ((l hook-list))
- (if (pair? l)
- (begin
- ((car l))
- (loop (cdr l)))))))
-
- ; Preparation des actions
- (set-action-statics
- (lambda (pre-action)
- (pre-action final-lexer IS-user-getc IS-user-ungetc)))
- (prepare-special-action-none
- (lambda (pre-action)
- (let ((action #f))
- (let ((result
- (lambda ()
- (action "")))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-special-action-line
- (lambda (pre-action)
- (let ((action #f))
- (let ((result
- (lambda (yyline)
- (action "" yyline)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-special-action-all
- (lambda (pre-action)
- (let ((action #f))
- (let ((result
- (lambda (yyline yycolumn yyoffset)
- (action "" yyline yycolumn yyoffset)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-special-action
- (lambda (pre-action)
- (cond ((eq? counters-type 'none)
- (prepare-special-action-none pre-action))
- ((eq? counters-type 'line)
- (prepare-special-action-line pre-action))
- ((eq? counters-type 'all)
- (prepare-special-action-all pre-action)))))
- (prepare-action-yytext-none
- (lambda (pre-action)
- (let ((get-start-end-text IS-get-start-end-text)
- (start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda ()
- (let ((yytext (get-start-end-text)))
- (start-go-to-end)
- (action yytext))))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-yytext-line
- (lambda (pre-action)
- (let ((get-start-end-text IS-get-start-end-text)
- (start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline)
- (let ((yytext (get-start-end-text)))
- (start-go-to-end)
- (action yytext yyline))))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-yytext-all
- (lambda (pre-action)
- (let ((get-start-end-text IS-get-start-end-text)
- (start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline yycolumn yyoffset)
- (let ((yytext (get-start-end-text)))
- (start-go-to-end)
- (action yytext yyline yycolumn yyoffset))))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-yytext
- (lambda (pre-action)
- (cond ((eq? counters-type 'none)
- (prepare-action-yytext-none pre-action))
- ((eq? counters-type 'line)
- (prepare-action-yytext-line pre-action))
- ((eq? counters-type 'all)
- (prepare-action-yytext-all pre-action)))))
- (prepare-action-no-yytext-none
- (lambda (pre-action)
- (let ((start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda ()
- (start-go-to-end)
- (action)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-no-yytext-line
- (lambda (pre-action)
- (let ((start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline)
- (start-go-to-end)
- (action yyline)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-no-yytext-all
- (lambda (pre-action)
- (let ((start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline yycolumn yyoffset)
- (start-go-to-end)
- (action yyline yycolumn yyoffset)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-no-yytext
- (lambda (pre-action)
- (cond ((eq? counters-type 'none)
- (prepare-action-no-yytext-none pre-action))
- ((eq? counters-type 'line)
- (prepare-action-no-yytext-line pre-action))
- ((eq? counters-type 'all)
- (prepare-action-no-yytext-all pre-action)))))
-
- ; Fabrique les fonctions de dispatch
- (prepare-dispatch-err
- (lambda (leaf)
- (lambda (c)
- #f)))
- (prepare-dispatch-number
- (lambda (leaf)
- (let ((state-function #f))
- (let ((result
- (lambda (c)
- state-function))
- (hook
- (lambda ()
- (set! state-function (vector-ref states leaf)))))
- (add-hook hook)
- result))))
- (prepare-dispatch-leaf
- (lambda (leaf)
- (if (eq? leaf 'err)
- (prepare-dispatch-err leaf)
- (prepare-dispatch-number leaf))))
- (prepare-dispatch-<
- (lambda (tree)
- (let ((left-tree (list-ref tree 1))
- (right-tree (list-ref tree 2)))
- (let ((bound (list-ref tree 0))
- (left-func (prepare-dispatch-tree left-tree))
- (right-func (prepare-dispatch-tree right-tree)))
- (lambda (c)
- (if (< c bound)
- (left-func c)
- (right-func c)))))))
- (prepare-dispatch-=
- (lambda (tree)
- (let ((left-tree (list-ref tree 2))
- (right-tree (list-ref tree 3)))
- (let ((bound (list-ref tree 1))
- (left-func (prepare-dispatch-tree left-tree))
- (right-func (prepare-dispatch-tree right-tree)))
- (lambda (c)
- (if (= c bound)
- (left-func c)
- (right-func c)))))))
- (prepare-dispatch-tree
- (lambda (tree)
- (cond ((not (pair? tree))
- (prepare-dispatch-leaf tree))
- ((eq? (car tree) '=)
- (prepare-dispatch-= tree))
- (else
- (prepare-dispatch-< tree)))))
- (prepare-dispatch
- (lambda (tree)
- (let ((dicho-func (prepare-dispatch-tree tree)))
- (lambda (c)
- (and c (dicho-func c))))))
-
- ; Fabrique les fonctions de transition (read & go) et (abort)
- (prepare-read-n-go
- (lambda (tree)
- (let ((dispatch-func (prepare-dispatch tree))
- (read-char IS-read-char))
- (lambda ()
- (dispatch-func (read-char))))))
- (prepare-abort
- (lambda (tree)
- (lambda ()
- #f)))
- (prepare-transition
- (lambda (tree)
- (if (eq? tree 'err)
- (prepare-abort tree)
- (prepare-read-n-go tree))))
-
- ; Fabrique les fonctions d'etats ([set-end] & trans)
- (prepare-state-no-acc
- (lambda (s r1 r2)
- (let ((trans-func (prepare-transition (vector-ref trees-v s))))
- (lambda (action)
- (let ((next-state (trans-func)))
- (if next-state
- (next-state action)
- action))))))
- (prepare-state-yes-no
- (lambda (s r1 r2)
- (let ((peek-char IS-peek-char)
- (end-go-to-point IS-end-go-to-point)
- (new-action1 #f)
- (trans-func (prepare-transition (vector-ref trees-v s))))
- (let ((result
- (lambda (action)
- (let* ((c (peek-char))
- (new-action
- (if (or (not c) (= c lexer-integer-newline))
- (begin
- (end-go-to-point)
- new-action1)
- action))
- (next-state (trans-func)))
- (if next-state
- (next-state new-action)
- new-action))))
- (hook
- (lambda ()
- (set! new-action1 (vector-ref rules-actions r1)))))
- (add-hook hook)
- result))))
- (prepare-state-diff-acc
- (lambda (s r1 r2)
- (let ((end-go-to-point IS-end-go-to-point)
- (peek-char IS-peek-char)
- (new-action1 #f)
- (new-action2 #f)
- (trans-func (prepare-transition (vector-ref trees-v s))))
- (let ((result
- (lambda (action)
- (end-go-to-point)
- (let* ((c (peek-char))
- (new-action
- (if (or (not c) (= c lexer-integer-newline))
- new-action1
- new-action2))
- (next-state (trans-func)))
- (if next-state
- (next-state new-action)
- new-action))))
- (hook
- (lambda ()
- (set! new-action1 (vector-ref rules-actions r1))
- (set! new-action2 (vector-ref rules-actions r2)))))
- (add-hook hook)
- result))))
- (prepare-state-same-acc
- (lambda (s r1 r2)
- (let ((end-go-to-point IS-end-go-to-point)
- (trans-func (prepare-transition (vector-ref trees-v s)))
- (new-action #f))
- (let ((result
- (lambda (action)
- (end-go-to-point)
- (let ((next-state (trans-func)))
- (if next-state
- (next-state new-action)
- new-action))))
- (hook
- (lambda ()
- (set! new-action (vector-ref rules-actions r1)))))
- (add-hook hook)
- result))))
- (prepare-state
- (lambda (s)
- (let* ((acc (vector-ref acc-v s))
- (r1 (car acc))
- (r2 (cdr acc)))
- (cond ((not r1) (prepare-state-no-acc s r1 r2))
- ((not r2) (prepare-state-yes-no s r1 r2))
- ((< r1 r2) (prepare-state-diff-acc s r1 r2))
- (else (prepare-state-same-acc s r1 r2))))))
-
- ; Fabrique la fonction de lancement du lexage a l'etat de depart
- (prepare-start-same
- (lambda (s1 s2)
- (let ((peek-char IS-peek-char)
- (eof-action #f)
- (start-state #f)
- (error-action #f))
- (let ((result
- (lambda ()
- (if (not (peek-char))
- eof-action
- (start-state error-action))))
- (hook
- (lambda ()
- (set! eof-action <<EOF>>-action)
- (set! start-state (vector-ref states s1))
- (set! error-action <<ERROR>>-action))))
- (add-hook hook)
- result))))
- (prepare-start-diff
- (lambda (s1 s2)
- (let ((peek-char IS-peek-char)
- (eof-action #f)
- (peek-left-context IS-peek-left-context)
- (start-state1 #f)
- (start-state2 #f)
- (error-action #f))
- (let ((result
- (lambda ()
- (cond ((not (peek-char))
- eof-action)
- ((= (peek-left-context) lexer-integer-newline)
- (start-state1 error-action))
- (else
- (start-state2 error-action)))))
- (hook
- (lambda ()
- (set! eof-action <<EOF>>-action)
- (set! start-state1 (vector-ref states s1))
- (set! start-state2 (vector-ref states s2))
- (set! error-action <<ERROR>>-action))))
- (add-hook hook)
- result))))
- (prepare-start
- (lambda ()
- (let ((s1 table-nl-start)
- (s2 table-no-nl-start))
- (if (= s1 s2)
- (prepare-start-same s1 s2)
- (prepare-start-diff s1 s2)))))
-
- ; Fabrique la fonction principale
- (prepare-lexer-none
- (lambda ()
- (let ((init-lexeme IS-init-lexeme)
- (start-func (prepare-start)))
- (lambda ()
- (init-lexeme)
- ((start-func))))))
- (prepare-lexer-line
- (lambda ()
- (let ((init-lexeme IS-init-lexeme)
- (get-start-line IS-get-start-line)
- (start-func (prepare-start)))
- (lambda ()
- (init-lexeme)
- (let ((yyline (get-start-line)))
- ((start-func) yyline))))))
- (prepare-lexer-all
- (lambda ()
- (let ((init-lexeme IS-init-lexeme)
- (get-start-line IS-get-start-line)
- (get-start-column IS-get-start-column)
- (get-start-offset IS-get-start-offset)
- (start-func (prepare-start)))
- (lambda ()
- (init-lexeme)
- (let ((yyline (get-start-line))
- (yycolumn (get-start-column))
- (yyoffset (get-start-offset)))
- ((start-func) yyline yycolumn yyoffset))))))
- (prepare-lexer
- (lambda ()
- (cond ((eq? counters-type 'none) (prepare-lexer-none))
- ((eq? counters-type 'line) (prepare-lexer-line))
- ((eq? counters-type 'all) (prepare-lexer-all))))))
-
- ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
- (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
- (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
-
- ; Calculer la valeur de rules-actions
- (let* ((len (quotient (vector-length rules-pre-actions) 2))
- (v (make-vector len)))
- (let loop ((r (- len 1)))
- (if (< r 0)
- (set! rules-actions v)
- (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
- (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
- (action (if yytext?
- (prepare-action-yytext pre-action)
- (prepare-action-no-yytext pre-action))))
- (vector-set! v r action)
- (loop (- r 1))))))
-
- ; Calculer la valeur de states
- (let* ((len (vector-length trees-v))
- (v (make-vector len)))
- (let loop ((s (- len 1)))
- (if (< s 0)
- (set! states v)
- (begin
- (vector-set! v s (prepare-state s))
- (loop (- s 1))))))
-
- ; Calculer la valeur de final-lexer
- (set! final-lexer (prepare-lexer))
-
- ; Executer les hooks
- (apply-hooks)
-
- ; Resultat
- final-lexer)))
-
-; Fabrication de lexer a partir de listes de caracteres taggees
-(define lexer-make-char-lexer
- (let* ((char->class
- (lambda (c)
- (let ((n (char->integer c)))
- (list (cons n n)))))
- (merge-sort
- (lambda (l combine zero-elt)
- (if (null? l)
- zero-elt
- (let loop1 ((l l))
- (if (null? (cdr l))
- (car l)
- (loop1
- (let loop2 ((l l))
- (cond ((null? l)
- l)
- ((null? (cdr l))
- l)
- (else
- (cons (combine (car l) (cadr l))
- (loop2 (cddr l))))))))))))
- (finite-class-union
- (lambda (c1 c2)
- (let loop ((c1 c1) (c2 c2) (u '()))
- (if (null? c1)
- (if (null? c2)
- (reverse u)
- (loop c1 (cdr c2) (cons (car c2) u)))
- (if (null? c2)
- (loop (cdr c1) c2 (cons (car c1) u))
- (let* ((r1 (car c1))
- (r2 (car c2))
- (r1start (car r1))
- (r1end (cdr r1))
- (r2start (car r2))
- (r2end (cdr r2)))
- (if (<= r1start r2start)
- (cond ((< (+ r1end 1) r2start)
- (loop (cdr c1) c2 (cons r1 u)))
- ((<= r1end r2end)
- (loop (cdr c1)
- (cons (cons r1start r2end) (cdr c2))
- u))
- (else
- (loop c1 (cdr c2) u)))
- (cond ((> r1start (+ r2end 1))
- (loop c1 (cdr c2) (cons r2 u)))
- ((>= r1end r2end)
- (loop (cons (cons r2start r1end) (cdr c1))
- (cdr c2)
- u))
- (else
- (loop (cdr c1) c2 u))))))))))
- (char-list->class
- (lambda (cl)
- (let ((classes (map char->class cl)))
- (merge-sort classes finite-class-union '()))))
- (class-<
- (lambda (b1 b2)
- (cond ((eq? b1 'inf+) #f)
- ((eq? b2 'inf-) #f)
- ((eq? b1 'inf-) #t)
- ((eq? b2 'inf+) #t)
- (else (< b1 b2)))))
- (finite-class-compl
- (lambda (c)
- (let loop ((c c) (start 'inf-))
- (if (null? c)
- (list (cons start 'inf+))
- (let* ((r (car c))
- (rstart (car r))
- (rend (cdr r)))
- (if (class-< start rstart)
- (cons (cons start (- rstart 1))
- (loop c rstart))
- (loop (cdr c) (+ rend 1))))))))
- (tagged-chars->class
- (lambda (tcl)
- (let* ((inverse? (car tcl))
- (cl (cdr tcl))
- (class-tmp (char-list->class cl)))
- (if inverse? (finite-class-compl class-tmp) class-tmp))))
- (charc->arc
- (lambda (charc)
- (let* ((tcl (car charc))
- (dest (cdr charc))
- (class (tagged-chars->class tcl)))
- (cons class dest))))
- (arc->sharcs
- (lambda (arc)
- (let* ((range-l (car arc))
- (dest (cdr arc))
- (op (lambda (range) (cons range dest))))
- (map op range-l))))
- (class-<=
- (lambda (b1 b2)
- (cond ((eq? b1 'inf-) #t)
- ((eq? b2 'inf+) #t)
- ((eq? b1 'inf+) #f)
- ((eq? b2 'inf-) #f)
- (else (<= b1 b2)))))
- (sharc-<=
- (lambda (sharc1 sharc2)
- (class-<= (caar sharc1) (caar sharc2))))
- (merge-sharcs
- (lambda (l1 l2)
- (let loop ((l1 l1) (l2 l2))
- (cond ((null? l1)
- l2)
- ((null? l2)
- l1)
- (else
- (let ((sharc1 (car l1))
- (sharc2 (car l2)))
- (if (sharc-<= sharc1 sharc2)
- (cons sharc1 (loop (cdr l1) l2))
- (cons sharc2 (loop l1 (cdr l2))))))))))
- (class-= eqv?)
- (fill-error
- (lambda (sharcs)
- (let loop ((sharcs sharcs) (start 'inf-))
- (cond ((class-= start 'inf+)
- '())
- ((null? sharcs)
- (cons (cons (cons start 'inf+) 'err)
- (loop sharcs 'inf+)))
- (else
- (let* ((sharc (car sharcs))
- (h (caar sharc))
- (t (cdar sharc)))
- (if (class-< start h)
- (cons (cons (cons start (- h 1)) 'err)
- (loop sharcs h))
- (cons sharc (loop (cdr sharcs)
- (if (class-= t 'inf+)
- 'inf+
- (+ t 1)))))))))))
- (charcs->tree
- (lambda (charcs)
- (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
- (sharcs-l (map op charcs))
- (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
- (full-sharcs (fill-error sorted-sharcs))
- (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
- (table (list->vector (map op full-sharcs))))
- (let loop ((left 0) (right (- (vector-length table) 1)))
- (if (= left right)
- (cdr (vector-ref table left))
- (let ((mid (quotient (+ left right 1) 2)))
- (if (and (= (+ left 2) right)
- (= (+ (car (vector-ref table mid)) 1)
- (car (vector-ref table right)))
- (eqv? (cdr (vector-ref table left))
- (cdr (vector-ref table right))))
- (list '=
- (car (vector-ref table mid))
- (cdr (vector-ref table mid))
- (cdr (vector-ref table left)))
- (list (car (vector-ref table mid))
- (loop left (- mid 1))
- (loop mid right))))))))))
- (lambda (tables IS)
- (let ((counters (vector-ref tables 0))
- (<<EOF>>-action (vector-ref tables 1))
- (<<ERROR>>-action (vector-ref tables 2))
- (rules-actions (vector-ref tables 3))
- (nl-start (vector-ref tables 5))
- (no-nl-start (vector-ref tables 6))
- (charcs-v (vector-ref tables 7))
- (acc-v (vector-ref tables 8)))
- (let* ((len (vector-length charcs-v))
- (v (make-vector len)))
- (let loop ((i (- len 1)))
- (if (>= i 0)
- (begin
- (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
- (loop (- i 1)))
- (lexer-make-tree-lexer
- (vector counters
- <<EOF>>-action
- <<ERROR>>-action
- rules-actions
- 'decision-trees
- nl-start
- no-nl-start
- v
- acc-v)
- IS))))))))
-
-; Fabrication d'un lexer a partir de code pre-genere
-(define lexer-make-code-lexer
- (lambda (tables IS)
- (let ((<<EOF>>-pre-action (vector-ref tables 1))
- (<<ERROR>>-pre-action (vector-ref tables 2))
- (rules-pre-action (vector-ref tables 3))
- (code (vector-ref tables 5)))
- (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
-
-(define lexer-make-lexer
- (lambda (tables IS)
- (let ((automaton-type (vector-ref tables 4)))
- (cond ((eq? automaton-type 'decision-trees)
- (lexer-make-tree-lexer tables IS))
- ((eq? automaton-type 'tagged-chars-lists)
- (lexer-make-char-lexer tables IS))
- ((eq? automaton-type 'code)
- (lexer-make-code-lexer tables IS))))))
-
-; Module lexparser.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Fonctions auxilliaires du lexer
-;
-
-(define parse-spec-char
- (lambda (lexeme line column)
- (make-tok char-tok lexeme line column newline-ch)))
-
-(define parse-digits-char
- (lambda (lexeme line column)
- (let* ((num (substring lexeme 1 (string-length lexeme)))
- (n (string->number num)))
- (make-tok char-tok lexeme line column n))))
-
-(define parse-quoted-char
- (lambda (lexeme line column)
- (let ((c (string-ref lexeme 1)))
- (make-tok char-tok lexeme line column (char->integer c)))))
-
-(define parse-ordinary-char
- (lambda (lexeme line column)
- (let ((c (string-ref lexeme 0)))
- (make-tok char-tok lexeme line column (char->integer c)))))
-
-(define extract-id
- (lambda (s)
- (let ((len (string-length s)))
- (substring s 1 (- len 1)))))
-
-(define parse-id
- (lambda (lexeme line column)
- (make-tok id-tok lexeme line column (string-downcase lexeme) lexeme)))
-
-(define parse-id-ref
- (lambda (lexeme line column)
- (let* ((orig-name (extract-id lexeme))
- (name (string-downcase orig-name)))
- (make-tok subst-tok lexeme line column name orig-name))))
-
-(define parse-power-m
- (lambda (lexeme line column)
- (let* ((len (string-length lexeme))
- (substr (substring lexeme 1 (- len 1)))
- (m (string->number substr))
- (range (cons m m)))
- (make-tok power-tok lexeme line column range))))
-
-(define parse-power-m-inf
- (lambda (lexeme line column)
- (let* ((len (string-length lexeme))
- (substr (substring lexeme 1 (- len 2)))
- (m (string->number substr))
- (range (cons m 'inf)))
- (make-tok power-tok lexeme line column range))))
-
-(define parse-power-m-n
- (lambda (lexeme line column)
- (let ((len (string-length lexeme)))
- (let loop ((comma 2))
- (if (char=? (string-ref lexeme comma) #\,)
- (let* ((sub1 (substring lexeme 1 comma))
- (sub2 (substring lexeme (+ comma 1) (- len 1)))
- (m (string->number sub1))
- (n (string->number sub2))
- (range (cons m n)))
- (make-tok power-tok lexeme line column range))
- (loop (+ comma 1)))))))
-
-
-
-
-;
-; Lexer generique
-;
-
-(define lexer-raw #f)
-(define lexer-stack '())
-
-(define lexer-alist #f)
-
-(define lexer-buffer #f)
-(define lexer-buffer-empty? #t)
-
-(define lexer-history '())
-(define lexer-history-interp #f)
-
-(define init-lexer
- (lambda (port)
- (let* ((IS (lexer-make-IS 'port port 'all))
- (action-lexer (lexer-make-lexer action-tables IS))
- (class-lexer (lexer-make-lexer class-tables IS))
- (macro-lexer (lexer-make-lexer macro-tables IS))
- (regexp-lexer (lexer-make-lexer regexp-tables IS))
- (string-lexer (lexer-make-lexer string-tables IS)))
- (set! lexer-raw #f)
- (set! lexer-stack '())
- (set! lexer-alist
- (list (cons 'action action-lexer)
- (cons 'class class-lexer)
- (cons 'macro macro-lexer)
- (cons 'regexp regexp-lexer)
- (cons 'string string-lexer)))
- (set! lexer-buffer-empty? #t)
- (set! lexer-history '()))))
-
-; Lexer brut
-; S'assurer qu'il n'y a pas de risque de changer de
-; lexer quand le buffer est rempli
-(define push-lexer
- (lambda (name)
- (set! lexer-stack (cons lexer-raw lexer-stack))
- (set! lexer-raw (cdr (assq name lexer-alist)))))
-
-(define pop-lexer
- (lambda ()
- (set! lexer-raw (car lexer-stack))
- (set! lexer-stack (cdr lexer-stack))))
-
-; Traite le "unget" (capacite du unget: 1)
-(define lexer2
- (lambda ()
- (if lexer-buffer-empty?
- (lexer-raw)
- (begin
- (set! lexer-buffer-empty? #t)
- lexer-buffer))))
-
-(define lexer2-unget
- (lambda (tok)
- (set! lexer-buffer tok)
- (set! lexer-buffer-empty? #f)))
-
-; Traite l'historique
-(define lexer
- (lambda ()
- (let* ((tok (lexer2))
- (tok-lexeme (get-tok-lexeme tok))
- (hist-lexeme (if lexer-history-interp
- (blank-translate tok-lexeme)
- tok-lexeme)))
- (set! lexer-history (cons hist-lexeme lexer-history))
- tok)))
-
-(define lexer-unget
- (lambda (tok)
- (set! lexer-history (cdr lexer-history))
- (lexer2-unget tok)))
-
-(define lexer-set-blank-history
- (lambda (b)
- (set! lexer-history-interp b)))
-
-(define blank-translate
- (lambda (s)
- (let ((ss (string-copy s)))
- (let loop ((i (- (string-length ss) 1)))
- (cond ((< i 0)
- ss)
- ((char=? (string-ref ss i) (integer->char tab-ch))
- (loop (- i 1)))
- ((char=? (string-ref ss i) #\newline)
- (loop (- i 1)))
- (else
- (string-set! ss i #\space)
- (loop (- i 1))))))))
-
-(define lexer-get-history
- (lambda ()
- (let* ((rightlist (reverse lexer-history))
- (str (string-append-list rightlist))
- (strlen (string-length str))
- (str2 (if (and (> strlen 0)
- (char=? (string-ref str (- strlen 1)) #\newline))
- str
- (string-append str (string #\newline)))))
- (set! lexer-history '())
- str2)))
-
-
-
-
-;
-; Traitement des listes de tokens
-;
-
-(define de-anchor-tokens
- (let ((not-anchor-toks (make-dispatch-table number-of-tokens
- (list (cons caret-tok #f)
- (cons dollar-tok #f)
- (cons <<EOF>>-tok #f)
- (cons <<ERROR>>-tok #f))
- #t)))
- (lambda (tok-list)
- (if (null? tok-list)
- '()
- (let* ((tok (car tok-list))
- (tok-type (get-tok-type tok))
- (toks (cdr tok-list))
- (new-toks (de-anchor-tokens toks)))
- (cond ((vector-ref not-anchor-toks tok-type)
- (cons tok new-toks))
- ((or (= tok-type caret-tok) (= tok-type dollar-tok))
- (let* ((line (get-tok-line tok))
- (column (get-tok-column tok))
- (attr (if (= tok-type caret-tok) caret-ch dollar-ch))
- (new-tok (make-tok char-tok "" line column attr)))
- (cons new-tok new-toks)))
- ((= tok-type <<EOF>>-tok)
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "the <<EOF>> anchor must be used alone"
- " and only after %%."))
- ((= tok-type <<ERROR>>-tok)
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "the <<ERROR>> anchor must be used alone"
- " and only after %%."))))))))
-
-(define strip-end
- (lambda (l)
- (if (null? (cdr l))
- '()
- (cons (car l) (strip-end (cdr l))))))
-
-(define extract-anchors
- (lambda (tok-list)
- (let* ((tok1 (car tok-list))
- (line (get-tok-line tok1))
- (tok1-type (get-tok-type tok1)))
- (cond ((and (= tok1-type <<EOF>>-tok) (null? (cdr tok-list)))
- (make-rule line #t #f #f #f '() #f))
- ((and (= tok1-type <<ERROR>>-tok) (null? (cdr tok-list)))
- (make-rule line #f #t #f #f '() #f))
- (else
- (let* ((bol? (= tok1-type caret-tok))
- (tok-list2 (if bol? (cdr tok-list) tok-list)))
- (if (null? tok-list2)
- (make-rule line #f #f bol? #f tok-list2 #f)
- (let* ((len (length tok-list2))
- (tok2 (list-ref tok-list2 (- len 1)))
- (tok2-type (get-tok-type tok2))
- (eol? (= tok2-type dollar-tok))
- (tok-list3 (if eol?
- (strip-end tok-list2)
- tok-list2)))
- (make-rule line #f #f bol? eol? tok-list3 #f)))))))))
-
-(define char-list->conc
- (lambda (char-list)
- (if (null? char-list)
- (make-re epsilon-re)
- (let loop ((cl char-list))
- (let* ((c (car cl))
- (cl2 (cdr cl)))
- (if (null? cl2)
- (make-re char-re c)
- (make-re conc-re (make-re char-re c) (loop cl2))))))))
-
-(define parse-tokens-atom
- (let ((action-table
- (make-dispatch-table
- number-of-tokens
- (list (cons lpar-tok
- (lambda (tok tok-list macros)
- (parse-tokens-sub tok-list macros)))
- (cons dot-tok
- (lambda (tok tok-list macros)
- (cons (make-re class-re dot-class) (cdr tok-list))))
- (cons subst-tok
- (lambda (tok tok-list macros)
- (let* ((name (get-tok-attr tok))
- (ass (assoc name macros)))
- (if ass
- (cons (cdr ass) (cdr tok-list))
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "unknown macro \""
- (get-tok-2nd-attr tok)
- "\".")))))
- (cons char-tok
- (lambda (tok tok-list macros)
- (let ((c (get-tok-attr tok)))
- (cons (make-re char-re c) (cdr tok-list)))))
- (cons class-tok
- (lambda (tok tok-list macros)
- (let ((class (get-tok-attr tok)))
- (cons (make-re class-re class) (cdr tok-list)))))
- (cons string-tok
- (lambda (tok tok-list macros)
- (let* ((char-list (get-tok-attr tok))
- (re (char-list->conc char-list)))
- (cons re (cdr tok-list))))))
- (lambda (tok tok-list macros)
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "syntax error in regular expression.")))))
- (lambda (tok-list macros)
- (let* ((tok (car tok-list))
- (tok-type (get-tok-type tok))
- (action (vector-ref action-table tok-type)))
- (action tok tok-list macros)))))
-
-(define check-power-tok
- (lambda (tok)
- (let* ((range (get-tok-attr tok))
- (start (car range))
- (end (cdr range)))
- (if (or (eq? 'inf end) (<= start end))
- range
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "incorrect power specification.")))))
-
-(define power->star-plus
- (lambda (re range)
- (power->star-plus-rec re (car range) (cdr range))))
-
-(define power->star-plus-rec
- (lambda (re start end)
- (cond ((eq? end 'inf)
- (cond ((= start 0)
- (make-re star-re re))
- ((= start 1)
- (make-re plus-re re))
- (else
- (make-re conc-re
- re
- (power->star-plus-rec re (- start 1) 'inf)))))
- ((= start 0)
- (cond ((= end 0)
- (make-re epsilon-re))
- ((= end 1)
- (make-re question-re re))
- (else
- (make-re question-re
- (power->star-plus-rec re 1 end)))))
- ((= start 1)
- (if (= end 1)
- re
- (make-re conc-re re (power->star-plus-rec re 0 (- end 1)))))
- (else
- (make-re conc-re
- re
- (power->star-plus-rec re (- start 1) (- end 1)))))))
-
-(define parse-tokens-fact
- (let ((not-op-toks (make-dispatch-table number-of-tokens
- (list (cons question-tok #f)
- (cons plus-tok #f)
- (cons star-tok #f)
- (cons power-tok #f))
- #t)))
- (lambda (tok-list macros)
- (let* ((result (parse-tokens-atom tok-list macros))
- (re (car result))
- (tok-list2 (cdr result)))
- (let loop ((re re) (tok-list3 tok-list2))
- (let* ((tok (car tok-list3))
- (tok-type (get-tok-type tok)))
- (cond ((vector-ref not-op-toks tok-type)
- (cons re tok-list3))
- ((= tok-type question-tok)
- (loop (make-re question-re re) (cdr tok-list3)))
- ((= tok-type plus-tok)
- (loop (make-re plus-re re) (cdr tok-list3)))
- ((= tok-type star-tok)
- (loop (make-re star-re re) (cdr tok-list3)))
- ((= tok-type power-tok)
- (loop (power->star-plus re (check-power-tok tok))
- (cdr tok-list3))))))))))
-
-(define parse-tokens-conc
- (lambda (tok-list macros)
- (let* ((result1 (parse-tokens-fact tok-list macros))
- (re1 (car result1))
- (tok-list2 (cdr result1))
- (tok (car tok-list2))
- (tok-type (get-tok-type tok)))
- (cond ((or (= tok-type pipe-tok)
- (= tok-type rpar-tok))
- result1)
- (else ; Autres facteurs
- (let* ((result2 (parse-tokens-conc tok-list2 macros))
- (re2 (car result2))
- (tok-list3 (cdr result2)))
- (cons (make-re conc-re re1 re2) tok-list3)))))))
-
-(define parse-tokens-or
- (lambda (tok-list macros)
- (let* ((result1 (parse-tokens-conc tok-list macros))
- (re1 (car result1))
- (tok-list2 (cdr result1))
- (tok (car tok-list2))
- (tok-type (get-tok-type tok)))
- (cond ((= tok-type pipe-tok)
- (let* ((tok-list3 (cdr tok-list2))
- (result2 (parse-tokens-or tok-list3 macros))
- (re2 (car result2))
- (tok-list4 (cdr result2)))
- (cons (make-re or-re re1 re2) tok-list4)))
- (else ; rpar-tok
- result1)))))
-
-(define parse-tokens-sub
- (lambda (tok-list macros)
- (let* ((tok-list2 (cdr tok-list)) ; Manger le lpar-tok
- (result (parse-tokens-or tok-list2 macros))
- (re (car result))
- (tok-list3 (cdr result))
- (tok-list4 (cdr tok-list3))) ; Manger le rpar-tok
- (cons re tok-list4))))
-
-(define parse-tokens-match
- (lambda (tok-list line)
- (let loop ((tl tok-list) (count 0))
- (if (null? tl)
- (if (> count 0)
- (lex-error line
- #f
- "mismatched parentheses."))
- (let* ((tok (car tl))
- (tok-type (get-tok-type tok)))
- (cond ((= tok-type lpar-tok)
- (loop (cdr tl) (+ count 1)))
- ((= tok-type rpar-tok)
- (if (zero? count)
- (lex-error line
- #f
- "mismatched parentheses."))
- (loop (cdr tl) (- count 1)))
- (else
- (loop (cdr tl) count))))))))
-
-; Ne traite pas les anchors
-(define parse-tokens
- (lambda (tok-list macros)
- (if (null? tok-list)
- (make-re epsilon-re)
- (let ((line (get-tok-line (car tok-list))))
- (parse-tokens-match tok-list line)
- (let* ((begin-par (make-tok lpar-tok "" line 1))
- (end-par (make-tok rpar-tok "" line 1)))
- (let* ((tok-list2 (append (list begin-par)
- tok-list
- (list end-par)))
- (result (parse-tokens-sub tok-list2 macros)))
- (car result))))))) ; (cdr result) == () obligatoirement
-
-(define tokens->regexp
- (lambda (tok-list macros)
- (let ((tok-list2 (de-anchor-tokens tok-list)))
- (parse-tokens tok-list2 macros))))
-
-(define tokens->rule
- (lambda (tok-list macros)
- (let* ((rule (extract-anchors tok-list))
- (tok-list2 (get-rule-regexp rule))
- (tok-list3 (de-anchor-tokens tok-list2))
- (re (parse-tokens tok-list3 macros)))
- (set-rule-regexp rule re)
- rule)))
-
-; Retourne une paire: <<EOF>>-action et vecteur des regles ordinaires
-(define adapt-rules
- (lambda (rules)
- (let loop ((r rules) (revr '()) (<<EOF>>-action #f) (<<ERROR>>-action #f))
- (if (null? r)
- (cons (or <<EOF>>-action default-<<EOF>>-action)
- (cons (or <<ERROR>>-action default-<<ERROR>>-action)
- (list->vector (reverse revr))))
- (let ((r1 (car r)))
- (cond ((get-rule-eof? r1)
- (if <<EOF>>-action
- (lex-error (get-rule-line r1)
- #f
- "the <<EOF>> anchor can be "
- "used at most once.")
- (loop (cdr r)
- revr
- (get-rule-action r1)
- <<ERROR>>-action)))
- ((get-rule-error? r1)
- (if <<ERROR>>-action
- (lex-error (get-rule-line r1)
- #f
- "the <<ERROR>> anchor can be "
- "used at most once.")
- (loop (cdr r)
- revr
- <<EOF>>-action
- (get-rule-action r1))))
- (else
- (loop (cdr r)
- (cons r1 revr)
- <<EOF>>-action
- <<ERROR>>-action))))))))
-
-
-
-
-;
-; Analyseur de fichier lex
-;
-
-(define parse-hv-blanks
- (lambda ()
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok)))
- (if (or (= tok-type hblank-tok)
- (= tok-type vblank-tok))
- (parse-hv-blanks)
- (lexer-unget tok)))))
-
-(define parse-class-range
- (lambda ()
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok)))
- (cond ((= tok-type char-tok)
- (let* ((c (get-tok-attr tok))
- (tok2 (lexer))
- (tok2-type (get-tok-type tok2)))
- (if (not (= tok2-type minus-tok))
- (begin
- (lexer-unget tok2)
- (cons c c))
- (let* ((tok3 (lexer))
- (tok3-type (get-tok-type tok3)))
- (cond ((= tok3-type char-tok)
- (let ((c2 (get-tok-attr tok3)))
- (if (> c c2)
- (lex-error (get-tok-line tok3)
- (get-tok-column tok3)
- "bad range specification in "
- "character class;"
- #\newline
- "the start character is "
- "higher than the end one.")
- (cons c c2))))
- ((or (= tok3-type rbrack-tok)
- (= tok3-type minus-tok))
- (lex-error (get-tok-line tok3)
- (get-tok-column tok3)
- "bad range specification in "
- "character class; a specification"
- #\newline
- "like \"-x\", \"x--\" or \"x-]\" has "
- "been used."))
- ((= tok3-type eof-tok)
- (lex-error (get-tok-line tok3)
- #f
- "eof of file found while parsing "
- "a character class.")))))))
- ((= tok-type minus-tok)
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "bad range specification in character class; a "
- "specification"
- #\newline
- "like \"-x\", \"x--\" or \"x-]\" has been used."))
- ((= tok-type rbrack-tok)
- #f)
- ((= tok-type eof-tok)
- (lex-error (get-tok-line tok)
- #f
- "eof of file found while parsing "
- "a character class."))))))
-
-(define parse-class
- (lambda (initial-class negative-class? line column)
- (push-lexer 'class)
- (let loop ((class initial-class))
- (let ((new-range (parse-class-range)))
- (if new-range
- (loop (class-union (list new-range) class))
- (let ((class (if negative-class?
- (class-compl class)
- class)))
- (pop-lexer)
- (make-tok class-tok "" line column class)))))))
-
-(define parse-string
- (lambda (line column)
- (push-lexer 'string)
- (let ((char-list (let loop ()
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok)))
- (cond ((= tok-type char-tok)
- (cons (get-tok-attr tok) (loop)))
- ((= tok-type doublequote-tok)
- (pop-lexer)
- '())
- (else ; eof-tok
- (lex-error (get-tok-line tok)
- #f
- "end of file found while "
- "parsing a string.")))))))
- (make-tok string-tok "" line column char-list))))
-
-(define parse-regexp
- (let* ((end-action
- (lambda (tok loop)
- (lexer-unget tok)
- (pop-lexer)
- (lexer-set-blank-history #f)
- `()))
- (action-table
- (make-dispatch-table
- number-of-tokens
- (list (cons eof-tok end-action)
- (cons hblank-tok end-action)
- (cons vblank-tok end-action)
- (cons lbrack-tok
- (lambda (tok loop)
- (let ((tok1 (parse-class (list)
- #f
- (get-tok-line tok)
- (get-tok-column tok))))
- (cons tok1 (loop)))))
- (cons lbrack-rbrack-tok
- (lambda (tok loop)
- (let ((tok1 (parse-class
- (list (cons rbrack-ch rbrack-ch))
- #f
- (get-tok-line tok)
- (get-tok-column tok))))
- (cons tok1 (loop)))))
- (cons lbrack-caret-tok
- (lambda (tok loop)
- (let ((tok1 (parse-class (list)
- #t
- (get-tok-line tok)
- (get-tok-column tok))))
- (cons tok1 (loop)))))
- (cons lbrack-minus-tok
- (lambda (tok loop)
- (let ((tok1 (parse-class
- (list (cons minus-ch minus-ch))
- #f
- (get-tok-line tok)
- (get-tok-column tok))))
- (cons tok1 (loop)))))
- (cons doublequote-tok
- (lambda (tok loop)
- (let ((tok1 (parse-string (get-tok-line tok)
- (get-tok-column tok))))
- (cons tok1 (loop)))))
- (cons illegal-tok
- (lambda (tok loop)
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "syntax error in macro reference."))))
- (lambda (tok loop)
- (cons tok (loop))))))
- (lambda ()
- (push-lexer 'regexp)
- (lexer-set-blank-history #t)
- (parse-hv-blanks)
- (let loop ()
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok))
- (action (vector-ref action-table tok-type)))
- (action tok loop))))))
-
-(define parse-ws1-regexp ; Exige un blanc entre le nom et la RE d'une macro
- (lambda ()
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok)))
- (cond ((or (= tok-type hblank-tok) (= tok-type vblank-tok))
- (parse-regexp))
- (else ; percent-percent-tok, id-tok ou illegal-tok
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "white space expected."))))))
-
-(define parse-macro
- (lambda (macros)
- (push-lexer 'macro)
- (parse-hv-blanks)
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok)))
- (cond ((= tok-type id-tok)
- (let* ((name (get-tok-attr tok))
- (ass (assoc name macros)))
- (if ass
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "the macro \""
- (get-tok-2nd-attr tok)
- "\" has already been defined.")
- (let* ((tok-list (parse-ws1-regexp))
- (regexp (tokens->regexp tok-list macros)))
- (pop-lexer)
- (cons name regexp)))))
- ((= tok-type percent-percent-tok)
- (pop-lexer)
- #f)
- ((= tok-type illegal-tok)
- (lex-error (get-tok-line tok)
- (get-tok-column tok)
- "macro name expected."))
- ((= tok-type eof-tok)
- (lex-error (get-tok-line tok)
- #f
- "end of file found before %%."))))))
-
-(define parse-macros
- (lambda ()
- (let loop ((macros '()))
- (let ((macro (parse-macro macros)))
- (if macro
- (loop (cons macro macros))
- macros)))))
-
-(define parse-action-end
- (lambda (<<EOF>>-action? <<ERROR>>-action? action?)
- (let ((act (lexer-get-history)))
- (cond (action?
- act)
- (<<EOF>>-action?
- (string-append act default-<<EOF>>-action))
- (<<ERROR>>-action?
- (string-append act default-<<ERROR>>-action))
- (else
- (string-append act default-action))))))
-
-(define parse-action
- (lambda (<<EOF>>-action? <<ERROR>>-action?)
- (push-lexer 'action)
- (let loop ((action? #f))
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok)))
- (cond ((= tok-type char-tok)
- (loop #t))
- ((= tok-type hblank-tok)
- (loop action?))
- ((= tok-type vblank-tok)
- (push-lexer 'regexp)
- (let* ((tok (lexer))
- (tok-type (get-tok-type tok))
- (bidon (lexer-unget tok)))
- (pop-lexer)
- (if (or (= tok-type hblank-tok)
- (= tok-type vblank-tok))
- (loop action?)
- (begin
- (pop-lexer)
- (parse-action-end <<EOF>>-action?
- <<ERROR>>-action?
- action?)))))
- (else ; eof-tok
- (lexer-unget tok)
- (pop-lexer)
- (parse-action-end <<EOF>>-action?
- <<ERROR>>-action?
- action?)))))))
-
-(define parse-rule
- (lambda (macros)
- (let ((tok-list (parse-regexp)))
- (if (null? tok-list)
- #f
- (let* ((rule (tokens->rule tok-list macros))
- (action
- (parse-action (get-rule-eof? rule) (get-rule-error? rule))))
- (set-rule-action rule action)
- rule)))))
-
-(define parse-rules
- (lambda (macros)
- (parse-action #f #f)
- (let loop ()
- (let ((rule (parse-rule macros)))
- (if rule
- (cons rule (loop))
- '())))))
-
-(define parser
- (lambda (filename)
- (let* ((port (open-input-file filename))
- (port-open? #t))
- (lex-unwind-protect (lambda ()
- (if port-open?
- (close-input-port port))))
- (init-lexer port)
- (let* ((macros (parse-macros))
- (rules (parse-rules macros)))
- (close-input-port port)
- (set! port-open? #f)
- (adapt-rules rules)))))
-
-; Module re2nfa.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-; Le vecteur d'etats contient la table de transition du nfa.
-; Chaque entree contient les arcs partant de l'etat correspondant.
-; Les arcs sont stockes dans une liste.
-; Chaque arc est une paire (class . destination).
-; Les caracteres d'une classe sont enumeres par ranges.
-; Les ranges sont donnes dans une liste,
-; chaque element etant une paire (debut . fin).
-; Le symbole eps peut remplacer une classe.
-; L'acceptation est decrite par une paire (acc-if-eol . acc-if-no-eol).
-
-; Quelques variables globales
-(define r2n-counter 0)
-(define r2n-v-arcs '#(#f))
-(define r2n-v-acc '#(#f))
-(define r2n-v-len 1)
-
-; Initialisation des variables globales
-(define r2n-init
- (lambda ()
- (set! r2n-counter 0)
- (set! r2n-v-arcs (vector '()))
- (set! r2n-v-acc (vector #f))
- (set! r2n-v-len 1)))
-
-; Agrandissement des vecteurs
-(define r2n-extend-v
- (lambda ()
- (let* ((new-len (* 2 r2n-v-len))
- (new-v-arcs (make-vector new-len '()))
- (new-v-acc (make-vector new-len #f)))
- (let loop ((i 0))
- (if (< i r2n-v-len)
- (begin
- (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
- (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
- (loop (+ i 1)))))
- (set! r2n-v-arcs new-v-arcs)
- (set! r2n-v-acc new-v-acc)
- (set! r2n-v-len new-len))))
-
-; Finalisation des vecteurs
-(define r2n-finalize-v
- (lambda ()
- (let* ((new-v-arcs (make-vector r2n-counter))
- (new-v-acc (make-vector r2n-counter)))
- (let loop ((i 0))
- (if (< i r2n-counter)
- (begin
- (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
- (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
- (loop (+ i 1)))))
- (set! r2n-v-arcs new-v-arcs)
- (set! r2n-v-acc new-v-acc)
- (set! r2n-v-len r2n-counter))))
-
-; Creation d'etat
-(define r2n-get-state
- (lambda (acc)
- (if (= r2n-counter r2n-v-len)
- (r2n-extend-v))
- (let ((state r2n-counter))
- (set! r2n-counter (+ r2n-counter 1))
- (vector-set! r2n-v-acc state (or acc (cons #f #f)))
- state)))
-
-; Ajout d'un arc
-(define r2n-add-arc
- (lambda (start chars end)
- (vector-set! r2n-v-arcs
- start
- (cons (cons chars end) (vector-ref r2n-v-arcs start)))))
-
-; Construction de l'automate a partir des regexp
-(define r2n-build-epsilon
- (lambda (re start end)
- (r2n-add-arc start 'eps end)))
-
-(define r2n-build-or
- (lambda (re start end)
- (let ((re1 (get-re-attr1 re))
- (re2 (get-re-attr2 re)))
- (r2n-build-re re1 start end)
- (r2n-build-re re2 start end))))
-
-(define r2n-build-conc
- (lambda (re start end)
- (let* ((re1 (get-re-attr1 re))
- (re2 (get-re-attr2 re))
- (inter (r2n-get-state #f)))
- (r2n-build-re re1 start inter)
- (r2n-build-re re2 inter end))))
-
-(define r2n-build-star
- (lambda (re start end)
- (let* ((re1 (get-re-attr1 re))
- (inter1 (r2n-get-state #f))
- (inter2 (r2n-get-state #f)))
- (r2n-add-arc start 'eps inter1)
- (r2n-add-arc inter1 'eps inter2)
- (r2n-add-arc inter2 'eps end)
- (r2n-build-re re1 inter2 inter1))))
-
-(define r2n-build-plus
- (lambda (re start end)
- (let* ((re1 (get-re-attr1 re))
- (inter1 (r2n-get-state #f))
- (inter2 (r2n-get-state #f)))
- (r2n-add-arc start 'eps inter1)
- (r2n-add-arc inter2 'eps inter1)
- (r2n-add-arc inter2 'eps end)
- (r2n-build-re re1 inter1 inter2))))
-
-(define r2n-build-question
- (lambda (re start end)
- (let ((re1 (get-re-attr1 re)))
- (r2n-add-arc start 'eps end)
- (r2n-build-re re1 start end))))
-
-(define r2n-build-class
- (lambda (re start end)
- (let ((class (get-re-attr1 re)))
- (r2n-add-arc start class end))))
-
-(define r2n-build-char
- (lambda (re start end)
- (let* ((c (get-re-attr1 re))
- (class (list (cons c c))))
- (r2n-add-arc start class end))))
-
-(define r2n-build-re
- (let ((sub-function-v (vector r2n-build-epsilon
- r2n-build-or
- r2n-build-conc
- r2n-build-star
- r2n-build-plus
- r2n-build-question
- r2n-build-class
- r2n-build-char)))
- (lambda (re start end)
- (let* ((re-type (get-re-type re))
- (sub-f (vector-ref sub-function-v re-type)))
- (sub-f re start end)))))
-
-; Construction de l'automate relatif a une regle
-(define r2n-build-rule
- (lambda (rule ruleno nl-start no-nl-start)
- (let* ((re (get-rule-regexp rule))
- (bol? (get-rule-bol? rule))
- (eol? (get-rule-eol? rule))
- (rule-start (r2n-get-state #f))
- (rule-end (r2n-get-state (if eol?
- (cons ruleno #f)
- (cons ruleno ruleno)))))
- (r2n-build-re re rule-start rule-end)
- (r2n-add-arc nl-start 'eps rule-start)
- (if (not bol?)
- (r2n-add-arc no-nl-start 'eps rule-start)))))
-
-; Construction de l'automate complet
-(define re2nfa
- (lambda (rules)
- (let ((nb-of-rules (vector-length rules)))
- (r2n-init)
- (let* ((nl-start (r2n-get-state #f))
- (no-nl-start (r2n-get-state #f)))
- (let loop ((i 0))
- (if (< i nb-of-rules)
- (begin
- (r2n-build-rule (vector-ref rules i)
- i
- nl-start
- no-nl-start)
- (loop (+ i 1)))))
- (r2n-finalize-v)
- (let ((v-arcs r2n-v-arcs)
- (v-acc r2n-v-acc))
- (r2n-init)
- (list nl-start no-nl-start v-arcs v-acc))))))
-
-; Module noeps.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-; Fonction "merge" qui elimine les repetitions
-(define noeps-merge-1
- (lambda (l1 l2)
- (cond ((null? l1)
- l2)
- ((null? l2)
- l1)
- (else
- (let ((t1 (car l1))
- (t2 (car l2)))
- (cond ((< t1 t2)
- (cons t1 (noeps-merge-1 (cdr l1) l2)))
- ((= t1 t2)
- (cons t1 (noeps-merge-1 (cdr l1) (cdr l2))))
- (else
- (cons t2 (noeps-merge-1 l1 (cdr l2))))))))))
-
-; Fabrication des voisinages externes
-(define noeps-mkvois
- (lambda (trans-v)
- (let* ((nbnodes (vector-length trans-v))
- (arcs (make-vector nbnodes '())))
- (let loop1 ((n 0))
- (if (< n nbnodes)
- (begin
- (let loop2 ((trans (vector-ref trans-v n)) (ends '()))
- (if (null? trans)
- (vector-set! arcs n ends)
- (let* ((tran (car trans))
- (class (car tran))
- (end (cdr tran)))
- (loop2 (cdr trans) (if (eq? class 'eps)
- (noeps-merge-1 ends (list end))
- ends)))))
- (loop1 (+ n 1)))))
- arcs)))
-
-; Fabrication des valeurs initiales
-(define noeps-mkinit
- (lambda (trans-v)
- (let* ((nbnodes (vector-length trans-v))
- (init (make-vector nbnodes)))
- (let loop ((n 0))
- (if (< n nbnodes)
- (begin
- (vector-set! init n (list n))
- (loop (+ n 1)))))
- init)))
-
-; Traduction d'une liste d'arcs
-(define noeps-trad-arcs
- (lambda (trans dict)
- (let loop ((trans trans))
- (if (null? trans)
- '()
- (let* ((tran (car trans))
- (class (car tran))
- (end (cdr tran)))
- (if (eq? class 'eps)
- (loop (cdr trans))
- (let* ((new-end (vector-ref dict end))
- (new-tran (cons class new-end)))
- (cons new-tran (loop (cdr trans))))))))))
-
-; Elimination des transitions eps
-(define noeps
- (lambda (nl-start no-nl-start arcs acc)
- (let* ((digraph-arcs (noeps-mkvois arcs))
- (digraph-init (noeps-mkinit arcs))
- (dict (digraph digraph-arcs digraph-init noeps-merge-1))
- (new-nl-start (vector-ref dict nl-start))
- (new-no-nl-start (vector-ref dict no-nl-start)))
- (let loop ((i (- (vector-length arcs) 1)))
- (if (>= i 0)
- (begin
- (vector-set! arcs i (noeps-trad-arcs (vector-ref arcs i) dict))
- (loop (- i 1)))))
- (list new-nl-start new-no-nl-start arcs acc))))
-
-; Module sweep.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-; Preparer les arcs pour digraph
-(define sweep-mkarcs
- (lambda (trans-v)
- (let* ((nbnodes (vector-length trans-v))
- (arcs-v (make-vector nbnodes '())))
- (let loop1 ((n 0))
- (if (< n nbnodes)
- (let loop2 ((trans (vector-ref trans-v n)) (arcs '()))
- (if (null? trans)
- (begin
- (vector-set! arcs-v n arcs)
- (loop1 (+ n 1)))
- (loop2 (cdr trans) (noeps-merge-1 (cdar trans) arcs))))
- arcs-v)))))
-
-; Preparer l'operateur pour digraph
-(define sweep-op
- (let ((acc-min (lambda (rule1 rule2)
- (cond ((not rule1)
- rule2)
- ((not rule2)
- rule1)
- (else
- (min rule1 rule2))))))
- (lambda (acc1 acc2)
- (cons (acc-min (car acc1) (car acc2))
- (acc-min (cdr acc1) (cdr acc2))))))
-
-; Renumerotation des etats (#f pour etat a eliminer)
-; Retourne (new-nbnodes . dict)
-(define sweep-renum
- (lambda (dist-acc-v)
- (let* ((nbnodes (vector-length dist-acc-v))
- (dict (make-vector nbnodes)))
- (let loop ((n 0) (new-n 0))
- (if (< n nbnodes)
- (let* ((acc (vector-ref dist-acc-v n))
- (dead? (equal? acc '(#f . #f))))
- (if dead?
- (begin
- (vector-set! dict n #f)
- (loop (+ n 1) new-n))
- (begin
- (vector-set! dict n new-n)
- (loop (+ n 1) (+ new-n 1)))))
- (cons new-n dict))))))
-
-; Elimination des etats inutiles d'une liste d'etats
-(define sweep-list
- (lambda (ss dict)
- (if (null? ss)
- '()
- (let* ((olds (car ss))
- (news (vector-ref dict olds)))
- (if news
- (cons news (sweep-list (cdr ss) dict))
- (sweep-list (cdr ss) dict))))))
-
-; Elimination des etats inutiles d'une liste d'arcs
-(define sweep-arcs
- (lambda (arcs dict)
- (if (null? arcs)
- '()
- (let* ((arc (car arcs))
- (class (car arc))
- (ss (cdr arc))
- (new-ss (sweep-list ss dict)))
- (if (null? new-ss)
- (sweep-arcs (cdr arcs) dict)
- (cons (cons class new-ss) (sweep-arcs (cdr arcs) dict)))))))
-
-; Elimination des etats inutiles dans toutes les transitions
-(define sweep-all-arcs
- (lambda (arcs-v dict)
- (let loop ((n (- (vector-length arcs-v) 1)))
- (if (>= n 0)
- (begin
- (vector-set! arcs-v n (sweep-arcs (vector-ref arcs-v n) dict))
- (loop (- n 1)))
- arcs-v))))
-
-; Elimination des etats inutiles dans un vecteur
-(define sweep-states
- (lambda (v new-nbnodes dict)
- (let ((nbnodes (vector-length v))
- (new-v (make-vector new-nbnodes)))
- (let loop ((n 0))
- (if (< n nbnodes)
- (let ((new-n (vector-ref dict n)))
- (if new-n
- (vector-set! new-v new-n (vector-ref v n)))
- (loop (+ n 1)))
- new-v)))))
-
-; Elimination des etats inutiles
-(define sweep
- (lambda (nl-start no-nl-start arcs-v acc-v)
- (let* ((digraph-arcs (sweep-mkarcs arcs-v))
- (digraph-init acc-v)
- (digraph-op sweep-op)
- (dist-acc-v (digraph digraph-arcs digraph-init digraph-op))
- (result (sweep-renum dist-acc-v))
- (new-nbnodes (car result))
- (dict (cdr result))
- (new-nl-start (sweep-list nl-start dict))
- (new-no-nl-start (sweep-list no-nl-start dict))
- (new-arcs-v (sweep-states (sweep-all-arcs arcs-v dict)
- new-nbnodes
- dict))
- (new-acc-v (sweep-states acc-v new-nbnodes dict)))
- (list new-nl-start new-no-nl-start new-arcs-v new-acc-v))))
-
-; Module nfa2dfa.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-; Recoupement de deux arcs
-(define n2d-2arcs
- (lambda (arc1 arc2)
- (let* ((class1 (car arc1))
- (ss1 (cdr arc1))
- (class2 (car arc2))
- (ss2 (cdr arc2))
- (result (class-sep class1 class2))
- (classl (vector-ref result 0))
- (classc (vector-ref result 1))
- (classr (vector-ref result 2))
- (ssl ss1)
- (ssc (ss-union ss1 ss2))
- (ssr ss2))
- (vector (if (or (null? classl) (null? ssl)) #f (cons classl ssl))
- (if (or (null? classc) (null? ssc)) #f (cons classc ssc))
- (if (or (null? classr) (null? ssr)) #f (cons classr ssr))))))
-
-; Insertion d'un arc dans une liste d'arcs a classes distinctes
-(define n2d-insert-arc
- (lambda (new-arc arcs)
- (if (null? arcs)
- (list new-arc)
- (let* ((arc (car arcs))
- (others (cdr arcs))
- (result (n2d-2arcs new-arc arc))
- (arcl (vector-ref result 0))
- (arcc (vector-ref result 1))
- (arcr (vector-ref result 2))
- (list-arcc (if arcc (list arcc) '()))
- (list-arcr (if arcr (list arcr) '())))
- (if arcl
- (append list-arcc list-arcr (n2d-insert-arc arcl others))
- (append list-arcc list-arcr others))))))
-
-; Regroupement des arcs qui aboutissent au meme sous-ensemble d'etats
-(define n2d-factorize-arcs
- (lambda (arcs)
- (if (null? arcs)
- '()
- (let* ((arc (car arcs))
- (arc-ss (cdr arc))
- (others-no-fact (cdr arcs))
- (others (n2d-factorize-arcs others-no-fact)))
- (let loop ((o others))
- (if (null? o)
- (list arc)
- (let* ((o1 (car o))
- (o1-ss (cdr o1)))
- (if (equal? o1-ss arc-ss)
- (let* ((arc-class (car arc))
- (o1-class (car o1))
- (new-class (class-union arc-class o1-class))
- (new-arc (cons new-class arc-ss)))
- (cons new-arc (cdr o)))
- (cons o1 (loop (cdr o)))))))))))
-
-; Transformer une liste d'arcs quelconques en des arcs a classes distinctes
-(define n2d-distinguish-arcs
- (lambda (arcs)
- (let loop ((arcs arcs) (n-arcs '()))
- (if (null? arcs)
- n-arcs
- (loop (cdr arcs) (n2d-insert-arc (car arcs) n-arcs))))))
-
-; Transformer une liste d'arcs quelconques en des arcs a classes et a
-; destinations distinctes
-(define n2d-normalize-arcs
- (lambda (arcs)
- (n2d-factorize-arcs (n2d-distinguish-arcs arcs))))
-
-; Factoriser des arcs a destination unique (~deterministes)
-(define n2d-factorize-darcs
- (lambda (arcs)
- (if (null? arcs)
- '()
- (let* ((arc (car arcs))
- (arc-end (cdr arc))
- (other-arcs (cdr arcs))
- (farcs (n2d-factorize-darcs other-arcs)))
- (let loop ((farcs farcs))
- (if (null? farcs)
- (list arc)
- (let* ((farc (car farcs))
- (farc-end (cdr farc)))
- (if (= farc-end arc-end)
- (let* ((arc-class (car arc))
- (farc-class (car farc))
- (new-class (class-union farc-class arc-class))
- (new-arc (cons new-class arc-end)))
- (cons new-arc (cdr farcs)))
- (cons farc (loop (cdr farcs)))))))))))
-
-; Normaliser un vecteur de listes d'arcs
-(define n2d-normalize-arcs-v
- (lambda (arcs-v)
- (let* ((nbnodes (vector-length arcs-v))
- (new-v (make-vector nbnodes)))
- (let loop ((n 0))
- (if (= n nbnodes)
- new-v
- (begin
- (vector-set! new-v n (n2d-normalize-arcs (vector-ref arcs-v n)))
- (loop (+ n 1))))))))
-
-; Inserer un arc dans une liste d'arcs a classes distinctes en separant
-; les arcs contenant une partie de la classe du nouvel arc des autres arcs
-; Retourne: (oui . non)
-(define n2d-ins-sep-arc
- (lambda (new-arc arcs)
- (if (null? arcs)
- (cons (list new-arc) '())
- (let* ((arc (car arcs))
- (others (cdr arcs))
- (result (n2d-2arcs new-arc arc))
- (arcl (vector-ref result 0))
- (arcc (vector-ref result 1))
- (arcr (vector-ref result 2))
- (l-arcc (if arcc (list arcc) '()))
- (l-arcr (if arcr (list arcr) '()))
- (result (if arcl
- (n2d-ins-sep-arc arcl others)
- (cons '() others)))
- (oui-arcs (car result))
- (non-arcs (cdr result)))
- (cons (append l-arcc oui-arcs) (append l-arcr non-arcs))))))
-
-; Combiner deux listes d'arcs a classes distinctes
-; Ne tente pas de combiner les arcs qui ont nec. des classes disjointes
-; Conjecture: les arcs crees ont leurs classes disjointes
-; Note: envisager de rajouter un "n2d-factorize-arcs" !!!!!!!!!!!!
-(define n2d-combine-arcs
- (lambda (arcs1 arcs2)
- (let loop ((arcs1 arcs1) (arcs2 arcs2) (dist-arcs2 '()))
- (if (null? arcs1)
- (append arcs2 dist-arcs2)
- (let* ((arc (car arcs1))
- (result (n2d-ins-sep-arc arc arcs2))
- (oui-arcs (car result))
- (non-arcs (cdr result)))
- (loop (cdr arcs1) non-arcs (append oui-arcs dist-arcs2)))))))
-
-; ;
-; ; Section temporaire: vieille facon de generer le dfa
-; ; Dictionnaire d'etat det. Recherche lineaire. Creation naive
-; ; des arcs d'un ensemble d'etats.
-; ;
-;
-; ; Quelques variables globales
-; (define n2d-state-dict '#(#f))
-; (define n2d-state-len 1)
-; (define n2d-state-count 0)
-;
-; ; Fonctions de gestion des entrees du dictionnaire
-; (define make-dentry (lambda (ss) (vector ss #f #f)))
-;
-; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
-; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
-; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
-;
-; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
-; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
-;
-; ; Initialisation des variables globales
-; (define n2d-init-glob-vars
-; (lambda ()
-; (set! n2d-state-dict (vector #f))
-; (set! n2d-state-len 1)
-; (set! n2d-state-count 0)))
-;
-; ; Extension du dictionnaire
-; (define n2d-extend-dict
-; (lambda ()
-; (let* ((new-len (* 2 n2d-state-len))
-; (v (make-vector new-len #f)))
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (begin
-; (set! n2d-state-dict v)
-; (set! n2d-state-len new-len))
-; (begin
-; (vector-set! v n (vector-ref n2d-state-dict n))
-; (loop (+ n 1))))))))
-;
-; ; Ajout d'un etat
-; (define n2d-add-state
-; (lambda (ss)
-; (let* ((s n2d-state-count)
-; (dentry (make-dentry ss)))
-; (if (= n2d-state-count n2d-state-len)
-; (n2d-extend-dict))
-; (vector-set! n2d-state-dict s dentry)
-; (set! n2d-state-count (+ n2d-state-count 1))
-; s)))
-;
-; ; Recherche d'un etat
-; (define n2d-search-state
-; (lambda (ss)
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (n2d-add-state ss)
-; (let* ((dentry (vector-ref n2d-state-dict n))
-; (dentry-ss (get-dentry-ss dentry)))
-; (if (equal? dentry-ss ss)
-; n
-; (loop (+ n 1))))))))
-;
-; ; Transformer un arc non-det. en un arc det.
-; (define n2d-translate-arc
-; (lambda (arc)
-; (let* ((class (car arc))
-; (ss (cdr arc))
-; (s (n2d-search-state ss)))
-; (cons class s))))
-;
-; ; Transformer une liste d'arcs non-det. en ...
-; (define n2d-translate-arcs
-; (lambda (arcs)
-; (map n2d-translate-arc arcs)))
-;
-; ; Trouver le minimum de deux acceptants
-; (define n2d-acc-min2
-; (let ((acc-min (lambda (rule1 rule2)
-; (cond ((not rule1)
-; rule2)
-; ((not rule2)
-; rule1)
-; (else
-; (min rule1 rule2))))))
-; (lambda (acc1 acc2)
-; (cons (acc-min (car acc1) (car acc2))
-; (acc-min (cdr acc1) (cdr acc2))))))
-;
-; ; Trouver le minimum de plusieurs acceptants
-; (define n2d-acc-mins
-; (lambda (accs)
-; (if (null? accs)
-; (cons #f #f)
-; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
-;
-; ; Fabriquer les vecteurs d'arcs et d'acceptance
-; (define n2d-extract-vs
-; (lambda ()
-; (let* ((arcs-v (make-vector n2d-state-count))
-; (acc-v (make-vector n2d-state-count)))
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (cons arcs-v acc-v)
-; (begin
-; (vector-set! arcs-v n (get-dentry-darcs
-; (vector-ref n2d-state-dict n)))
-; (vector-set! acc-v n (get-dentry-acc
-; (vector-ref n2d-state-dict n)))
-; (loop (+ n 1))))))))
-;
-; ; Effectuer la transformation de l'automate de non-det. a det.
-; (define nfa2dfa
-; (lambda (nl-start no-nl-start arcs-v acc-v)
-; (n2d-init-glob-vars)
-; (let* ((nl-d (n2d-search-state nl-start))
-; (no-nl-d (n2d-search-state no-nl-start)))
-; (let loop ((n 0))
-; (if (< n n2d-state-count)
-; (let* ((dentry (vector-ref n2d-state-dict n))
-; (ss (get-dentry-ss dentry))
-; (arcss (map (lambda (s) (vector-ref arcs-v s)) ss))
-; (arcs (apply append arcss))
-; (dist-arcs (n2d-distinguish-arcs arcs))
-; (darcs (n2d-translate-arcs dist-arcs))
-; (fact-darcs (n2d-factorize-darcs darcs))
-; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
-; (acc (n2d-acc-mins accs)))
-; (set-dentry-darcs dentry fact-darcs)
-; (set-dentry-acc dentry acc)
-; (loop (+ n 1)))))
-; (let* ((result (n2d-extract-vs))
-; (new-arcs-v (car result))
-; (new-acc-v (cdr result)))
-; (n2d-init-glob-vars)
-; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
-
-; ;
-; ; Section temporaire: vieille facon de generer le dfa
-; ; Dictionnaire d'etat det. Recherche lineaire. Creation des
-; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
-; ; classes distinctes.
-; ;
-;
-; ; Quelques variables globales
-; (define n2d-state-dict '#(#f))
-; (define n2d-state-len 1)
-; (define n2d-state-count 0)
-;
-; ; Fonctions de gestion des entrees du dictionnaire
-; (define make-dentry (lambda (ss) (vector ss #f #f)))
-;
-; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
-; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
-; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
-;
-; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
-; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
-;
-; ; Initialisation des variables globales
-; (define n2d-init-glob-vars
-; (lambda ()
-; (set! n2d-state-dict (vector #f))
-; (set! n2d-state-len 1)
-; (set! n2d-state-count 0)))
-;
-; ; Extension du dictionnaire
-; (define n2d-extend-dict
-; (lambda ()
-; (let* ((new-len (* 2 n2d-state-len))
-; (v (make-vector new-len #f)))
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (begin
-; (set! n2d-state-dict v)
-; (set! n2d-state-len new-len))
-; (begin
-; (vector-set! v n (vector-ref n2d-state-dict n))
-; (loop (+ n 1))))))))
-;
-; ; Ajout d'un etat
-; (define n2d-add-state
-; (lambda (ss)
-; (let* ((s n2d-state-count)
-; (dentry (make-dentry ss)))
-; (if (= n2d-state-count n2d-state-len)
-; (n2d-extend-dict))
-; (vector-set! n2d-state-dict s dentry)
-; (set! n2d-state-count (+ n2d-state-count 1))
-; s)))
-;
-; ; Recherche d'un etat
-; (define n2d-search-state
-; (lambda (ss)
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (n2d-add-state ss)
-; (let* ((dentry (vector-ref n2d-state-dict n))
-; (dentry-ss (get-dentry-ss dentry)))
-; (if (equal? dentry-ss ss)
-; n
-; (loop (+ n 1))))))))
-;
-; ; Combiner des listes d'arcs a classes dictinctes
-; (define n2d-combine-arcs-l
-; (lambda (arcs-l)
-; (if (null? arcs-l)
-; '()
-; (let* ((arcs (car arcs-l))
-; (other-arcs-l (cdr arcs-l))
-; (other-arcs (n2d-combine-arcs-l other-arcs-l)))
-; (n2d-combine-arcs arcs other-arcs)))))
-;
-; ; Transformer un arc non-det. en un arc det.
-; (define n2d-translate-arc
-; (lambda (arc)
-; (let* ((class (car arc))
-; (ss (cdr arc))
-; (s (n2d-search-state ss)))
-; (cons class s))))
-;
-; ; Transformer une liste d'arcs non-det. en ...
-; (define n2d-translate-arcs
-; (lambda (arcs)
-; (map n2d-translate-arc arcs)))
-;
-; ; Trouver le minimum de deux acceptants
-; (define n2d-acc-min2
-; (let ((acc-min (lambda (rule1 rule2)
-; (cond ((not rule1)
-; rule2)
-; ((not rule2)
-; rule1)
-; (else
-; (min rule1 rule2))))))
-; (lambda (acc1 acc2)
-; (cons (acc-min (car acc1) (car acc2))
-; (acc-min (cdr acc1) (cdr acc2))))))
-;
-; ; Trouver le minimum de plusieurs acceptants
-; (define n2d-acc-mins
-; (lambda (accs)
-; (if (null? accs)
-; (cons #f #f)
-; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
-;
-; ; Fabriquer les vecteurs d'arcs et d'acceptance
-; (define n2d-extract-vs
-; (lambda ()
-; (let* ((arcs-v (make-vector n2d-state-count))
-; (acc-v (make-vector n2d-state-count)))
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (cons arcs-v acc-v)
-; (begin
-; (vector-set! arcs-v n (get-dentry-darcs
-; (vector-ref n2d-state-dict n)))
-; (vector-set! acc-v n (get-dentry-acc
-; (vector-ref n2d-state-dict n)))
-; (loop (+ n 1))))))))
-;
-; ; Effectuer la transformation de l'automate de non-det. a det.
-; (define nfa2dfa
-; (lambda (nl-start no-nl-start arcs-v acc-v)
-; (n2d-init-glob-vars)
-; (let* ((nl-d (n2d-search-state nl-start))
-; (no-nl-d (n2d-search-state no-nl-start))
-; (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
-; (let loop ((n 0))
-; (if (< n n2d-state-count)
-; (let* ((dentry (vector-ref n2d-state-dict n))
-; (ss (get-dentry-ss dentry))
-; (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
-; (arcs (n2d-combine-arcs-l arcs-l))
-; (darcs (n2d-translate-arcs arcs))
-; (fact-darcs (n2d-factorize-darcs darcs))
-; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
-; (acc (n2d-acc-mins accs)))
-; (set-dentry-darcs dentry fact-darcs)
-; (set-dentry-acc dentry acc)
-; (loop (+ n 1)))))
-; (let* ((result (n2d-extract-vs))
-; (new-arcs-v (car result))
-; (new-acc-v (cdr result)))
-; (n2d-init-glob-vars)
-; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
-
-; ;
-; ; Section temporaire: vieille facon de generer le dfa
-; ; Dictionnaire d'etat det. Arbre de recherche. Creation des
-; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
-; ; classes distinctes.
-; ;
-;
-; ; Quelques variables globales
-; (define n2d-state-dict '#(#f))
-; (define n2d-state-len 1)
-; (define n2d-state-count 0)
-; (define n2d-state-tree '#(#f ()))
-;
-; ; Fonctions de gestion des entrees du dictionnaire
-; (define make-dentry (lambda (ss) (vector ss #f #f)))
-;
-; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
-; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
-; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
-;
-; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
-; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
-;
-; ; Fonctions de gestion de l'arbre de recherche
-; (define make-snode (lambda () (vector #f '())))
-;
-; (define get-snode-dstate (lambda (snode) (vector-ref snode 0)))
-; (define get-snode-children (lambda (snode) (vector-ref snode 1)))
-;
-; (define set-snode-dstate
-; (lambda (snode dstate) (vector-set! snode 0 dstate)))
-; (define set-snode-children
-; (lambda (snode children) (vector-set! snode 1 children)))
-;
-; ; Initialisation des variables globales
-; (define n2d-init-glob-vars
-; (lambda ()
-; (set! n2d-state-dict (vector #f))
-; (set! n2d-state-len 1)
-; (set! n2d-state-count 0)
-; (set! n2d-state-tree (make-snode))))
-;
-; ; Extension du dictionnaire
-; (define n2d-extend-dict
-; (lambda ()
-; (let* ((new-len (* 2 n2d-state-len))
-; (v (make-vector new-len #f)))
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (begin
-; (set! n2d-state-dict v)
-; (set! n2d-state-len new-len))
-; (begin
-; (vector-set! v n (vector-ref n2d-state-dict n))
-; (loop (+ n 1))))))))
-;
-; ; Ajout d'un etat
-; (define n2d-add-state
-; (lambda (ss)
-; (let* ((s n2d-state-count)
-; (dentry (make-dentry ss)))
-; (if (= n2d-state-count n2d-state-len)
-; (n2d-extend-dict))
-; (vector-set! n2d-state-dict s dentry)
-; (set! n2d-state-count (+ n2d-state-count 1))
-; s)))
-;
-; ; Recherche d'un etat
-; (define n2d-search-state
-; (lambda (ss)
-; (let loop ((s-l ss) (snode n2d-state-tree))
-; (if (null? s-l)
-; (or (get-snode-dstate snode)
-; (let ((s (n2d-add-state ss)))
-; (set-snode-dstate snode s)
-; s))
-; (let* ((next-s (car s-l))
-; (alist (get-snode-children snode))
-; (ass (or (assv next-s alist)
-; (let ((ass (cons next-s (make-snode))))
-; (set-snode-children snode (cons ass alist))
-; ass))))
-; (loop (cdr s-l) (cdr ass)))))))
-;
-; ; Combiner des listes d'arcs a classes dictinctes
-; (define n2d-combine-arcs-l
-; (lambda (arcs-l)
-; (if (null? arcs-l)
-; '()
-; (let* ((arcs (car arcs-l))
-; (other-arcs-l (cdr arcs-l))
-; (other-arcs (n2d-combine-arcs-l other-arcs-l)))
-; (n2d-combine-arcs arcs other-arcs)))))
-;
-; ; Transformer un arc non-det. en un arc det.
-; (define n2d-translate-arc
-; (lambda (arc)
-; (let* ((class (car arc))
-; (ss (cdr arc))
-; (s (n2d-search-state ss)))
-; (cons class s))))
-;
-; ; Transformer une liste d'arcs non-det. en ...
-; (define n2d-translate-arcs
-; (lambda (arcs)
-; (map n2d-translate-arc arcs)))
-;
-; ; Trouver le minimum de deux acceptants
-; (define n2d-acc-min2
-; (let ((acc-min (lambda (rule1 rule2)
-; (cond ((not rule1)
-; rule2)
-; ((not rule2)
-; rule1)
-; (else
-; (min rule1 rule2))))))
-; (lambda (acc1 acc2)
-; (cons (acc-min (car acc1) (car acc2))
-; (acc-min (cdr acc1) (cdr acc2))))))
-;
-; ; Trouver le minimum de plusieurs acceptants
-; (define n2d-acc-mins
-; (lambda (accs)
-; (if (null? accs)
-; (cons #f #f)
-; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
-;
-; ; Fabriquer les vecteurs d'arcs et d'acceptance
-; (define n2d-extract-vs
-; (lambda ()
-; (let* ((arcs-v (make-vector n2d-state-count))
-; (acc-v (make-vector n2d-state-count)))
-; (let loop ((n 0))
-; (if (= n n2d-state-count)
-; (cons arcs-v acc-v)
-; (begin
-; (vector-set! arcs-v n (get-dentry-darcs
-; (vector-ref n2d-state-dict n)))
-; (vector-set! acc-v n (get-dentry-acc
-; (vector-ref n2d-state-dict n)))
-; (loop (+ n 1))))))))
-;
-; ; Effectuer la transformation de l'automate de non-det. a det.
-; (define nfa2dfa
-; (lambda (nl-start no-nl-start arcs-v acc-v)
-; (n2d-init-glob-vars)
-; (let* ((nl-d (n2d-search-state nl-start))
-; (no-nl-d (n2d-search-state no-nl-start))
-; (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
-; (let loop ((n 0))
-; (if (< n n2d-state-count)
-; (let* ((dentry (vector-ref n2d-state-dict n))
-; (ss (get-dentry-ss dentry))
-; (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
-; (arcs (n2d-combine-arcs-l arcs-l))
-; (darcs (n2d-translate-arcs arcs))
-; (fact-darcs (n2d-factorize-darcs darcs))
-; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
-; (acc (n2d-acc-mins accs)))
-; (set-dentry-darcs dentry fact-darcs)
-; (set-dentry-acc dentry acc)
-; (loop (+ n 1)))))
-; (let* ((result (n2d-extract-vs))
-; (new-arcs-v (car result))
-; (new-acc-v (cdr result)))
-; (n2d-init-glob-vars)
-; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
-
-;
-; Section temporaire: vieille facon de generer le dfa
-; Dictionnaire d'etat det. Table de hashage. Creation des
-; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
-; classes distinctes.
-;
-
-; Quelques variables globales
-(define n2d-state-dict '#(#f))
-(define n2d-state-len 1)
-(define n2d-state-count 0)
-(define n2d-state-hash '#())
-
-; Fonctions de gestion des entrees du dictionnaire
-(define make-dentry (lambda (ss) (vector ss #f #f)))
-
-(define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
-(define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
-(define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
-
-(define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
-(define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
-
-; Initialisation des variables globales
-(define n2d-init-glob-vars
- (lambda (hash-len)
- (set! n2d-state-dict (vector #f))
- (set! n2d-state-len 1)
- (set! n2d-state-count 0)
- (set! n2d-state-hash (make-vector hash-len '()))))
-
-; Extension du dictionnaire
-(define n2d-extend-dict
- (lambda ()
- (let* ((new-len (* 2 n2d-state-len))
- (v (make-vector new-len #f)))
- (let loop ((n 0))
- (if (= n n2d-state-count)
- (begin
- (set! n2d-state-dict v)
- (set! n2d-state-len new-len))
- (begin
- (vector-set! v n (vector-ref n2d-state-dict n))
- (loop (+ n 1))))))))
-
-; Ajout d'un etat
-(define n2d-add-state
- (lambda (ss)
- (let* ((s n2d-state-count)
- (dentry (make-dentry ss)))
- (if (= n2d-state-count n2d-state-len)
- (n2d-extend-dict))
- (vector-set! n2d-state-dict s dentry)
- (set! n2d-state-count (+ n2d-state-count 1))
- s)))
-
-; Recherche d'un etat
-(define n2d-search-state
- (lambda (ss)
- (let* ((hash-no (if (null? ss) 0 (car ss)))
- (alist (vector-ref n2d-state-hash hash-no))
- (ass (assoc ss alist)))
- (if ass
- (cdr ass)
- (let* ((s (n2d-add-state ss))
- (new-ass (cons ss s)))
- (vector-set! n2d-state-hash hash-no (cons new-ass alist))
- s)))))
-
-; Combiner des listes d'arcs a classes dictinctes
-(define n2d-combine-arcs-l
- (lambda (arcs-l)
- (if (null? arcs-l)
- '()
- (let* ((arcs (car arcs-l))
- (other-arcs-l (cdr arcs-l))
- (other-arcs (n2d-combine-arcs-l other-arcs-l)))
- (n2d-combine-arcs arcs other-arcs)))))
-
-; Transformer un arc non-det. en un arc det.
-(define n2d-translate-arc
- (lambda (arc)
- (let* ((class (car arc))
- (ss (cdr arc))
- (s (n2d-search-state ss)))
- (cons class s))))
-
-; Transformer une liste d'arcs non-det. en ...
-(define n2d-translate-arcs
- (lambda (arcs)
- (map n2d-translate-arc arcs)))
-
-; Trouver le minimum de deux acceptants
-(define n2d-acc-min2
- (let ((acc-min (lambda (rule1 rule2)
- (cond ((not rule1)
- rule2)
- ((not rule2)
- rule1)
- (else
- (min rule1 rule2))))))
- (lambda (acc1 acc2)
- (cons (acc-min (car acc1) (car acc2))
- (acc-min (cdr acc1) (cdr acc2))))))
-
-; Trouver le minimum de plusieurs acceptants
-(define n2d-acc-mins
- (lambda (accs)
- (if (null? accs)
- (cons #f #f)
- (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
-
-; Fabriquer les vecteurs d'arcs et d'acceptance
-(define n2d-extract-vs
- (lambda ()
- (let* ((arcs-v (make-vector n2d-state-count))
- (acc-v (make-vector n2d-state-count)))
- (let loop ((n 0))
- (if (= n n2d-state-count)
- (cons arcs-v acc-v)
- (begin
- (vector-set! arcs-v n (get-dentry-darcs
- (vector-ref n2d-state-dict n)))
- (vector-set! acc-v n (get-dentry-acc
- (vector-ref n2d-state-dict n)))
- (loop (+ n 1))))))))
-
-; Effectuer la transformation de l'automate de non-det. a det.
-(define nfa2dfa
- (lambda (nl-start no-nl-start arcs-v acc-v)
- (n2d-init-glob-vars (vector-length arcs-v))
- (let* ((nl-d (n2d-search-state nl-start))
- (no-nl-d (n2d-search-state no-nl-start))
- (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
- (let loop ((n 0))
- (if (< n n2d-state-count)
- (let* ((dentry (vector-ref n2d-state-dict n))
- (ss (get-dentry-ss dentry))
- (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
- (arcs (n2d-combine-arcs-l arcs-l))
- (darcs (n2d-translate-arcs arcs))
- (fact-darcs (n2d-factorize-darcs darcs))
- (accs (map (lambda (s) (vector-ref acc-v s)) ss))
- (acc (n2d-acc-mins accs)))
- (set-dentry-darcs dentry fact-darcs)
- (set-dentry-acc dentry acc)
- (loop (+ n 1)))))
- (let* ((result (n2d-extract-vs))
- (new-arcs-v (car result))
- (new-acc-v (cdr result)))
- (n2d-init-glob-vars 0)
- (list nl-d no-nl-d new-arcs-v new-acc-v)))))
-
-; Module prep.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Divers pre-traitements avant l'ecriture des tables
-;
-
-; Passe d'un arc multi-range a une liste d'arcs mono-range
-(define prep-arc->sharcs
- (lambda (arc)
- (let* ((range-l (car arc))
- (dest (cdr arc))
- (op (lambda (range) (cons range dest))))
- (map op range-l))))
-
-; Compare des arcs courts selon leur premier caractere
-(define prep-sharc-<=
- (lambda (sharc1 sharc2)
- (class-<= (caar sharc1) (caar sharc2))))
-
-; Remplit les trous parmi les sharcs avec des arcs "erreur"
-(define prep-fill-error
- (lambda (sharcs)
- (let loop ((sharcs sharcs) (start 'inf-))
- (cond ((class-= start 'inf+)
- '())
- ((null? sharcs)
- (cons (cons (cons start 'inf+) 'err) (loop sharcs 'inf+)))
- (else
- (let* ((sharc (car sharcs))
- (h (caar sharc))
- (t (cdar sharc)))
- (if (class-< start h)
- (cons (cons (cons start (- h 1)) 'err) (loop sharcs h))
- (cons sharc (loop (cdr sharcs)
- (if (class-= t 'inf+)
- 'inf+
- (+ t 1)))))))))))
-
-; ; Passe d'une liste d'arcs a un arbre de decision
-; ; 1ere methode: seulement des comparaisons <
-; (define prep-arcs->tree
-; (lambda (arcs)
-; (let* ((sharcs-l (map prep-arc->sharcs arcs))
-; (sharcs (apply append sharcs-l))
-; (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
-; (sorted (prep-fill-error sorted-with-holes))
-; (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
-; (table (list->vector (map op sorted))))
-; (let loop ((left 0) (right (- (vector-length table) 1)))
-; (if (= left right)
-; (cdr (vector-ref table left))
-; (let ((mid (quotient (+ left right 1) 2)))
-; (list (car (vector-ref table mid))
-; (loop left (- mid 1))
-; (loop mid right))))))))
-
-; Passe d'une liste d'arcs a un arbre de decision
-; 2eme methode: permettre des comparaisons = quand ca adonne
-(define prep-arcs->tree
- (lambda (arcs)
- (let* ((sharcs-l (map prep-arc->sharcs arcs))
- (sharcs (apply append sharcs-l))
- (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
- (sorted (prep-fill-error sorted-with-holes))
- (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
- (table (list->vector (map op sorted))))
- (let loop ((left 0) (right (- (vector-length table) 1)))
- (if (= left right)
- (cdr (vector-ref table left))
- (let ((mid (quotient (+ left right 1) 2)))
- (if (and (= (+ left 2) right)
- (= (+ (car (vector-ref table mid)) 1)
- (car (vector-ref table right)))
- (eqv? (cdr (vector-ref table left))
- (cdr (vector-ref table right))))
- (list '=
- (car (vector-ref table mid))
- (cdr (vector-ref table mid))
- (cdr (vector-ref table left)))
- (list (car (vector-ref table mid))
- (loop left (- mid 1))
- (loop mid right)))))))))
-
-; Determine si une action a besoin de calculer yytext
-(define prep-detect-yytext
- (lambda (s)
- (let loop1 ((i (- (string-length s) 6)))
- (cond ((< i 0)
- #f)
- ((char-ci=? (string-ref s i) #\y)
- (let loop2 ((j 5))
- (cond ((= j 0)
- #t)
- ((char-ci=? (string-ref s (+ i j))
- (string-ref "yytext" j))
- (loop2 (- j 1)))
- (else
- (loop1 (- i 1))))))
- (else
- (loop1 (- i 1)))))))
-
-; Note dans une regle si son action a besoin de yytext
-(define prep-set-rule-yytext?
- (lambda (rule)
- (let ((action (get-rule-action rule)))
- (set-rule-yytext? rule (prep-detect-yytext action)))))
-
-; Note dans toutes les regles si leurs actions ont besoin de yytext
-(define prep-set-rules-yytext?
- (lambda (rules)
- (let loop ((n (- (vector-length rules) 1)))
- (if (>= n 0)
- (begin
- (prep-set-rule-yytext? (vector-ref rules n))
- (loop (- n 1)))))))
-
-; Module output.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Nettoie les actions en enlevant les lignes blanches avant et apres
-;
-
-(define out-split-in-lines
- (lambda (s)
- (let ((len (string-length s)))
- (let loop ((i 0) (start 0))
- (cond ((= i len)
- '())
- ((char=? (string-ref s i) #\newline)
- (cons (substring s start (+ i 1))
- (loop (+ i 1) (+ i 1))))
- (else
- (loop (+ i 1) start)))))))
-
-(define out-empty-line?
- (lambda (s)
- (let ((len (- (string-length s) 1)))
- (let loop ((i 0))
- (cond ((= i len)
- #t)
- ((char-whitespace? (string-ref s i))
- (loop (+ i 1)))
- (else
- #f))))))
-
-; Enleve les lignes vides dans une liste avant et apres l'action
-(define out-remove-empty-lines
- (lambda (lines)
- (let loop ((lines lines) (top? #t))
- (if (null? lines)
- '()
- (let ((line (car lines)))
- (cond ((not (out-empty-line? line))
- (cons line (loop (cdr lines) #f)))
- (top?
- (loop (cdr lines) #t))
- (else
- (let ((rest (loop (cdr lines) #f)))
- (if (null? rest)
- '()
- (cons line rest))))))))))
-
-; Enleve les lignes vides avant et apres l'action
-(define out-clean-action
- (lambda (s)
- (let* ((lines (out-split-in-lines s))
- (clean-lines (out-remove-empty-lines lines)))
- (string-append-list clean-lines))))
-
-
-
-
-;
-; Pretty-printer pour les booleens, la liste vide, les nombres,
-; les symboles, les caracteres, les chaines, les listes et les vecteurs
-;
-
-; Colonne limite pour le pretty-printer (a ne pas atteindre)
-(define out-max-col 76)
-
-(define out-flatten-list
- (lambda (ll)
- (let loop ((ll ll) (part-out '()))
- (if (null? ll)
- part-out
- (let* ((new-part-out (loop (cdr ll) part-out))
- (head (car ll)))
- (cond ((null? head)
- new-part-out)
- ((pair? head)
- (loop head new-part-out))
- (else
- (cons head new-part-out))))))))
-
-(define out-force-string
- (lambda (obj)
- (if (char? obj)
- (string obj)
- obj)))
-
-; Transforme une liste impropre en une liste propre qui s'ecrit
-; de la meme facon
-(define out-regular-list
- (let ((symbolic-dot (string->symbol ".")))
- (lambda (p)
- (let ((tail (cdr p)))
- (cond ((null? tail)
- p)
- ((pair? tail)
- (cons (car p) (out-regular-list tail)))
- (else
- (list (car p) symbolic-dot tail)))))))
-
-; Cree des chaines d'espaces de facon paresseuse
-(define out-blanks
- (let ((cache-v (make-vector 80 #f)))
- (lambda (n)
- (or (vector-ref cache-v n)
- (let ((result (make-string n #\space)))
- (vector-set! cache-v n result)
- result)))))
-
-; Insere le separateur entre chaque element d'une liste non-vide
-(define out-separate
- (lambda (text-l sep)
- (if (null? (cdr text-l))
- text-l
- (cons (car text-l) (cons sep (out-separate (cdr text-l) sep))))))
-
-; Met des donnees en colonnes. Retourne comme out-pp-aux-list
-(define out-pp-columns
- (lambda (left right wmax txt&lens)
- (let loop1 ((tls txt&lens) (lwmax 0) (lwlast 0) (lines '()))
- (if (null? tls)
- (vector #t 0 lwmax lwlast (reverse lines))
- (let loop2 ((tls tls) (len 0) (first? #t) (prev-pad 0) (line '()))
- (cond ((null? tls)
- (loop1 tls
- (max len lwmax)
- len
- (cons (reverse line) lines)))
- ((> (+ left len prev-pad 1 wmax) out-max-col)
- (loop1 tls
- (max len lwmax)
- len
- (cons (reverse line) lines)))
- (first?
- (let ((text (caar tls))
- (text-len (cdar tls)))
- (loop2 (cdr tls)
- (+ len text-len)
- #f
- (- wmax text-len)
- (cons text line))))
- ((pair? (cdr tls))
- (let* ((prev-pad-s (out-blanks prev-pad))
- (text (caar tls))
- (text-len (cdar tls)))
- (loop2 (cdr tls)
- (+ len prev-pad 1 text-len)
- #f
- (- wmax text-len)
- (cons text (cons " " (cons prev-pad-s line))))))
- (else
- (let ((prev-pad-s (out-blanks prev-pad))
- (text (caar tls))
- (text-len (cdar tls)))
- (if (> (+ left len prev-pad 1 text-len) right)
- (loop1 tls
- (max len lwmax)
- len
- (cons (reverse line) lines))
- (loop2 (cdr tls)
- (+ len prev-pad 1 text-len)
- #f
- (- wmax text-len)
- (append (list text " " prev-pad-s)
- line)))))))))))
-
-; Retourne un vecteur #( multiline? width-all width-max width-last text-l )
-(define out-pp-aux-list
- (lambda (l left right)
- (let loop ((l l) (multi? #f) (wall -1) (wmax -1) (wlast -1) (txt&lens '()))
- (if (null? l)
- (cond (multi?
- (vector #t wall wmax wlast (map car (reverse txt&lens))))
- ((<= (+ left wall) right)
- (vector #f wall wmax wlast (map car (reverse txt&lens))))
- ((<= (+ left wmax 1 wmax) out-max-col)
- (out-pp-columns left right wmax (reverse txt&lens)))
- (else
- (vector #t wall wmax wlast (map car (reverse txt&lens)))))
- (let* ((obj (car l))
- (last? (null? (cdr l)))
- (this-right (if last? right out-max-col))
- (result (out-pp-aux obj left this-right))
- (obj-multi? (vector-ref result 0))
- (obj-wmax (vector-ref result 1))
- (obj-wlast (vector-ref result 2))
- (obj-text (vector-ref result 3)))
- (loop (cdr l)
- (or multi? obj-multi?)
- (+ wall obj-wmax 1)
- (max wmax obj-wmax)
- obj-wlast
- (cons (cons obj-text obj-wmax) txt&lens)))))))
-
-; Retourne un vecteur #( multiline? wmax wlast text )
-(define out-pp-aux
- (lambda (obj left right)
- (cond ((boolean? obj)
- (vector #f 2 2 (if obj '("#t") '("#f"))))
- ((null? obj)
- (vector #f 2 2 '("()")))
- ((number? obj)
- (let* ((s (number->string obj))
- (len (string-length s)))
- (vector #f len len (list s))))
- ((symbol? obj)
- (let* ((s (symbol->string obj))
- (len (string-length s)))
- (vector #f len len (list s))))
- ((char? obj)
- (cond ((char=? obj #\space)
- (vector #f 7 7 (list "#\\space")))
- ((char=? obj #\newline)
- (vector #f 9 9 (list "#\\newline")))
- (else
- (vector #f 3 3 (list "#\\" obj)))))
- ((string? obj)
- (let loop ((i (- (string-length obj) 1))
- (len 1)
- (text '("\"")))
- (if (= i -1)
- (vector #f (+ len 1) (+ len 1) (cons "\"" text))
- (let ((c (string-ref obj i)))
- (cond ((char=? c #\\)
- (loop (- i 1) (+ len 2) (cons "\\\\" text)))
- ((char=? c #\")
- (loop (- i 1) (+ len 2) (cons "\\\"" text)))
- (else
- (loop (- i 1) (+ len 1) (cons (string c) text))))))))
- ((pair? obj)
- (let* ((l (out-regular-list obj))
- (result (out-pp-aux-list l (+ left 1) (- right 1)))
- (multiline? (vector-ref result 0))
- (width-all (vector-ref result 1))
- (width-max (vector-ref result 2))
- (width-last (vector-ref result 3))
- (text-l (vector-ref result 4)))
- (if multiline?
- (let* ((sep (list #\newline (out-blanks left)))
- (formatted-text (out-separate text-l sep))
- (text (list "(" formatted-text ")")))
- (vector #t
- (+ (max width-max (+ width-last 1)) 1)
- (+ width-last 2)
- text))
- (let* ((sep (list " "))
- (formatted-text (out-separate text-l sep))
- (text (list "(" formatted-text ")")))
- (vector #f (+ width-all 2) (+ width-all 2) text)))))
- ((and (vector? obj) (zero? (vector-length obj)))
- (vector #f 3 3 '("#()")))
- ((vector? obj)
- (let* ((l (vector->list obj))
- (result (out-pp-aux-list l (+ left 2) (- right 1)))
- (multiline? (vector-ref result 0))
- (width-all (vector-ref result 1))
- (width-max (vector-ref result 2))
- (width-last (vector-ref result 3))
- (text-l (vector-ref result 4)))
- (if multiline?
- (let* ((sep (list #\newline (out-blanks (+ left 1))))
- (formatted-text (out-separate text-l sep))
- (text (list "#(" formatted-text ")")))
- (vector #t
- (+ (max width-max (+ width-last 1)) 2)
- (+ width-last 3)
- text))
- (let* ((sep (list " "))
- (formatted-text (out-separate text-l sep))
- (text (list "#(" formatted-text ")")))
- (vector #f (+ width-all 3) (+ width-all 3) text)))))
- (else
- (display "Internal error: out-pp")
- (newline)))))
-
-; Retourne la chaine a afficher
-(define out-pp
- (lambda (obj col)
- (let* ((list-rec-of-strings-n-chars
- (vector-ref (out-pp-aux obj col out-max-col) 3))
- (list-of-strings-n-chars
- (out-flatten-list list-rec-of-strings-n-chars))
- (list-of-strings
- (map out-force-string list-of-strings-n-chars)))
- (string-append-list list-of-strings))))
-
-
-
-
-;
-; Nice-printer, plus rapide mais moins beau que le pretty-printer
-;
-
-(define out-np
- (lambda (obj start)
- (letrec ((line-pad
- (string-append (string #\newline)
- (out-blanks (- start 1))))
- (step-line
- (lambda (p)
- (set-car! p line-pad)))
- (p-bool
- (lambda (obj col objw texts hole cont)
- (let ((text (if obj "#t" "#f")))
- (cont (+ col 2) (+ objw 2) (cons text texts) hole))))
- (p-number
- (lambda (obj col objw texts hole cont)
- (let* ((text (number->string obj))
- (len (string-length text)))
- (cont (+ col len) (+ objw len) (cons text texts) hole))))
- (p-symbol
- (lambda (obj col objw texts hole cont)
- (let* ((text (symbol->string obj))
- (len (string-length text)))
- (cont (+ col len) (+ objw len) (cons text texts) hole))))
- (p-char
- (lambda (obj col objw texts hole cont)
- (let* ((text
- (cond ((char=? obj #\space) "#\\space")
- ((char=? obj #\newline) "#\\newline")
- (else (string-append "#\\" (string obj)))))
- (len (string-length text)))
- (cont (+ col len) (+ objw len) (cons text texts) hole))))
- (p-list
- (lambda (obj col objw texts hole cont)
- (p-tail obj (+ col 1) (+ objw 1) (cons "(" texts) hole cont)))
- (p-vector
- (lambda (obj col objw texts hole cont)
- (p-list (vector->list obj)
- (+ col 1) (+ objw 1) (cons "#" texts) hole cont)))
- (p-tail
- (lambda (obj col objw texts hole cont)
- (if (null? obj)
- (cont (+ col 1) (+ objw 1) (cons ")" texts) hole)
- (p-obj (car obj) col objw texts hole
- (make-cdr-cont obj cont)))))
- (make-cdr-cont
- (lambda (obj cont)
- (lambda (col objw texts hole)
- (cond ((null? (cdr obj))
- (cont (+ col 1) (+ objw 1) (cons ")" texts) hole))
- ((> col out-max-col)
- (step-line hole)
- (let ((hole2 (cons " " texts)))
- (p-cdr obj (+ start objw 1) 0 hole2 hole2 cont)))
- (else
- (let ((hole2 (cons " " texts)))
- (p-cdr obj (+ col 1) 0 hole2 hole2 cont)))))))
- (p-cdr
- (lambda (obj col objw texts hole cont)
- (if (pair? (cdr obj))
- (p-tail (cdr obj) col objw texts hole cont)
- (p-dot col objw texts hole
- (make-cdr-cont (list #f (cdr obj)) cont)))))
- (p-dot
- (lambda (col objw texts hole cont)
- (cont (+ col 1) (+ objw 1) (cons "." texts) hole)))
- (p-obj
- (lambda (obj col objw texts hole cont)
- (cond ((boolean? obj)
- (p-bool obj col objw texts hole cont))
- ((number? obj)
- (p-number obj col objw texts hole cont))
- ((symbol? obj)
- (p-symbol obj col objw texts hole cont))
- ((char? obj)
- (p-char obj col objw texts hole cont))
- ((or (null? obj) (pair? obj))
- (p-list obj col objw texts hole cont))
- ((vector? obj)
- (p-vector obj col objw texts hole cont))))))
- (p-obj obj start 0 '() (cons #f #f)
- (lambda (col objw texts hole)
- (if (> col out-max-col)
- (step-line hole))
- (string-append-list (reverse texts)))))))
-
-
-
-
-;
-; Fonction pour afficher une table
-; Appelle la sous-routine adequate pour le type de fin de table
-;
-
-; Affiche la table d'un driver
-(define out-print-table
- (lambda (args-alist
- <<EOF>>-action <<ERROR>>-action rules
- nl-start no-nl-start arcs-v acc-v
- port)
- (let* ((filein
- (cdr (assq 'filein args-alist)))
- (table-name
- (cdr (assq 'table-name args-alist)))
- (pretty?
- (assq 'pp args-alist))
- (counters-type
- (let ((a (assq 'counters args-alist)))
- (if a (cdr a) 'line)))
- (counters-param-list
- (cond ((eq? counters-type 'none)
- ")")
- ((eq? counters-type 'line)
- " yyline)")
- (else ; 'all
- " yyline yycolumn yyoffset)")))
- (counters-param-list-short
- (if (char=? (string-ref counters-param-list 0) #\space)
- (substring counters-param-list
- 1
- (string-length counters-param-list))
- counters-param-list))
- (clean-eof-action
- (out-clean-action <<EOF>>-action))
- (clean-error-action
- (out-clean-action <<ERROR>>-action))
- (rule-op
- (lambda (rule) (out-clean-action (get-rule-action rule))))
- (rules-l
- (vector->list rules))
- (clean-actions-l
- (map rule-op rules-l))
- (yytext?-l
- (map get-rule-yytext? rules-l)))
-
- ; Commentaires prealables
- (display ";" port)
- (newline port)
- (display "; Table generated from the file " port)
- (display filein port)
- (display " by SILex 1.0" port)
- (newline port)
- (display ";" port)
- (newline port)
- (newline port)
-
- ; Ecrire le debut de la table
- (display "(define " port)
- (display table-name port)
- (newline port)
- (display " (vector" port)
- (newline port)
-
- ; Ecrire la description du type de compteurs
- (display " '" port)
- (write counters-type port)
- (newline port)
-
- ; Ecrire l'action pour la fin de fichier
- (display " (lambda (yycontinue yygetc yyungetc)" port)
- (newline port)
- (display " (lambda (yytext" port)
- (display counters-param-list port)
- (newline port)
- (display clean-eof-action port)
- (display " ))" port)
- (newline port)
-
- ; Ecrire l'action pour le cas d'erreur
- (display " (lambda (yycontinue yygetc yyungetc)" port)
- (newline port)
- (display " (lambda (yytext" port)
- (display counters-param-list port)
- (newline port)
- (display clean-error-action port)
- (display " ))" port)
- (newline port)
-
- ; Ecrire le vecteur des actions des regles ordinaires
- (display " (vector" port)
- (newline port)
- (let loop ((al clean-actions-l) (yyl yytext?-l))
- (if (pair? al)
- (let ((yytext? (car yyl)))
- (display " " port)
- (write yytext? port)
- (newline port)
- (display " (lambda (yycontinue yygetc yyungetc)" port)
- (newline port)
- (if yytext?
- (begin
- (display " (lambda (yytext" port)
- (display counters-param-list port))
- (begin
- (display " (lambda (" port)
- (display counters-param-list-short port)))
- (newline port)
- (display (car al) port)
- (display " ))" port)
- (if (pair? (cdr al))
- (newline port))
- (loop (cdr al) (cdr yyl)))))
- (display ")" port)
- (newline port)
-
- ; Ecrire l'automate
- (cond ((assq 'portable args-alist)
- (out-print-table-chars
- pretty?
- nl-start no-nl-start arcs-v acc-v
- port))
- ((assq 'code args-alist)
- (out-print-table-code
- counters-type (vector-length rules) yytext?-l
- nl-start no-nl-start arcs-v acc-v
- port))
- (else
- (out-print-table-data
- pretty?
- nl-start no-nl-start arcs-v acc-v
- port))))))
-
-;
-; Affiche l'automate sous forme d'arbres de decision
-; Termine la table du meme coup
-;
-
-(define out-print-table-data
- (lambda (pretty? nl-start no-nl-start arcs-v acc-v port)
- (let* ((len (vector-length arcs-v))
- (trees-v (make-vector len)))
- (let loop ((i 0))
- (if (< i len)
- (begin
- (vector-set! trees-v i (prep-arcs->tree (vector-ref arcs-v i)))
- (loop (+ i 1)))))
-
- ; Decrire le format de l'automate
- (display " 'decision-trees" port)
- (newline port)
-
- ; Ecrire l'etat de depart pour le cas "debut de la ligne"
- (display " " port)
- (write nl-start port)
- (newline port)
-
- ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne"
- (display " " port)
- (write no-nl-start port)
- (newline port)
-
- ; Ecrire la table de transitions
- (display " '" port)
- (if pretty?
- (display (out-pp trees-v 5) port)
- (display (out-np trees-v 5) port))
- (newline port)
-
- ; Ecrire la table des acceptations
- (display " '" port)
- (if pretty?
- (display (out-pp acc-v 5) port)
- (display (out-np acc-v 5) port))
-
- ; Ecrire la fin de la table
- (display "))" port)
- (newline port))))
-
-;
-; Affiche l'automate sous forme de listes de caracteres taggees
-; Termine la table du meme coup
-;
-
-(define out-print-table-chars
- (lambda (pretty? nl-start no-nl-start arcs-v acc-v port)
- (let* ((len (vector-length arcs-v))
- (portable-v (make-vector len))
- (arc-op (lambda (arc)
- (cons (class->tagged-char-list (car arc)) (cdr arc)))))
- (let loop ((s 0))
- (if (< s len)
- (let* ((arcs (vector-ref arcs-v s))
- (port-arcs (map arc-op arcs)))
- (vector-set! portable-v s port-arcs)
- (loop (+ s 1)))))
-
- ; Decrire le format de l'automate
- (display " 'tagged-chars-lists" port)
- (newline port)
-
- ; Ecrire l'etat de depart pour le cas "debut de la ligne"
- (display " " port)
- (write nl-start port)
- (newline port)
-
- ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne"
- (display " " port)
- (write no-nl-start port)
- (newline port)
-
- ; Ecrire la table de transitions
- (display " '" port)
- (if pretty?
- (display (out-pp portable-v 5) port)
- (display (out-np portable-v 5) port))
- (newline port)
-
- ; Ecrire la table des acceptations
- (display " '" port)
- (if pretty?
- (display (out-pp acc-v 5) port)
- (display (out-np acc-v 5) port))
-
- ; Ecrire la fin de la table
- (display "))" port)
- (newline port))))
-
-;
-; Genere l'automate en code Scheme
-; Termine la table du meme coup
-;
-
-(define out-print-code-trans3
- (lambda (margin tree action-var port)
- (newline port)
- (display (out-blanks margin) port)
- (cond ((eq? tree 'err)
- (display action-var port))
- ((number? tree)
- (display "(state-" port)
- (display tree port)
- (display " " port)
- (display action-var port)
- (display ")" port))
- ((eq? (car tree) '=)
- (display "(if (= c " port)
- (display (list-ref tree 1) port)
- (display ")" port)
- (out-print-code-trans3 (+ margin 4)
- (list-ref tree 2)
- action-var
- port)
- (out-print-code-trans3 (+ margin 4)
- (list-ref tree 3)
- action-var
- port)
- (display ")" port))
- (else
- (display "(if (< c " port)
- (display (list-ref tree 0) port)
- (display ")" port)
- (out-print-code-trans3 (+ margin 4)
- (list-ref tree 1)
- action-var
- port)
- (out-print-code-trans3 (+ margin 4)
- (list-ref tree 2)
- action-var
- port)
- (display ")" port)))))
-
-(define out-print-code-trans2
- (lambda (margin tree action-var port)
- (newline port)
- (display (out-blanks margin) port)
- (display "(if c" port)
- (out-print-code-trans3 (+ margin 4) tree action-var port)
- (newline port)
- (display (out-blanks (+ margin 4)) port)
- (display action-var port)
- (display ")" port)))
-
-(define out-print-code-trans1
- (lambda (margin tree action-var port)
- (newline port)
- (display (out-blanks margin) port)
- (if (eq? tree 'err)
- (display action-var port)
- (begin
- (display "(let ((c (read-char)))" port)
- (out-print-code-trans2 (+ margin 2) tree action-var port)
- (display ")" port)))))
-
-(define out-print-table-code
- (lambda (counters nbrules yytext?-l
- nl-start no-nl-start arcs-v acc-v
- port)
- (let* ((counters-params
- (cond ((eq? counters 'none) ")")
- ((eq? counters 'line) " yyline)")
- ((eq? counters 'all) " yyline yycolumn yyoffset)")))
- (counters-params-short
- (cond ((eq? counters 'none) ")")
- ((eq? counters 'line) "yyline)")
- ((eq? counters 'all) "yyline yycolumn yyoffset)")))
- (nbstates (vector-length arcs-v))
- (trees-v (make-vector nbstates)))
- (let loop ((s 0))
- (if (< s nbstates)
- (begin
- (vector-set! trees-v s (prep-arcs->tree (vector-ref arcs-v s)))
- (loop (+ s 1)))))
-
- ; Decrire le format de l'automate
- (display " 'code" port)
- (newline port)
-
- ; Ecrire l'entete de la fonction
- (display " (lambda (<<EOF>>-pre-action" port)
- (newline port)
- (display " <<ERROR>>-pre-action" port)
- (newline port)
- (display " rules-pre-action" port)
- (newline port)
- (display " IS)" port)
- (newline port)
-
- ; Ecrire le debut du letrec et les variables d'actions brutes
- (display " (letrec" port)
- (newline port)
- (display " ((user-action-<<EOF>> #f)" port)
- (newline port)
- (display " (user-action-<<ERROR>> #f)" port)
- (newline port)
- (let loop ((i 0))
- (if (< i nbrules)
- (begin
- (display " (user-action-" port)
- (write i port)
- (display " #f)" port)
- (newline port)
- (loop (+ i 1)))))
-
- ; Ecrire l'extraction des fonctions du IS
- (display " (start-go-to-end " port)
- (display "(cdr (assq 'start-go-to-end IS)))" port)
- (newline port)
- (display " (end-go-to-point " port)
- (display "(cdr (assq 'end-go-to-point IS)))" port)
- (newline port)
- (display " (init-lexeme " port)
- (display "(cdr (assq 'init-lexeme IS)))" port)
- (newline port)
- (display " (get-start-line " port)
- (display "(cdr (assq 'get-start-line IS)))" port)
- (newline port)
- (display " (get-start-column " port)
- (display "(cdr (assq 'get-start-column IS)))" port)
- (newline port)
- (display " (get-start-offset " port)
- (display "(cdr (assq 'get-start-offset IS)))" port)
- (newline port)
- (display " (peek-left-context " port)
- (display "(cdr (assq 'peek-left-context IS)))" port)
- (newline port)
- (display " (peek-char " port)
- (display "(cdr (assq 'peek-char IS)))" port)
- (newline port)
- (display " (read-char " port)
- (display "(cdr (assq 'read-char IS)))" port)
- (newline port)
- (display " (get-start-end-text " port)
- (display "(cdr (assq 'get-start-end-text IS)))" port)
- (newline port)
- (display " (user-getc " port)
- (display "(cdr (assq 'user-getc IS)))" port)
- (newline port)
- (display " (user-ungetc " port)
- (display "(cdr (assq 'user-ungetc IS)))" port)
- (newline port)
-
- ; Ecrire les variables d'actions
- (display " (action-<<EOF>>" port)
- (newline port)
- (display " (lambda (" port)
- (display counters-params-short port)
- (newline port)
- (display " (user-action-<<EOF>> \"\"" port)
- (display counters-params port)
- (display "))" port)
- (newline port)
- (display " (action-<<ERROR>>" port)
- (newline port)
- (display " (lambda (" port)
- (display counters-params-short port)
- (newline port)
- (display " (user-action-<<ERROR>> \"\"" port)
- (display counters-params port)
- (display "))" port)
- (newline port)
- (let loop ((i 0) (yyl yytext?-l))
- (if (< i nbrules)
- (begin
- (display " (action-" port)
- (display i port)
- (newline port)
- (display " (lambda (" port)
- (display counters-params-short port)
- (newline port)
- (if (car yyl)
- (begin
- (display " (let ((yytext" port)
- (display " (get-start-end-text)))" port)
- (newline port)
- (display " (start-go-to-end)" port)
- (newline port)
- (display " (user-action-" port)
- (display i port)
- (display " yytext" port)
- (display counters-params port)
- (display ")))" port)
- (newline port))
- (begin
- (display " (start-go-to-end)" port)
- (newline port)
- (display " (user-action-" port)
- (display i port)
- (display counters-params port)
- (display "))" port)
- (newline port)))
- (loop (+ i 1) (cdr yyl)))))
-
- ; Ecrire les variables d'etats
- (let loop ((s 0))
- (if (< s nbstates)
- (let* ((tree (vector-ref trees-v s))
- (acc (vector-ref acc-v s))
- (acc-eol (car acc))
- (acc-no-eol (cdr acc)))
- (display " (state-" port)
- (display s port)
- (newline port)
- (display " (lambda (action)" port)
- (cond ((not acc-eol)
- (out-print-code-trans1 13 tree "action" port))
- ((not acc-no-eol)
- (newline port)
- (if (eq? tree 'err)
- (display " (let* ((c (peek-char))" port)
- (display " (let* ((c (read-char))" port))
- (newline port)
- (display " (new-action (if (o" port)
- (display "r (not c) (= c lexer-integer-newline))" port)
- (newline port)
- (display " " port)
- (display " (begin (end-go-to-point) action-" port)
- (display acc-eol port)
- (display ")" port)
- (newline port)
- (display " " port)
- (display " action)))" port)
- (if (eq? tree 'err)
- (out-print-code-trans1 15 tree "new-action" port)
- (out-print-code-trans2 15 tree "new-action" port))
- (display ")" port))
- ((< acc-eol acc-no-eol)
- (newline port)
- (display " (end-go-to-point)" port)
- (newline port)
- (if (eq? tree 'err)
- (display " (let* ((c (peek-char))" port)
- (display " (let* ((c (read-char))" port))
- (newline port)
- (display " (new-action (if (o" port)
- (display "r (not c) (= c lexer-integer-newline))" port)
- (newline port)
- (display " " port)
- (display " action-" port)
- (display acc-eol port)
- (newline port)
- (display " " port)
- (display " action-" port)
- (display acc-no-eol port)
- (display ")))" port)
- (if (eq? tree 'err)
- (out-print-code-trans1 15 tree "new-action" port)
- (out-print-code-trans2 15 tree "new-action" port))
- (display ")" port))
- (else
- (let ((action-var
- (string-append "action-"
- (number->string acc-eol))))
- (newline port)
- (display " (end-go-to-point)" port)
- (out-print-code-trans1 13 tree action-var port))))
- (display "))" port)
- (newline port)
- (loop (+ s 1)))))
-
- ; Ecrire la variable de lancement de l'automate
- (display " (start-automaton" port)
- (newline port)
- (display " (lambda ()" port)
- (newline port)
- (if (= nl-start no-nl-start)
- (begin
- (display " (if (peek-char)" port)
- (newline port)
- (display " (state-" port)
- (display nl-start port)
- (display " action-<<ERROR>>)" port)
- (newline port)
- (display " action-<<EOF>>)" port))
- (begin
- (display " (cond ((not (peek-char))" port)
- (newline port)
- (display " action-<<EOF>>)" port)
- (newline port)
- (display " ((= (peek-left-context)" port)
- (display " lexer-integer-newline)" port)
- (newline port)
- (display " (state-" port)
- (display nl-start port)
- (display " action-<<ERROR>>))" port)
- (newline port)
- (display " (else" port)
- (newline port)
- (display " (state-" port)
- (display no-nl-start port)
- (display " action-<<ERROR>>)))" port)))
- (display "))" port)
- (newline port)
-
- ; Ecrire la fonction principale de lexage
- (display " (final-lexer" port)
- (newline port)
- (display " (lambda ()" port)
- (newline port)
- (display " (init-lexeme)" port)
- (newline port)
- (cond ((eq? counters 'none)
- (display " ((start-automaton))" port))
- ((eq? counters 'line)
- (display " (let ((yyline (get-start-line)))" port)
- (newline port)
- (display " ((start-automaton) yyline))" port))
- ((eq? counters 'all)
- (display " (let ((yyline (get-start-line))" port)
- (newline port)
- (display " (yycolumn (get-start-column))" port)
- (newline port)
- (display " (yyoffset (get-start-offset)))" port)
- (newline port)
- (display " ((start-automat" port)
- (display "on) yyline yycolumn yyoffset))" port)))
- (display "))" port)
-
- ; Fermer les bindings du grand letrec
- (display ")" port)
- (newline port)
-
- ; Initialiser les variables user-action-XX
- (display " (set! user-action-<<EOF>>" port)
- (display " (<<EOF>>-pre-action" port)
- (newline port)
- (display " final-lexer" port)
- (display " user-getc user-ungetc))" port)
- (newline port)
- (display " (set! user-action-<<ERROR>>" port)
- (display " (<<ERROR>>-pre-action" port)
- (newline port)
- (display " final-lexer" port)
- (display " user-getc user-ungetc))" port)
- (newline port)
- (let loop ((r 0))
- (if (< r nbrules)
- (let* ((str-r (number->string r))
- (blanks (out-blanks (string-length str-r))))
- (display " (set! user-action-" port)
- (display str-r port)
- (display " ((vector-ref rules-pre-action " port)
- (display (number->string (+ (* 2 r) 1)) port)
- (display ")" port)
- (newline port)
- (display blanks port)
- (display " final-lexer " port)
- (display "user-getc user-ungetc))" port)
- (newline port)
- (loop (+ r 1)))))
-
- ; Faire retourner le lexer final et fermer la table au complet
- (display " final-lexer))))" port)
- (newline port))))
-
-;
-; Fonctions necessaires a l'initialisation automatique du lexer
-;
-
-(define out-print-driver-functions
- (lambda (args-alist port)
- (let ((counters (cdr (or (assq 'counters args-alist) '(z . line))))
- (table-name (cdr (assq 'table-name args-alist))))
- (display ";" port)
- (newline port)
- (display "; User functions" port)
- (newline port)
- (display ";" port)
- (newline port)
- (newline port)
- (display "(define lexer #f)" port)
- (newline port)
- (newline port)
- (if (not (eq? counters 'none))
- (begin
- (display "(define lexer-get-line #f)" port)
- (newline port)
- (if (eq? counters 'all)
- (begin
- (display "(define lexer-get-column #f)" port)
- (newline port)
- (display "(define lexer-get-offset #f)" port)
- (newline port)))))
- (display "(define lexer-getc #f)" port)
- (newline port)
- (display "(define lexer-ungetc #f)" port)
- (newline port)
- (newline port)
- (display "(define lexer-init" port)
- (newline port)
- (display " (lambda (input-type input)" port)
- (newline port)
- (display " (let ((IS (lexer-make-IS input-type input '" port)
- (write counters port)
- (display ")))" port)
- (newline port)
- (display " (set! lexer (lexer-make-lexer " port)
- (display table-name port)
- (display " IS))" port)
- (newline port)
- (if (not (eq? counters 'none))
- (begin
- (display " (set! lexer-get-line (lexer-get-func-line IS))"
- port)
- (newline port)
- (if (eq? counters 'all)
- (begin
- (display
- " (set! lexer-get-column (lexer-get-func-column IS))"
- port)
- (newline port)
- (display
- " (set! lexer-get-offset (lexer-get-func-offset IS))"
- port)
- (newline port)))))
- (display " (set! lexer-getc (lexer-get-func-getc IS))" port)
- (newline port)
- (display " (set! lexer-ungetc (lexer-get-func-ungetc IS)))))"
- port)
- (newline port))))
-
-;
-; Fonction principale
-; Affiche une table ou un driver complet
-;
-
-(define output
- (lambda (args-alist
- <<EOF>>-action <<ERROR>>-action rules
- nl-start no-nl-start arcs acc)
- (let* ((fileout (cdr (assq 'fileout args-alist)))
- (port (open-output-file fileout))
- (complete-driver? (cdr (assq 'complete-driver? args-alist))))
- (if complete-driver?
- (begin
- (out-print-run-time-lib port)
- (newline port)))
- (out-print-table args-alist
- <<EOF>>-action <<ERROR>>-action rules
- nl-start no-nl-start arcs acc
- port)
- (if complete-driver?
- (begin
- (newline port)
- (out-print-driver-functions args-alist port)))
- (close-output-port port))))
-
-; Module output2.scm.
-;
-; Fonction de copiage du fichier run-time
-;
-
-(define out-print-run-time-lib
- (lambda (port)
- (display "; *** This file start" port)
- (display "s with a copy of the " port)
- (display "file multilex.scm ***" port)
- (newline port)
- (display "; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Gestion des Input Systems
-; Fonctions a utiliser par l'usager:
-; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
-; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
-;
-
-; Taille initiale par defaut du buffer d'entree
-(define lexer-init-buffer-len 1024)
-
-; Numero du caractere newline
-(define lexer-integer-newline (char->integer #\\newline))
-
-; Constructeur d'IS brut
-(define lexer-raw-IS-maker
- (lambda (buffer read-ptr input-f counters)
- (let ((input-f input-f) ; Entree reelle
- (buffer buffer) ; Buffer
- (buflen (string-length buffer))
- (read-ptr read-ptr)
- (start-ptr 1) ; Marque de debut de lexeme
- (start-line 1)
- (start-column 1)
- (start-offset 0)
- (end-ptr 1) ; Marque de fin de lexeme
- (point-ptr 1) ; Le point
- (user-ptr 1) ; Marque de l'usager
- (user-line 1)
- (user-column 1)
- (user-offset 0)
- (user-up-to-date? #t)) ; Concerne la colonne seul.
- (letrec
- ((start-go-to-end-none ; Fonctions de depl. des marques
- (lambda ()
- (set! start-ptr end-ptr)))
- (start-go-to-end-line
- (lambda ()
- (let loop ((ptr start-ptr) (line start-line))
- (if (= ptr end-ptr)
- (begin
- (set! start-ptr ptr)
- (set! start-line line))
- (if (char=? (string-ref buffer ptr) #\\newline)
- (loop (+ ptr 1) (+ line 1))
- (loop (+ ptr 1) line))))))
- (start-go-to-end-all
- (lambda ()
- (set! start-offset (+ start-offset (- end-ptr start-ptr)))
- (let loop ((ptr start-ptr)
- (line start-line)
- (column start-column))
- (if (= ptr end-ptr)
- (begin
- (set! start-ptr ptr)
- (set! start-line line)
- (set! start-column column))
- (if (char=? (string-ref buffer ptr) #\\newline)
- (loop (+ ptr 1) (+ line 1) 1)
- (loop (+ ptr 1) line (+ column 1)))))))
- (start-go-to-user-none
- (lambda ()
- (set! start-ptr user-ptr)))
- (start-go-to-user-line
- (lambda ()
- (set! start-ptr user-ptr)
- (set! start-line user-line)))
- (start-go-to-user-all
- (lambda ()
- (set! start-line user-line)
- (set! start-offset user-offset)
- (if user-up-to-date?
- (begin
- (set! start-ptr user-ptr)
- (set! start-column user-column))
- (let loop ((ptr start-ptr) (column start-column))
- (if (= ptr user-ptr)
- (begin
- (set! start-ptr ptr)
- (set! start-column column))
- (if (char=? (string-ref buffer ptr) #\\newline)
- (loop (+ ptr 1) 1)
- (loop (+ ptr 1) (+ column 1))))))))
- (end-go-to-point
- (lambda ()
- (set! end-ptr point-ptr)))
- (point-go-to-start
- (lambda ()
- (set! point-ptr start-ptr)))
- (user-go-to-start-none
- (lambda ()
- (set! user-ptr start-ptr)))
- (user-go-to-start-line
- (lambda ()
- (set! user-ptr start-ptr)
- (set! user-line start-line)))
- (user-go-to-start-all
- (lambda ()
- (set! user-ptr start-ptr)
- (set! user-line start-line)
- (set! user-column start-column)
- (set! user-offset start-offset)
- (set! user-up-to-date? #t)))
- (init-lexeme-none ; Debute un nouveau lexeme
- (lambda ()
- (if (< start-ptr user-ptr)
- (start-go-to-user-none))
- (point-go-to-start)))
- (init-lexeme-line
- (lambda ()
- (if (< start-ptr user-ptr)
- (start-go-to-user-line))
- (point-go-to-start)))
- (init-lexeme-all
- (lambda ()
- (if (< start-ptr user-ptr)
- (start-go-to-user-all))
- (point-go-to-start)))
- (get-start-line ; Obtention des stats du debut du lxm
- (lambda ()
- start-line))
- (get-start-column
- (lambda ()
- start-column))
- (get-start-offset
- (lambda ()
- start-offset))
- (peek-left-context ; Obtention de caracteres (#f si EOF)
- (lambda ()
- (char->integer (string-ref buffer (- start-ptr 1)))))
- (peek-char
- (lambda ()
- (if (< point-ptr read-ptr)
- (char->integer (string-ref buffer point-ptr))
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer point-ptr c)
- (set! read-ptr (+ point-ptr 1))
- (char->integer c))
- (begin
- (set! input-f (lambda () 'eof))
- #f))))))
- (read-char
- (lambda ()
- (if (< point-ptr read-ptr)
- (let ((c (string-ref buffer point-ptr)))
- (set! point-ptr (+ point-ptr 1))
- (char->integer c))
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer point-ptr c)
- (set! read-ptr (+ point-ptr 1))
- (set! point-ptr read-ptr)
- (char->integer c))
- (begin
- (set! input-f (lambda () 'eof))
- #f))))))
- (get-start-end-text ; Obtention du lexeme
- (lambda ()
- (substring buffer start-ptr end-ptr)))
- (get-user-line-line ; Fonctions pour l'usager
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-line))
- user-line))
- (get-user-line-all
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-all))
- user-line))
- (get-user-column-all
- (lambda ()
- (cond ((< user-ptr start-ptr)
- (user-go-to-start-all)
- user-column)
- (user-up-to-date?
- user-column)
- (else
- (let loop ((ptr start-ptr) (column start-column))
- (if (= ptr user-ptr)
- (begin
- (set! user-column column)
- (set! user-up-to-date? #t)
- column)
- (if (char=? (string-ref buffer ptr) #\\newline)
- (loop (+ ptr 1) 1)
- (loop (+ ptr 1) (+ column 1)))))))))
- (get-user-offset-all
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-all))
- user-offset))
- (user-getc-none
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-none))
- (if (< user-ptr read-ptr)
- (let ((c (string-ref buffer user-ptr)))
- (set! user-ptr (+ user-ptr 1))
- c)
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer user-ptr c)
- (set! read-ptr (+ read-ptr 1))
- (set! user-ptr read-ptr)
- c)
- (begin
- (set! input-f (lambda () 'eof))
- 'eof))))))
- (user-getc-line
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-line))
- (if (< user-ptr read-ptr)
- (let ((c (string-ref buffer user-ptr)))
- (set! user-ptr (+ user-ptr 1))
- (if (char=? c #\\newline)
- (set! user-line (+ user-line 1)))
- c)
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer user-ptr c)
- (set! read-ptr (+ read-ptr 1))
- (set! user-ptr read-ptr)
- (if (char=? c #\\newline)
- (set! user-line (+ user-line 1)))
- c)
- (begin
- (set! input-f (lambda () 'eof))
- 'eof))))))
- (user-getc-all
- (lambda ()
- (if (< user-ptr start-ptr)
- (user-go-to-start-all))
- (if (< user-ptr read-ptr)
- (let ((c (string-ref buffer user-ptr)))
- (set! user-ptr (+ user-ptr 1))
- (if (char=? c #\\newline)
- (begin
- (set! user-line (+ user-line 1))
- (set! user-column 1))
- (set! user-column (+ user-column 1)))
- (set! user-offset (+ user-offset 1))
- c)
- (let ((c (input-f)))
- (if (char? c)
- (begin
- (if (= read-ptr buflen)
- (reorganize-buffer))
- (string-set! buffer user-ptr c)
- (set! read-ptr (+ read-ptr 1))
- (set! user-ptr read-ptr)
- (if (char=? c #\\newline)
- (begin
- (set! user-line (+ user-line 1))
- (set! user-column 1))
- (set! user-column (+ user-column 1)))
- (set! user-offset (+ user-offset 1))
- c)
- (begin
- (set! input-f (lambda () 'eof))
- 'eof))))))
- (user-ungetc-none
- (lambda ()
- (if (> user-ptr start-ptr)
- (set! user-ptr (- user-ptr 1)))))
- (user-ungetc-line
- (lambda ()
- (if (> user-ptr start-ptr)
- (begin
- (set! user-ptr (- user-ptr 1))
- (let ((c (string-ref buffer user-ptr)))
- (if (char=? c #\\newline)
- (set! user-line (- user-line 1))))))))
- (user-ungetc-all
- (lambda ()
- (if (> user-ptr start-ptr)
- (begin
- (set! user-ptr (- user-ptr 1))
- (let ((c (string-ref buffer user-ptr)))
- (if (char=? c #\\newline)
- (begin
- (set! user-line (- user-line 1))
- (set! user-up-to-date? #f))
- (set! user-column (- user-column 1)))
- (set! user-offset (- user-offset 1)))))))
- (reorganize-buffer ; Decaler ou agrandir le buffer
- (lambda ()
- (if (< (* 2 start-ptr) buflen)
- (let* ((newlen (* 2 buflen))
- (newbuf (make-string newlen))
- (delta (- start-ptr 1)))
- (let loop ((from (- start-ptr 1)))
- (if (< from buflen)
- (begin
- (string-set! newbuf
- (- from delta)
- (string-ref buffer from))
- (loop (+ from 1)))))
- (set! buffer newbuf)
- (set! buflen newlen)
- (set! read-ptr (- read-ptr delta))
- (set! start-ptr (- start-ptr delta))
- (set! end-ptr (- end-ptr delta))
- (set! point-ptr (- point-ptr delta))
- (set! user-ptr (- user-ptr delta)))
- (let ((delta (- start-ptr 1)))
- (let loop ((from (- start-ptr 1)))
- (if (< from buflen)
- (begin
- (string-set! buffer
- (- from delta)
- (string-ref buffer from))
- (loop (+ from 1)))))
- (set! read-ptr (- read-ptr delta))
- (set! start-ptr (- start-ptr delta))
- (set! end-ptr (- end-ptr delta))
- (set! point-ptr (- point-ptr delta))
- (set! user-ptr (- user-ptr delta)))))))
- (list (cons 'start-go-to-end
- (cond ((eq? counters 'none) start-go-to-end-none)
- ((eq? counters 'line) start-go-to-end-line)
- ((eq? counters 'all ) start-go-to-end-all)))
- (cons 'end-go-to-point
- end-go-to-point)
- (cons 'init-lexeme
- (cond ((eq? counters 'none) init-lexeme-none)
- ((eq? counters 'line) init-lexeme-line)
- ((eq? counters 'all ) init-lexeme-all)))
- (cons 'get-start-line
- get-start-line)
- (cons 'get-start-column
- get-start-column)
- (cons 'get-start-offset
- get-start-offset)
- (cons 'peek-left-context
- peek-left-context)
- (cons 'peek-char
- peek-char)
- (cons 'read-char
- read-char)
- (cons 'get-start-end-text
- get-start-end-text)
- (cons 'get-user-line
- (cond ((eq? counters 'none) #f)
- ((eq? counters 'line) get-user-line-line)
- ((eq? counters 'all ) get-user-line-all)))
- (cons 'get-user-column
- (cond ((eq? counters 'none) #f)
- ((eq? counters 'line) #f)
- ((eq? counters 'all ) get-user-column-all)))
- (cons 'get-user-offset
- (cond ((eq? counters 'none) #f)
- ((eq? counters 'line) #f)
- ((eq? counters 'all ) get-user-offset-all)))
- (cons 'user-getc
- (cond ((eq? counters 'none) user-getc-none)
- ((eq? counters 'line) user-getc-line)
- ((eq? counters 'all ) user-getc-all)))
- (cons 'user-ungetc
- (cond ((eq? counters 'none) user-ungetc-none)
- ((eq? counters 'line) user-ungetc-line)
- ((eq? counters 'all ) user-ungetc-all))))))))
-
-; Construit un Input System
-; Le premier parametre doit etre parmi \"port\", \"procedure\" ou \"string\"
-; Prend un parametre facultatif qui doit etre parmi
-; \"none\", \"line\" ou \"all\"
-(define lexer-make-IS
- (lambda (input-type input . largs)
- (let ((counters-type (cond ((null? largs)
- 'line)
- ((memq (car largs) '(none line all))
- (car largs))
- (else
- 'line))))
- (cond ((and (eq? input-type 'port) (input-port? input))
- (let* ((buffer (make-string lexer-init-buffer-len #\\newline))
- (read-ptr 1)
- (input-f (lambda () (read-char input))))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
- ((and (eq? input-type 'procedure) (procedure? input))
- (let* ((buffer (make-string lexer-init-buffer-len #\\newline))
- (read-ptr 1)
- (input-f input))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
- ((and (eq? input-type 'string) (string? input))
- (let* ((buffer (string-append (string #\\newline) input))
- (read-ptr (string-length buffer))
- (input-f (lambda () 'eof)))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
- (else
- (let* ((buffer (string #\\newline))
- (read-ptr 1)
- (input-f (lambda () 'eof)))
- (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
-
-; Les fonctions:
-; lexer-get-func-getc, lexer-get-func-ungetc,
-; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
-(define lexer-get-func-getc
- (lambda (IS) (cdr (assq 'user-getc IS))))
-(define lexer-get-func-ungetc
- (lambda (IS) (cdr (assq 'user-ungetc IS))))
-(define lexer-get-func-line
- (lambda (IS) (cdr (assq 'get-user-line IS))))
-(define lexer-get-func-column
- (lambda (IS) (cdr (assq 'get-user-column IS))))
-(define lexer-get-func-offset
- (lambda (IS) (cdr (assq 'get-user-offset IS))))
-
-;
-; Gestion des lexers
-;
-
-; Fabrication de lexer a partir d'arbres de decision
-(define lexer-make-tree-lexer
- (lambda (tables IS)
- (letrec
- (; Contenu de la table
- (counters-type (vector-ref tables 0))
- (<<EOF>>-pre-action (vector-ref tables 1))
- (<<ERROR>>-pre-action (vector-ref tables 2))
- (rules-pre-actions (vector-ref tables 3))
- (table-nl-start (vector-ref tables 5))
- (table-no-nl-start (vector-ref tables 6))
- (trees-v (vector-ref tables 7))
- (acc-v (vector-ref tables 8))
-
- ; Contenu du IS
- (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
- (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
- (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
- (IS-get-start-line (cdr (assq 'get-start-line IS)))
- (IS-get-start-column (cdr (assq 'get-start-column IS)))
- (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
- (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
- (IS-peek-char (cdr (assq 'peek-char IS)))
- (IS-read-char (cdr (assq 'read-char IS)))
- (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
- (IS-get-user-line (cdr (assq 'get-user-line IS)))
- (IS-get-user-column (cdr (assq 'get-user-column IS)))
- (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
- (IS-user-getc (cdr (assq 'user-getc IS)))
- (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
-
- ; Resultats
- (<<EOF>>-action #f)
- (<<ERROR>>-action #f)
- (rules-actions #f)
- (states #f)
- (final-lexer #f)
-
- ; Gestion des hooks
- (hook-list '())
- (add-hook
- (lambda (thunk)
- (set! hook-list (cons thunk hook-list))))
- (apply-hooks
- (lambda ()
- (let loop ((l hook-list))
- (if (pair? l)
- (begin
- ((car l))
- (loop (cdr l)))))))
-
- ; Preparation des actions
- (set-action-statics
- (lambda (pre-action)
- (pre-action final-lexer IS-user-getc IS-user-ungetc)))
- (prepare-special-action-none
- (lambda (pre-action)
- (let ((action #f))
- (let ((result
- (lambda ()
- (action \"\")))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-special-action-line
- (lambda (pre-action)
- (let ((action #f))
- (let ((result
- (lambda (yyline)
- (action \"\" yyline)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-special-action-all
- (lambda (pre-action)
- (let ((action #f))
- (let ((result
- (lambda (yyline yycolumn yyoffset)
- (action \"\" yyline yycolumn yyoffset)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-special-action
- (lambda (pre-action)
- (cond ((eq? counters-type 'none)
- (prepare-special-action-none pre-action))
- ((eq? counters-type 'line)
- (prepare-special-action-line pre-action))
- ((eq? counters-type 'all)
- (prepare-special-action-all pre-action)))))
- (prepare-action-yytext-none
- (lambda (pre-action)
- (let ((get-start-end-text IS-get-start-end-text)
- (start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda ()
- (let ((yytext (get-start-end-text)))
- (start-go-to-end)
- (action yytext))))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-yytext-line
- (lambda (pre-action)
- (let ((get-start-end-text IS-get-start-end-text)
- (start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline)
- (let ((yytext (get-start-end-text)))
- (start-go-to-end)
- (action yytext yyline))))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-yytext-all
- (lambda (pre-action)
- (let ((get-start-end-text IS-get-start-end-text)
- (start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline yycolumn yyoffset)
- (let ((yytext (get-start-end-text)))
- (start-go-to-end)
- (action yytext yyline yycolumn yyoffset))))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-yytext
- (lambda (pre-action)
- (cond ((eq? counters-type 'none)
- (prepare-action-yytext-none pre-action))
- ((eq? counters-type 'line)
- (prepare-action-yytext-line pre-action))
- ((eq? counters-type 'all)
- (prepare-action-yytext-all pre-action)))))
- (prepare-action-no-yytext-none
- (lambda (pre-action)
- (let ((start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda ()
- (start-go-to-end)
- (action)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-no-yytext-line
- (lambda (pre-action)
- (let ((start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline)
- (start-go-to-end)
- (action yyline)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-no-yytext-all
- (lambda (pre-action)
- (let ((start-go-to-end IS-start-go-to-end)
- (action #f))
- (let ((result
- (lambda (yyline yycolumn yyoffset)
- (start-go-to-end)
- (action yyline yycolumn yyoffset)))
- (hook
- (lambda ()
- (set! action (set-action-statics pre-action)))))
- (add-hook hook)
- result))))
- (prepare-action-no-yytext
- (lambda (pre-action)
- (cond ((eq? counters-type 'none)
- (prepare-action-no-yytext-none pre-action))
- ((eq? counters-type 'line)
- (prepare-action-no-yytext-line pre-action))
- ((eq? counters-type 'all)
- (prepare-action-no-yytext-all pre-action)))))
-
- ; Fabrique les fonctions de dispatch
- (prepare-dispatch-err
- (lambda (leaf)
- (lambda (c)
- #f)))
- (prepare-dispatch-number
- (lambda (leaf)
- (let ((state-function #f))
- (let ((result
- (lambda (c)
- state-function))
- (hook
- (lambda ()
- (set! state-function (vector-ref states leaf)))))
- (add-hook hook)
- result))))
- (prepare-dispatch-leaf
- (lambda (leaf)
- (if (eq? leaf 'err)
- (prepare-dispatch-err leaf)
- (prepare-dispatch-number leaf))))
- (prepare-dispatch-<
- (lambda (tree)
- (let ((left-tree (list-ref tree 1))
- (right-tree (list-ref tree 2)))
- (let ((bound (list-ref tree 0))
- (left-func (prepare-dispatch-tree left-tree))
- (right-func (prepare-dispatch-tree right-tree)))
- (lambda (c)
- (if (< c bound)
- (left-func c)
- (right-func c)))))))
- (prepare-dispatch-=
- (lambda (tree)
- (let ((left-tree (list-ref tree 2))
- (right-tree (list-ref tree 3)))
- (let ((bound (list-ref tree 1))
- (left-func (prepare-dispatch-tree left-tree))
- (right-func (prepare-dispatch-tree right-tree)))
- (lambda (c)
- (if (= c bound)
- (left-func c)
- (right-func c)))))))
- (prepare-dispatch-tree
- (lambda (tree)
- (cond ((not (pair? tree))
- (prepare-dispatch-leaf tree))
- ((eq? (car tree) '=)
- (prepare-dispatch-= tree))
- (else
- (prepare-dispatch-< tree)))))
- (prepare-dispatch
- (lambda (tree)
- (let ((dicho-func (prepare-dispatch-tree tree)))
- (lambda (c)
- (and c (dicho-func c))))))
-
- ; Fabrique les fonctions de transition (read & go) et (abort)
- (prepare-read-n-go
- (lambda (tree)
- (let ((dispatch-func (prepare-dispatch tree))
- (read-char IS-read-char))
- (lambda ()
- (dispatch-func (read-char))))))
- (prepare-abort
- (lambda (tree)
- (lambda ()
- #f)))
- (prepare-transition
- (lambda (tree)
- (if (eq? tree 'err)
- (prepare-abort tree)
- (prepare-read-n-go tree))))
-
- ; Fabrique les fonctions d'etats ([set-end] & trans)
- (prepare-state-no-acc
- (lambda (s r1 r2)
- (let ((trans-func (prepare-transition (vector-ref trees-v s))))
- (lambda (action)
- (let ((next-state (trans-func)))
- (if next-state
- (next-state action)
- action))))))
- (prepare-state-yes-no
- (lambda (s r1 r2)
- (let ((peek-char IS-peek-char)
- (end-go-to-point IS-end-go-to-point)
- (new-action1 #f)
- (trans-func (prepare-transition (vector-ref trees-v s))))
- (let ((result
- (lambda (action)
- (let* ((c (peek-char))
- (new-action
- (if (or (not c) (= c lexer-integer-newline))
- (begin
- (end-go-to-point)
- new-action1)
- action))
- (next-state (trans-func)))
- (if next-state
- (next-state new-action)
- new-action))))
- (hook
- (lambda ()
- (set! new-action1 (vector-ref rules-actions r1)))))
- (add-hook hook)
- result))))
- (prepare-state-diff-acc
- (lambda (s r1 r2)
- (let ((end-go-to-point IS-end-go-to-point)
- (peek-char IS-peek-char)
- (new-action1 #f)
- (new-action2 #f)
- (trans-func (prepare-transition (vector-ref trees-v s))))
- (let ((result
- (lambda (action)
- (end-go-to-point)
- (let* ((c (peek-char))
- (new-action
- (if (or (not c) (= c lexer-integer-newline))
- new-action1
- new-action2))
- (next-state (trans-func)))
- (if next-state
- (next-state new-action)
- new-action))))
- (hook
- (lambda ()
- (set! new-action1 (vector-ref rules-actions r1))
- (set! new-action2 (vector-ref rules-actions r2)))))
- (add-hook hook)
- result))))
- (prepare-state-same-acc
- (lambda (s r1 r2)
- (let ((end-go-to-point IS-end-go-to-point)
- (trans-func (prepare-transition (vector-ref trees-v s)))
- (new-action #f))
- (let ((result
- (lambda (action)
- (end-go-to-point)
- (let ((next-state (trans-func)))
- (if next-state
- (next-state new-action)
- new-action))))
- (hook
- (lambda ()
- (set! new-action (vector-ref rules-actions r1)))))
- (add-hook hook)
- result))))
- (prepare-state
- (lambda (s)
- (let* ((acc (vector-ref acc-v s))
- (r1 (car acc))
- (r2 (cdr acc)))
- (cond ((not r1) (prepare-state-no-acc s r1 r2))
- ((not r2) (prepare-state-yes-no s r1 r2))
- ((< r1 r2) (prepare-state-diff-acc s r1 r2))
- (else (prepare-state-same-acc s r1 r2))))))
-
- ; Fabrique la fonction de lancement du lexage a l'etat de depart
- (prepare-start-same
- (lambda (s1 s2)
- (let ((peek-char IS-peek-char)
- (eof-action #f)
- (start-state #f)
- (error-action #f))
- (let ((result
- (lambda ()
- (if (not (peek-char))
- eof-action
- (start-state error-action))))
- (hook
- (lambda ()
- (set! eof-action <<EOF>>-action)
- (set! start-state (vector-ref states s1))
- (set! error-action <<ERROR>>-action))))
- (add-hook hook)
- result))))
- (prepare-start-diff
- (lambda (s1 s2)
- (let ((peek-char IS-peek-char)
- (eof-action #f)
- (peek-left-context IS-peek-left-context)
- (start-state1 #f)
- (start-state2 #f)
- (error-action #f))
- (let ((result
- (lambda ()
- (cond ((not (peek-char))
- eof-action)
- ((= (peek-left-context) lexer-integer-newline)
- (start-state1 error-action))
- (else
- (start-state2 error-action)))))
- (hook
- (lambda ()
- (set! eof-action <<EOF>>-action)
- (set! start-state1 (vector-ref states s1))
- (set! start-state2 (vector-ref states s2))
- (set! error-action <<ERROR>>-action))))
- (add-hook hook)
- result))))
- (prepare-start
- (lambda ()
- (let ((s1 table-nl-start)
- (s2 table-no-nl-start))
- (if (= s1 s2)
- (prepare-start-same s1 s2)
- (prepare-start-diff s1 s2)))))
-
- ; Fabrique la fonction principale
- (prepare-lexer-none
- (lambda ()
- (let ((init-lexeme IS-init-lexeme)
- (start-func (prepare-start)))
- (lambda ()
- (init-lexeme)
- ((start-func))))))
- (prepare-lexer-line
- (lambda ()
- (let ((init-lexeme IS-init-lexeme)
- (get-start-line IS-get-start-line)
- (start-func (prepare-start)))
- (lambda ()
- (init-lexeme)
- (let ((yyline (get-start-line)))
- ((start-func) yyline))))))
- (prepare-lexer-all
- (lambda ()
- (let ((init-lexeme IS-init-lexeme)
- (get-start-line IS-get-start-line)
- (get-start-column IS-get-start-column)
- (get-start-offset IS-get-start-offset)
- (start-func (prepare-start)))
- (lambda ()
- (init-lexeme)
- (let ((yyline (get-start-line))
- (yycolumn (get-start-column))
- (yyoffset (get-start-offset)))
- ((start-func) yyline yycolumn yyoffset))))))
- (prepare-lexer
- (lambda ()
- (cond ((eq? counters-type 'none) (prepare-lexer-none))
- ((eq? counters-type 'line) (prepare-lexer-line))
- ((eq? counters-type 'all) (prepare-lexer-all))))))
-
- ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
- (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
- (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
-
- ; Calculer la valeur de rules-actions
- (let* ((len (quotient (vector-length rules-pre-actions) 2))
- (v (make-vector len)))
- (let loop ((r (- len 1)))
- (if (< r 0)
- (set! rules-actions v)
- (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
- (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
- (action (if yytext?
- (prepare-action-yytext pre-action)
- (prepare-action-no-yytext pre-action))))
- (vector-set! v r action)
- (loop (- r 1))))))
-
- ; Calculer la valeur de states
- (let* ((len (vector-length trees-v))
- (v (make-vector len)))
- (let loop ((s (- len 1)))
- (if (< s 0)
- (set! states v)
- (begin
- (vector-set! v s (prepare-state s))
- (loop (- s 1))))))
-
- ; Calculer la valeur de final-lexer
- (set! final-lexer (prepare-lexer))
-
- ; Executer les hooks
- (apply-hooks)
-
- ; Resultat
- final-lexer)))
-
-; Fabrication de lexer a partir de listes de caracteres taggees
-(define lexer-make-char-lexer
- (let* ((char->class
- (lambda (c)
- (let ((n (char->integer c)))
- (list (cons n n)))))
- (merge-sort
- (lambda (l combine zero-elt)
- (if (null? l)
- zero-elt
- (let loop1 ((l l))
- (if (null? (cdr l))
- (car l)
- (loop1
- (let loop2 ((l l))
- (cond ((null? l)
- l)
- ((null? (cdr l))
- l)
- (else
- (cons (combine (car l) (cadr l))
- (loop2 (cddr l))))))))))))
- (finite-class-union
- (lambda (c1 c2)
- (let loop ((c1 c1) (c2 c2) (u '()))
- (if (null? c1)
- (if (null? c2)
- (reverse u)
- (loop c1 (cdr c2) (cons (car c2) u)))
- (if (null? c2)
- (loop (cdr c1) c2 (cons (car c1) u))
- (let* ((r1 (car c1))
- (r2 (car c2))
- (r1start (car r1))
- (r1end (cdr r1))
- (r2start (car r2))
- (r2end (cdr r2)))
- (if (<= r1start r2start)
- (cond ((< (+ r1end 1) r2start)
- (loop (cdr c1) c2 (cons r1 u)))
- ((<= r1end r2end)
- (loop (cdr c1)
- (cons (cons r1start r2end) (cdr c2))
- u))
- (else
- (loop c1 (cdr c2) u)))
- (cond ((> r1start (+ r2end 1))
- (loop c1 (cdr c2) (cons r2 u)))
- ((>= r1end r2end)
- (loop (cons (cons r2start r1end) (cdr c1))
- (cdr c2)
- u))
- (else
- (loop (cdr c1) c2 u))))))))))
- (char-list->class
- (lambda (cl)
- (let ((classes (map char->class cl)))
- (merge-sort classes finite-class-union '()))))
- (class-<
- (lambda (b1 b2)
- (cond ((eq? b1 'inf+) #f)
- ((eq? b2 'inf-) #f)
- ((eq? b1 'inf-) #t)
- ((eq? b2 'inf+) #t)
- (else (< b1 b2)))))
- (finite-class-compl
- (lambda (c)
- (let loop ((c c) (start 'inf-))
- (if (null? c)
- (list (cons start 'inf+))
- (let* ((r (car c))
- (rstart (car r))
- (rend (cdr r)))
- (if (class-< start rstart)
- (cons (cons start (- rstart 1))
- (loop c rstart))
- (loop (cdr c) (+ rend 1))))))))
- (tagged-chars->class
- (lambda (tcl)
- (let* ((inverse? (car tcl))
- (cl (cdr tcl))
- (class-tmp (char-list->class cl)))
- (if inverse? (finite-class-compl class-tmp) class-tmp))))
- (charc->arc
- (lambda (charc)
- (let* ((tcl (car charc))
- (dest (cdr charc))
- (class (tagged-chars->class tcl)))
- (cons class dest))))
- (arc->sharcs
- (lambda (arc)
- (let* ((range-l (car arc))
- (dest (cdr arc))
- (op (lambda (range) (cons range dest))))
- (map op range-l))))
- (class-<=
- (lambda (b1 b2)
- (cond ((eq? b1 'inf-) #t)
- ((eq? b2 'inf+) #t)
- ((eq? b1 'inf+) #f)
- ((eq? b2 'inf-) #f)
- (else (<= b1 b2)))))
- (sharc-<=
- (lambda (sharc1 sharc2)
- (class-<= (caar sharc1) (caar sharc2))))
- (merge-sharcs
- (lambda (l1 l2)
- (let loop ((l1 l1) (l2 l2))
- (cond ((null? l1)
- l2)
- ((null? l2)
- l1)
- (else
- (let ((sharc1 (car l1))
- (sharc2 (car l2)))
- (if (sharc-<= sharc1 sharc2)
- (cons sharc1 (loop (cdr l1) l2))
- (cons sharc2 (loop l1 (cdr l2))))))))))
- (class-= eqv?)
- (fill-error
- (lambda (sharcs)
- (let loop ((sharcs sharcs) (start 'inf-))
- (cond ((class-= start 'inf+)
- '())
- ((null? sharcs)
- (cons (cons (cons start 'inf+) 'err)
- (loop sharcs 'inf+)))
- (else
- (let* ((sharc (car sharcs))
- (h (caar sharc))
- (t (cdar sharc)))
- (if (class-< start h)
- (cons (cons (cons start (- h 1)) 'err)
- (loop sharcs h))
- (cons sharc (loop (cdr sharcs)
- (if (class-= t 'inf+)
- 'inf+
- (+ t 1)))))))))))
- (charcs->tree
- (lambda (charcs)
- (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
- (sharcs-l (map op charcs))
- (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
- (full-sharcs (fill-error sorted-sharcs))
- (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
- (table (list->vector (map op full-sharcs))))
- (let loop ((left 0) (right (- (vector-length table) 1)))
- (if (= left right)
- (cdr (vector-ref table left))
- (let ((mid (quotient (+ left right 1) 2)))
- (if (and (= (+ left 2) right)
- (= (+ (car (vector-ref table mid)) 1)
- (car (vector-ref table right)))
- (eqv? (cdr (vector-ref table left))
- (cdr (vector-ref table right))))
- (list '=
- (car (vector-ref table mid))
- (cdr (vector-ref table mid))
- (cdr (vector-ref table left)))
- (list (car (vector-ref table mid))
- (loop left (- mid 1))
- (loop mid right))))))))))
- (lambda (tables IS)
- (let ((counters (vector-ref tables 0))
- (<<EOF>>-action (vector-ref tables 1))
- (<<ERROR>>-action (vector-ref tables 2))
- (rules-actions (vector-ref tables 3))
- (nl-start (vector-ref tables 5))
- (no-nl-start (vector-ref tables 6))
- (charcs-v (vector-ref tables 7))
- (acc-v (vector-ref tables 8)))
- (let* ((len (vector-length charcs-v))
- (v (make-vector len)))
- (let loop ((i (- len 1)))
- (if (>= i 0)
- (begin
- (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
- (loop (- i 1)))
- (lexer-make-tree-lexer
- (vector counters
- <<EOF>>-action
- <<ERROR>>-action
- rules-actions
- 'decision-trees
- nl-start
- no-nl-start
- v
- acc-v)
- IS))))))))
-
-; Fabrication d'un lexer a partir de code pre-genere
-(define lexer-make-code-lexer
- (lambda (tables IS)
- (let ((<<EOF>>-pre-action (vector-ref tables 1))
- (<<ERROR>>-pre-action (vector-ref tables 2))
- (rules-pre-action (vector-ref tables 3))
- (code (vector-ref tables 5)))
- (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
-
-(define lexer-make-lexer
- (lambda (tables IS)
- (let ((automaton-type (vector-ref tables 4)))
- (cond ((eq? automaton-type 'decision-trees)
- (lexer-make-tree-lexer tables IS))
- ((eq? automaton-type 'tagged-chars-lists)
- (lexer-make-char-lexer tables IS))
- ((eq? automaton-type 'code)
- (lexer-make-code-lexer tables IS))))))
-" port)))
-
-; Module main.scm.
-; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
-; All rights reserved.
-; SILex 1.0.
-
-;
-; Gestion d'erreurs
-;
-
-(define lex-exit-continuation #f)
-(define lex-unwind-protect-list '())
-(define lex-error-filename #f)
-
-(define lex-unwind-protect
- (lambda (proc)
- (set! lex-unwind-protect-list (cons proc lex-unwind-protect-list))))
-
-(define lex-error
- (lambda (line column . l)
- (let* ((linestr (if line (number->string line) #f))
- (colstr (if column (number->string column) #f))
- (namelen (string-length lex-error-filename))
- (linelen (if line (string-length linestr) -1))
- (collen (if column (string-length colstr) -1))
- (totallen (+ namelen 1 linelen 1 collen 2)))
- (display "Lex error:")
- (newline)
- (display lex-error-filename)
- (if line
- (begin
- (display ":")
- (display linestr)))
- (if column
- (begin
- (display ":")
- (display colstr)))
- (display ": ")
- (let loop ((l l))
- (if (null? l)
- (newline)
- (let ((item (car l)))
- (display item)
- (if (equal? '#\newline item)
- (let loop2 ((i totallen))
- (if (> i 0)
- (begin
- (display #\space)
- (loop2 (- i 1))))))
- (loop (cdr l)))))
- (newline)
- (let loop ((l lex-unwind-protect-list))
- (if (pair? l)
- (begin
- ((car l))
- (loop (cdr l)))))
- (lex-exit-continuation #f))))
-
-
-
-
-;
-; Decoupage des arguments
-;
-
-(define lex-recognized-args
- '(complete-driver?
- filein
- table-name
- fileout
- counters
- portable
- code
- pp))
-
-(define lex-valued-args
- '(complete-driver?
- filein
- table-name
- fileout
- counters))
-
-(define lex-parse-args
- (lambda (args)
- (let loop ((args args))
- (if (null? args)
- '()
- (let ((sym (car args)))
- (cond ((not (symbol? sym))
- (lex-error #f #f "bad option list."))
- ((not (memq sym lex-recognized-args))
- (lex-error #f #f "unrecognized option \"" sym "\"."))
- ((not (memq sym lex-valued-args))
- (cons (cons sym '()) (loop (cdr args))))
- ((null? (cdr args))
- (lex-error #f #f "the value of \"" sym "\" not specified."))
- (else
- (cons (cons sym (cadr args)) (loop (cddr args))))))))))
-
-
-
-
-;
-; Differentes etapes de la fabrication de l'automate
-;
-
-(define lex1
- (lambda (filein)
-; (display "lex1: ") (write (get-internal-run-time)) (newline)
- (parser filein)))
-
-(define lex2
- (lambda (filein)
- (let* ((result (lex1 filein))
- (<<EOF>>-action (car result))
- (<<ERROR>>-action (cadr result))
- (rules (cddr result)))
-; (display "lex2: ") (write (get-internal-run-time)) (newline)
- (append (list <<EOF>>-action <<ERROR>>-action rules)
- (re2nfa rules)))))
-
-(define lex3
- (lambda (filein)
- (let* ((result (lex2 filein))
- (<<EOF>>-action (list-ref result 0))
- (<<ERROR>>-action (list-ref result 1))
- (rules (list-ref result 2))
- (nl-start (list-ref result 3))
- (no-nl-start (list-ref result 4))
- (arcs (list-ref result 5))
- (acc (list-ref result 6)))
-; (display "lex3: ") (write (get-internal-run-time)) (newline)
- (append (list <<EOF>>-action <<ERROR>>-action rules)
- (noeps nl-start no-nl-start arcs acc)))))
-
-(define lex4
- (lambda (filein)
- (let* ((result (lex3 filein))
- (<<EOF>>-action (list-ref result 0))
- (<<ERROR>>-action (list-ref result 1))
- (rules (list-ref result 2))
- (nl-start (list-ref result 3))
- (no-nl-start (list-ref result 4))
- (arcs (list-ref result 5))
- (acc (list-ref result 6)))
-; (display "lex4: ") (write (get-internal-run-time)) (newline)
- (append (list <<EOF>>-action <<ERROR>>-action rules)
- (sweep nl-start no-nl-start arcs acc)))))
-
-(define lex5
- (lambda (filein)
- (let* ((result (lex4 filein))
- (<<EOF>>-action (list-ref result 0))
- (<<ERROR>>-action (list-ref result 1))
- (rules (list-ref result 2))
- (nl-start (list-ref result 3))
- (no-nl-start (list-ref result 4))
- (arcs (list-ref result 5))
- (acc (list-ref result 6)))
-; (display "lex5: ") (write (get-internal-run-time)) (newline)
- (append (list <<EOF>>-action <<ERROR>>-action rules)
- (nfa2dfa nl-start no-nl-start arcs acc)))))
-
-(define lex6
- (lambda (args-alist)
- (let* ((filein (cdr (assq 'filein args-alist)))
- (result (lex5 filein))
- (<<EOF>>-action (list-ref result 0))
- (<<ERROR>>-action (list-ref result 1))
- (rules (list-ref result 2))
- (nl-start (list-ref result 3))
- (no-nl-start (list-ref result 4))
- (arcs (list-ref result 5))
- (acc (list-ref result 6)))
-; (display "lex6: ") (write (get-internal-run-time)) (newline)
- (prep-set-rules-yytext? rules)
- (output args-alist
- <<EOF>>-action <<ERROR>>-action
- rules nl-start no-nl-start arcs acc)
- #t)))
-
-(define lex7
- (lambda (args)
- (call-with-current-continuation
- (lambda (exit)
- (set! lex-exit-continuation exit)
- (set! lex-unwind-protect-list '())
- (set! lex-error-filename (cadr (memq 'filein args)))
- (let* ((args-alist (lex-parse-args args))
- (result (lex6 args-alist)))
-; (display "lex7: ") (write (get-internal-run-time)) (newline)
- result)))))
-
-
-
-
-;
-; Fonctions principales
-;
-
-(define lex
- (lambda (filein fileout . options)
- (lex7 (append (list 'complete-driver? #t
- 'filein filein
- 'table-name "lexer-default-table"
- 'fileout fileout)
- options))))
-
-(define lex-tables
- (lambda (filein table-name fileout . options)
- (lex7 (append (list 'complete-driver? #f
- 'filein filein
- 'table-name table-name
- 'fileout fileout)
- options))))
-
-)
Trap