feat: 9.5.9
This commit is contained in:
tmtt
parent
cb1753732b
commit
35f43a7909
1084 changed files with 558985 additions and 0 deletions
1
s/.gitattributes
vendored
Normal file
1
s/.gitattributes
vendored
Normal file
|
|
@ -0,0 +1 @@
|
|||
update-revision export-subst
|
||||
421
s/4.ss
Normal file
421
s/4.ss
Normal file
|
|
@ -0,0 +1,421 @@
|
|||
;;; 4.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who apply
|
||||
(let ()
|
||||
(define-syntax build-apply
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ () cl ...)
|
||||
#'(case-lambda
|
||||
[(p r)
|
||||
(unless (procedure? p)
|
||||
($oops #f "attempt to apply non-procedure ~s" p))
|
||||
(let ([n ($list-length r who)])
|
||||
(case n
|
||||
[(0) (p)]
|
||||
[(1) (p (car r))]
|
||||
[(2) (p (car r) (cadr r))]
|
||||
[(3) (let ([y1 (cdr r)]) (p (car r) (car y1) (cadr y1)))]
|
||||
[else ($apply p n r)]))]
|
||||
cl ...
|
||||
[(p x . r)
|
||||
(unless (procedure? p)
|
||||
($oops #f "attempt to apply non-procedure ~s" p))
|
||||
(let ([r (cons x ($apply list* ($list-length r who) r))])
|
||||
($apply p ($list-length r who) r))])]
|
||||
[(_ (s1 s2 ...) cl ...)
|
||||
(with-syntax ((m (length #'(s1 s2 ...))))
|
||||
#'(build-apply
|
||||
(s2 ...)
|
||||
[(p s1 s2 ... r)
|
||||
(unless (procedure? p)
|
||||
($oops #f "attempt to apply non-procedure ~s" p))
|
||||
(let ([n ($list-length r who)])
|
||||
(case n
|
||||
[(0) (p s1 s2 ...)]
|
||||
[(1) (p s1 s2 ... (car r))]
|
||||
[(2) (p s1 s2 ... (car r) (cadr r))]
|
||||
[(3) (let ([y1 (cdr r)])
|
||||
(p s1 s2 ... (car r) (car y1) (cadr y1)))]
|
||||
[else ($apply p (fx+ n m) (list* s1 s2 ... r))]))]
|
||||
cl ...))])))
|
||||
(build-apply (x1 x2 x3 x4))))
|
||||
|
||||
(let ()
|
||||
(define length-error
|
||||
(lambda (who l1 l2)
|
||||
($oops who "lists ~s and ~s differ in length" l1 l2)))
|
||||
|
||||
(define nonprocedure-error
|
||||
(lambda (who what)
|
||||
($oops who "~s is not a procedure" what)))
|
||||
|
||||
(define length-check
|
||||
(lambda (who first rest)
|
||||
(let ([n ($list-length first who)])
|
||||
(let loop ([rest rest])
|
||||
(cond
|
||||
[(null? rest) n]
|
||||
[(fx= ($list-length (car rest) who) n) (loop (cdr rest))]
|
||||
[else (length-error who first (car rest))])))))
|
||||
|
||||
(define mutation-error
|
||||
(lambda (who)
|
||||
($oops who "input list was altered during operation")))
|
||||
|
||||
; getcxrs returns the cdrs of ls and their cars
|
||||
(define getcxrs
|
||||
(lambda (ls who)
|
||||
(if (null? ls)
|
||||
(values '() '())
|
||||
(let-values ([(cdrs cars) (getcxrs (cdr ls) who)])
|
||||
(let ([d (cdar ls)])
|
||||
(unless (pair? d) (mutation-error who))
|
||||
(values (cons d cdrs) (cons (car d) cars)))))))
|
||||
|
||||
(let ()
|
||||
(define-syntax do-ormap
|
||||
(syntax-rules ()
|
||||
[(_ who)
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(and (not (null? ls))
|
||||
(let ormap ([n ($list-length ls who)] [ls ls])
|
||||
(if (fx= n 1)
|
||||
(f (car ls))
|
||||
(or (f (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(ormap (fx- n 1) ls))))))]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(let ([n (length-check who ls more)])
|
||||
(and (not (fx= n 0))
|
||||
(let ormap ([n n] [ls ls] [more more] [cars (map car more)])
|
||||
(if (fx= n 1)
|
||||
(apply f (car ls) cars)
|
||||
(or (apply f (car ls) cars)
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(ormap (fx- n 1) ls cdrs cars))))))))])]))
|
||||
(set-who! ormap (do-ormap who))
|
||||
(set-who! exists (do-ormap who)))
|
||||
|
||||
(let ()
|
||||
(define-syntax do-andmap
|
||||
(syntax-rules ()
|
||||
[(_ who)
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(or (null? ls)
|
||||
(let andmap ([n ($list-length ls who)] [ls ls])
|
||||
(if (fx= n 1)
|
||||
(f (car ls))
|
||||
(and (f (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(andmap (fx- n 1) ls))))))]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(let ([n (length-check who ls more)])
|
||||
(or (fx= n 0)
|
||||
(let andmap ([n n] [ls ls] [more more] [cars (map car more)])
|
||||
(if (fx= n 1)
|
||||
(apply f (car ls) cars)
|
||||
(and (apply f (car ls) cars)
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(andmap (fx- n 1) ls cdrs cars))))))))])]))
|
||||
(set-who! andmap (do-andmap who))
|
||||
(set-who! for-all (do-andmap who)))
|
||||
|
||||
(set-who! map
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
($list-length ls who)
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls)]
|
||||
[(f ls1 ls2)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
|
||||
(length-error who ls1 ls2))
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls1 ls2)]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(length-check who ls more)
|
||||
(let map ([f f] [ls ls] [more more])
|
||||
(if (null? ls)
|
||||
'()
|
||||
; cdr first to avoid getting sick if f mutates input
|
||||
(let ([tail (map f (cdr ls) (#3%map cdr more))])
|
||||
(cons (apply f (car ls) (#3%map car more)) tail))))]))
|
||||
|
||||
(set! $map
|
||||
; same as map but errors are reported as coming from who
|
||||
(case-lambda
|
||||
[(who f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
($list-length ls who)
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls)]
|
||||
[(who f ls1 ls2)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
|
||||
(length-error who ls1 ls2))
|
||||
; library map cdrs first to avoid getting sick if f mutates input
|
||||
(#3%map f ls1 ls2)]
|
||||
[(who f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(length-check who ls more)
|
||||
(let map ([f f] [ls ls] [more more])
|
||||
(if (null? ls)
|
||||
'()
|
||||
; cdr first to avoid getting sick if f mutates input
|
||||
(let ([tail (map f (cdr ls) (#3%map cdr more))])
|
||||
(cons (apply f (car ls) (#3%map car more)) tail))))]))
|
||||
|
||||
(set-who! for-each
|
||||
(case-lambda
|
||||
[(f ls)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(unless (null? ls)
|
||||
(let for-each ([n ($list-length ls who)] [ls ls])
|
||||
(if (fx= n 1)
|
||||
(f (car ls))
|
||||
(begin
|
||||
(f (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(for-each (fx- n 1) ls))))))]
|
||||
[(f ls . more)
|
||||
(unless (procedure? f) (nonprocedure-error who f))
|
||||
(let ([n (length-check who ls more)])
|
||||
(unless (fx= n 0)
|
||||
(let for-each ([n n] [ls ls] [more more] [cars (map car more)])
|
||||
(if (fx= n 1)
|
||||
(apply f (car ls) cars)
|
||||
(begin
|
||||
(apply f (car ls) cars)
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (pair? ls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(for-each (fx- n 1) ls cdrs cars))))))))]))
|
||||
|
||||
(set-who! fold-left
|
||||
(case-lambda
|
||||
[(combine nil ls)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(cond
|
||||
[(null? ls) nil]
|
||||
[else
|
||||
($list-length ls who)
|
||||
(let fold-left ([ls ls] [acc nil])
|
||||
(let ([cdrls (cdr ls)])
|
||||
(if (pair? cdrls)
|
||||
(fold-left cdrls (combine acc (car ls)))
|
||||
(if (null? cdrls)
|
||||
(combine acc (car ls))
|
||||
(mutation-error who)))))])]
|
||||
[(combine nil ls . more)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(length-check who ls more)
|
||||
(if (null? ls)
|
||||
nil
|
||||
(let fold-left ([ls ls] [more more] [cars (map car more)] [acc nil])
|
||||
(let ([cdrls (cdr ls)])
|
||||
(if (null? cdrls)
|
||||
(apply combine acc (car ls) cars)
|
||||
(let ([acc (apply combine acc (car ls) cars)])
|
||||
(unless (pair? cdrls) (mutation-error who))
|
||||
(let-values ([(cdrs cars) (getcxrs more who)])
|
||||
(fold-left cdrls cdrs cars acc)))))))]))
|
||||
|
||||
(set-who! fold-right
|
||||
(case-lambda
|
||||
[(combine nil ls)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
($list-length ls who)
|
||||
; #3%fold-right naturally does cdrs first to avoid mutation sickness
|
||||
(#3%fold-right combine nil ls)]
|
||||
[(combine nil ls1 ls2)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(unless (fx= ($list-length ls1 who) ($list-length ls2 who))
|
||||
(length-error who ls1 ls2))
|
||||
; #3%fold-right naturally does cdrs first to avoid mutation sickness
|
||||
(#3%fold-right combine nil ls1 ls2)]
|
||||
[(combine nil ls . more)
|
||||
(unless (procedure? combine) (nonprocedure-error who combine))
|
||||
(length-check who ls more)
|
||||
(let fold-right ([combine combine] [nil nil] [ls ls] [more more])
|
||||
(if (null? ls)
|
||||
nil
|
||||
(apply combine (car ls)
|
||||
(#3%fold-right cons
|
||||
(list (fold-right combine nil (cdr ls) (map cdr more)))
|
||||
(map car more)))))]))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define disable/enable (make-winder #f disable-interrupts enable-interrupts))
|
||||
|
||||
(define (dwind in body out)
|
||||
(let ((old-winders ($current-winders)))
|
||||
(in)
|
||||
($current-winders (cons (make-winder #f in out) old-winders))
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
[(x)
|
||||
($current-winders old-winders)
|
||||
(out)
|
||||
x]
|
||||
[args
|
||||
($current-winders old-winders)
|
||||
(out)
|
||||
(apply values args)]))))
|
||||
|
||||
(define (cwind in body out)
|
||||
(let* ((old-winders ($current-winders))
|
||||
[d/e+old-winders (cons disable/enable old-winders)])
|
||||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(in)
|
||||
($current-winders (cons (make-winder #t in out) old-winders))
|
||||
(enable-interrupts)
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
[(x)
|
||||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(out)
|
||||
($current-winders old-winders)
|
||||
(enable-interrupts)
|
||||
x]
|
||||
[args
|
||||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(out)
|
||||
($current-winders old-winders)
|
||||
(enable-interrupts)
|
||||
(apply values args)]))))
|
||||
|
||||
(define (check-args in body out)
|
||||
(unless (procedure? in)
|
||||
($oops 'dynamic-wind "~s is not a procedure" in))
|
||||
(unless (procedure? body)
|
||||
($oops 'dynamic-wind "~s is not a procedure" body))
|
||||
(unless (procedure? out)
|
||||
($oops 'dynamic-wind "~s is not a procedure" out)))
|
||||
|
||||
(set! dynamic-wind
|
||||
(case-lambda
|
||||
[(in body out)
|
||||
(check-args in body out)
|
||||
(dwind in body out)]
|
||||
[(critical? in body out)
|
||||
(check-args in body out)
|
||||
(if critical?
|
||||
(cwind in body out)
|
||||
(dwind in body out))]))
|
||||
|
||||
(set-who! #(r6rs: dynamic-wind)
|
||||
(lambda (in body out)
|
||||
(#2%dynamic-wind in body out)))
|
||||
|
||||
(set! $do-wind
|
||||
(lambda (old new)
|
||||
(define common-tail
|
||||
(lambda (x y)
|
||||
(let ([lx (length x)] [ly (length y)])
|
||||
(do ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x) (cdr x)]
|
||||
[y (if (fx> ly lx) (list-tail y (fx- ly lx)) y) (cdr y)])
|
||||
((eq? x y) x)))))
|
||||
(let ([tail (common-tail old new)])
|
||||
(let f ((old old))
|
||||
(unless (eq? old tail)
|
||||
(let ([w (car old)] [old (cdr old)])
|
||||
(if (winder-critical? w)
|
||||
(begin
|
||||
(disable-interrupts)
|
||||
($current-winders (cons disable/enable old))
|
||||
((winder-out w))
|
||||
($current-winders old)
|
||||
(enable-interrupts))
|
||||
(begin
|
||||
($current-winders old)
|
||||
((winder-out w))))
|
||||
(f old))))
|
||||
(let f ([new new])
|
||||
(unless (eq? new tail)
|
||||
(let ([w (car new)])
|
||||
(f (cdr new))
|
||||
(if (winder-critical? w)
|
||||
(begin
|
||||
(disable-interrupts)
|
||||
($current-winders (cons disable/enable (cdr new)))
|
||||
((winder-in w))
|
||||
($current-winders new)
|
||||
(enable-interrupts))
|
||||
(begin
|
||||
((winder-in w))
|
||||
($current-winders new)))))))))
|
||||
)
|
||||
|
||||
|
||||
;;; make-promise and force
|
||||
|
||||
(define-who $make-promise
|
||||
(lambda (thunk)
|
||||
(unless (procedure? thunk)
|
||||
($oops who "~s is not a procedure" thunk))
|
||||
(let ([value (void)] [set? #f])
|
||||
(lambda ()
|
||||
(case set?
|
||||
[(single) value]
|
||||
[(multiple) (apply values value)]
|
||||
[else
|
||||
(call-with-values
|
||||
thunk
|
||||
(case-lambda
|
||||
[(x)
|
||||
(case set?
|
||||
[(single) value]
|
||||
[(multiple) (apply values value)]
|
||||
[(#f) (set! value x)
|
||||
(set! set? 'single)
|
||||
x])]
|
||||
[x
|
||||
(case set?
|
||||
[(single) value]
|
||||
[(multiple) (apply values value)]
|
||||
[(#f) (set! value x)
|
||||
(set! set? 'multiple)
|
||||
(apply values x)])]))])))))
|
||||
|
||||
(define-who force
|
||||
(lambda (promise)
|
||||
(unless (procedure? promise)
|
||||
($oops who "~s is not a procedure" promise))
|
||||
(promise)))
|
||||
)
|
||||
335
s/5_1.ss
Normal file
335
s/5_1.ss
Normal file
|
|
@ -0,0 +1,335 @@
|
|||
;;; 5_1.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; type and generic predicates
|
||||
|
||||
(begin
|
||||
(define boolean?
|
||||
(lambda (x)
|
||||
(or (eq? x #t) (eq? x #f))))
|
||||
|
||||
(define not
|
||||
(lambda (x)
|
||||
(if x #f #t)))
|
||||
|
||||
(define eqv?
|
||||
(lambda (x y)
|
||||
(eqv? x y)))
|
||||
|
||||
(define (equal? x y)
|
||||
(define k0 200)
|
||||
(define kb -20)
|
||||
|
||||
#;(define (union-find ht x y) ; hashtable-ref/set! version
|
||||
(define (find b) ; splitting
|
||||
(let ([n (car b)]) ; next or census
|
||||
(if (pair? n)
|
||||
(let loop ([b b] [n n])
|
||||
(let ([nn (car n)])
|
||||
(if (pair? nn)
|
||||
(begin (set-car! b nn) (loop n nn))
|
||||
n)))
|
||||
b)))
|
||||
(let ([bx (eq-hashtable-ref ht x #f)]
|
||||
[by (eq-hashtable-ref ht y #f)])
|
||||
(if (not bx)
|
||||
(if (not by)
|
||||
(let ([b (list 1)])
|
||||
(eq-hashtable-set! ht x b)
|
||||
(eq-hashtable-set! ht y b)
|
||||
#f)
|
||||
(begin
|
||||
(eq-hashtable-set! ht x (find by))
|
||||
#f))
|
||||
(if (not by)
|
||||
(begin
|
||||
(eq-hashtable-set! ht y (find bx))
|
||||
#f)
|
||||
(let ([rx (find bx)] [ry (find by)])
|
||||
(or (eq? rx ry)
|
||||
(let ([nx (car rx)] [ny (car ry)])
|
||||
(if (fx> nx ny)
|
||||
(begin
|
||||
(set-car! ry rx)
|
||||
(set-car! rx (fx+ nx ny))
|
||||
#f)
|
||||
(begin
|
||||
(set-car! rx ry)
|
||||
(set-car! ry (fx+ ny nx))
|
||||
#f)))))))))
|
||||
|
||||
(define (union-find ht x y) ; htcell version
|
||||
(define (find p n) ; splitting
|
||||
(if (pair? n)
|
||||
(let loop ([p p] [n n])
|
||||
(let ([nn (cdr n)])
|
||||
(if (pair? nn)
|
||||
(begin (set-cdr! p nn) (loop n nn))
|
||||
n)))
|
||||
p))
|
||||
(let ([ax (eq-hashtable-cell ht x 0)]
|
||||
[ay (eq-hashtable-cell ht y 0)])
|
||||
(let ([nx (cdr ax)] [ny (cdr ay)])
|
||||
(if (eq? nx 0)
|
||||
(if (eq? ny 0)
|
||||
(begin
|
||||
(set-cdr! ax ay)
|
||||
(set-cdr! ay 1)
|
||||
#f)
|
||||
(begin
|
||||
(set-cdr! ax (find ay ny))
|
||||
#f))
|
||||
(if (eq? ny 0)
|
||||
(begin
|
||||
(set-cdr! ay (find ax nx))
|
||||
#f)
|
||||
(let ([rx (find ax nx)] [ry (find ay ny)])
|
||||
(or (eq? rx ry)
|
||||
(let ([nx (cdr rx)] [ny (cdr ry)])
|
||||
(if (fx> nx ny)
|
||||
(begin
|
||||
(set-cdr! ry rx)
|
||||
(set-cdr! rx (fx+ nx ny))
|
||||
#f)
|
||||
(begin
|
||||
(set-cdr! rx ry)
|
||||
(set-cdr! ry (fx+ ny nx))
|
||||
#f))))))))))
|
||||
|
||||
(define (interleave? x y k)
|
||||
(let ([ht (make-eq-hashtable)])
|
||||
(define (e? x y k)
|
||||
(if (fx<= k 0)
|
||||
(if (fx= k kb)
|
||||
(fast? x y (random (* 2 k0)))
|
||||
(slow? x y k))
|
||||
(fast? x y k)))
|
||||
(define (slow? x y k)
|
||||
(cond
|
||||
[(eq? x y) k]
|
||||
[(pair? x)
|
||||
(and (pair? y)
|
||||
(if (union-find ht x y)
|
||||
0
|
||||
(let ([k (e? (car x) (car y) (fx- k 1))])
|
||||
(and k (e? (cdr x) (cdr y) k)))))]
|
||||
[(vector? x)
|
||||
(and (vector? y)
|
||||
(let ([n (vector-length x)])
|
||||
(and (fx= (vector-length y) n)
|
||||
(if (union-find ht x y)
|
||||
0
|
||||
(let f ([i 0] [k (fx- k 1)])
|
||||
(if (fx= i n)
|
||||
k
|
||||
(let ([k (e? (vector-ref x i) (vector-ref y i) k)])
|
||||
(and k (f (fx+ i 1) k)))))))))]
|
||||
[(string? x) (and (string? y) (string=? x y) k)]
|
||||
[(flonum? x) (and (flonum? y) ($fleqv? x y) k)]
|
||||
[($inexactnum? x)
|
||||
(and ($inexactnum? y)
|
||||
($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
|
||||
($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y))
|
||||
k)]
|
||||
[(bignum? x) (and (bignum? y) (= x y) k)]
|
||||
[(ratnum? x) (and (ratnum? y) (= x y) k)]
|
||||
[($exactnum? x) (and ($exactnum? y) (= x y) k)]
|
||||
[(bytevector? x) (and (bytevector? y) (bytevector=? x y) k)]
|
||||
[(fxvector? x)
|
||||
(and (fxvector? y)
|
||||
(fx= (fxvector-length x) (fxvector-length y))
|
||||
(let f ([i (fx- (fxvector-length x) 1)])
|
||||
(if (fx< i 0)
|
||||
k
|
||||
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
|
||||
(f (fx1- i))))))]
|
||||
[(box? x)
|
||||
(and (box? y)
|
||||
(if (union-find ht x y)
|
||||
0
|
||||
(e? (unbox x) (unbox y) (fx- k 1))))]
|
||||
[($record? x)
|
||||
(and ($record? y)
|
||||
(let ([rec-equal? ($record-equal-procedure x y)])
|
||||
(and rec-equal?
|
||||
(if (union-find ht x y)
|
||||
0
|
||||
(let ([next-k k] [decr 1])
|
||||
(and (rec-equal? x y
|
||||
(lambda (x1 y1)
|
||||
; decrementing only on first subfield, if any, like vectors and pairs
|
||||
(let ([k (e? x1 y1 (fx- next-k decr))])
|
||||
(and k
|
||||
(begin
|
||||
(set! next-k k)
|
||||
(set! decr 0)
|
||||
#t)))))
|
||||
next-k))))))]
|
||||
[else (and (eqv? x y) k)]))
|
||||
(define (fast? x y k)
|
||||
(let ([k (fx- k 1)])
|
||||
(cond
|
||||
[(eq? x y) k]
|
||||
[(pair? x)
|
||||
(and (pair? y)
|
||||
(let ([k (e? (car x) (car y) k)])
|
||||
(and k (e? (cdr x) (cdr y) k))))]
|
||||
[(vector? x)
|
||||
(and (vector? y)
|
||||
(let ([n (vector-length x)])
|
||||
(and (fx= (vector-length y) n)
|
||||
(let f ([i 0] [k k])
|
||||
(if (fx= i n)
|
||||
k
|
||||
(let ([k (e? (vector-ref x i) (vector-ref y i) k)])
|
||||
(and k (f (fx+ i 1) k))))))))]
|
||||
[(string? x) (and (string? y) (string=? x y) k)]
|
||||
[(flonum? x) (and (flonum? y) ($fleqv? x y) k)]
|
||||
[($inexactnum? x)
|
||||
(and ($inexactnum? y)
|
||||
($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
|
||||
($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y))
|
||||
k)]
|
||||
[(bignum? x) (and (bignum? y) (= x y) k)]
|
||||
[(ratnum? x) (and (ratnum? y) (= x y) k)]
|
||||
[($exactnum? x) (and ($exactnum? y) (= x y) k)]
|
||||
[(bytevector? x) (and (bytevector? y) (bytevector=? x y) k)]
|
||||
[(fxvector? x)
|
||||
(and (fxvector? y)
|
||||
(fx= (fxvector-length x) (fxvector-length y))
|
||||
(let f ([i (fx- (fxvector-length x) 1)])
|
||||
(if (fx< i 0)
|
||||
k
|
||||
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
|
||||
(f (fx1- i))))))]
|
||||
[(box? x) (and (box? y) (e? (unbox x) (unbox y) k))]
|
||||
[($record? x)
|
||||
(and ($record? y)
|
||||
(let ([rec-equal? ($record-equal-procedure x y)])
|
||||
(and rec-equal?
|
||||
(let ([next-k k])
|
||||
(and (rec-equal? x y
|
||||
(lambda (x1 y1)
|
||||
(let ([k (e? x1 y1 next-k)])
|
||||
(and k
|
||||
(begin
|
||||
(set! next-k k)
|
||||
#t)))))
|
||||
next-k)))))]
|
||||
[else (and (eqv? x y) k)])))
|
||||
(and (e? x y k) #t)))
|
||||
|
||||
(define (precheck? x y k)
|
||||
(cond
|
||||
[(eq? x y) k]
|
||||
[(pair? x)
|
||||
(and (pair? y)
|
||||
(if (fx<= k 0)
|
||||
k
|
||||
(let ([k (precheck? (car x) (car y) (fx- k 1))])
|
||||
(and k (precheck? (cdr x) (cdr y) k)))))]
|
||||
[(vector? x)
|
||||
(and (vector? y)
|
||||
(let ([n (vector-length x)])
|
||||
(and (fx= (vector-length y) n)
|
||||
(let f ([i 0] [k k])
|
||||
(if (or (fx= i n) (fx<= k 0))
|
||||
k
|
||||
(let ([k (precheck?
|
||||
(vector-ref x i)
|
||||
(vector-ref y i)
|
||||
(fx- k 1))])
|
||||
(and k (f (fx+ i 1) k))))))))]
|
||||
[(string? x) (and (string? y) (string=? x y) k)]
|
||||
[(flonum? x) (and (flonum? y) ($fleqv? x y) k)]
|
||||
[($inexactnum? x)
|
||||
(and ($inexactnum? y)
|
||||
($fleqv? ($inexactnum-real-part x) ($inexactnum-real-part y))
|
||||
($fleqv? ($inexactnum-imag-part x) ($inexactnum-imag-part y))
|
||||
k)]
|
||||
[(bignum? x) (and (bignum? y) (= x y) k)]
|
||||
[(ratnum? x) (and (ratnum? y) (= x y) k)]
|
||||
[($exactnum? x) (and ($exactnum? y) (= x y) k)]
|
||||
[(bytevector? x) (and (bytevector? y) (bytevector=? x y) k)]
|
||||
[(fxvector? x)
|
||||
(and (fxvector? y)
|
||||
(fx= (fxvector-length x) (fxvector-length y))
|
||||
(let f ([i (fx- (fxvector-length x) 1)])
|
||||
(if (fx< i 0)
|
||||
k
|
||||
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
|
||||
(f (fx1- i))))))]
|
||||
[(box? x)
|
||||
(and (box? y)
|
||||
(if (fx<= k 0)
|
||||
k
|
||||
(precheck? (unbox x) (unbox y) (fx- k 1))))]
|
||||
[($record? x)
|
||||
(and ($record? y)
|
||||
(let ([rec-equal? ($record-equal-procedure x y)])
|
||||
(and rec-equal?
|
||||
(if (fx<= k 0)
|
||||
k
|
||||
(let ([next-k k])
|
||||
(and (rec-equal? x y
|
||||
(lambda (x1 y1)
|
||||
; decrementing k for each field, like vectors but unlike pairs
|
||||
(let ([k (precheck? x1 y1 (fx- next-k 1))])
|
||||
(and k
|
||||
(begin
|
||||
(set! next-k k)
|
||||
#t)))))
|
||||
next-k))))))]
|
||||
[else (and (eqv? x y) k)]))
|
||||
|
||||
(let ([k (precheck? x y k0)])
|
||||
(and k (or (fx> k 0) (interleave? x y 0)))))
|
||||
|
||||
(define boolean=?
|
||||
(case-lambda
|
||||
[(b1 b2)
|
||||
(unless (boolean? b1) ($oops 'boolean=? "~s is not a boolean" b1))
|
||||
(unless (boolean? b2) ($oops 'boolean=? "~s is not a boolean" b2))
|
||||
(#3%boolean=? b1 b2)]
|
||||
[(b1 b2 . b*)
|
||||
(unless (boolean? b1) ($oops 'boolean=? "~s is not a boolean" b1))
|
||||
(unless (boolean? b2) ($oops 'boolean=? "~s is not a boolean" b2))
|
||||
(for-each
|
||||
(lambda (b) (unless (boolean? b) ($oops 'boolean=? "~s is not a boolean" b)))
|
||||
b*)
|
||||
(and (#3%boolean=? b1 b2)
|
||||
(let f ([b* b*])
|
||||
(or (null? b*)
|
||||
(and (#3%boolean=? (car b*) b1)
|
||||
(f (cdr b*))))))]))
|
||||
|
||||
(define symbol=?
|
||||
(case-lambda
|
||||
[(s1 s2)
|
||||
(unless (symbol? s1) ($oops 'symbol=? "~s is not a symbol" s1))
|
||||
(unless (symbol? s2) ($oops 'symbol=? "~s is not a symbol" s2))
|
||||
(#3%symbol=? s1 s2)]
|
||||
[(s1 s2 . s*)
|
||||
(unless (symbol? s1) ($oops 'symbol=? "~s is not a symbol" s1))
|
||||
(unless (symbol? s2) ($oops 'symbol=? "~s is not a symbol" s2))
|
||||
(for-each
|
||||
(lambda (s) (unless (symbol? s) ($oops 'symbol=? "~s is not a symbol" s)))
|
||||
s*)
|
||||
(and (#3%symbol=? s1 s2)
|
||||
(let f ([s* s*])
|
||||
(or (null? s*)
|
||||
(and (#3%symbol=? (car s*) s1)
|
||||
(f (cdr s*))))))]))
|
||||
)
|
||||
795
s/5_2.ss
Normal file
795
s/5_2.ss
Normal file
|
|
@ -0,0 +1,795 @@
|
|||
;;; 5_2.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; list and pair functions
|
||||
|
||||
(begin
|
||||
(define atom?
|
||||
(lambda (x)
|
||||
(not (pair? x))))
|
||||
|
||||
(define list?
|
||||
(lambda (x)
|
||||
(let loop ([hare x] [tortoise x])
|
||||
(if (pair? hare)
|
||||
(let ([hare (cdr hare)])
|
||||
(if (pair? hare)
|
||||
(and (not (eq? hare tortoise))
|
||||
(loop (cdr hare) (cdr tortoise)))
|
||||
(null? hare)))
|
||||
(null? hare)))))
|
||||
|
||||
(define null?
|
||||
(lambda (x)
|
||||
(eq? x '())))
|
||||
|
||||
(define caar (lambda (x) (#2%caar x)))
|
||||
(define cadr (lambda (x) (#2%cadr x)))
|
||||
(define cdar (lambda (x) (#2%cdar x)))
|
||||
(define cddr (lambda (x) (#2%cddr x)))
|
||||
(define caaar (lambda (x) (#2%caaar x)))
|
||||
(define caadr (lambda (x) (#2%caadr x)))
|
||||
(define cadar (lambda (x) (#2%cadar x)))
|
||||
(define caddr (lambda (x) (#2%caddr x)))
|
||||
(define cdaar (lambda (x) (#2%cdaar x)))
|
||||
(define cdadr (lambda (x) (#2%cdadr x)))
|
||||
(define cddar (lambda (x) (#2%cddar x)))
|
||||
(define cdddr (lambda (x) (#2%cdddr x)))
|
||||
(define caaaar (lambda (x) (#2%caaaar x)))
|
||||
(define caaadr (lambda (x) (#2%caaadr x)))
|
||||
(define caadar (lambda (x) (#2%caadar x)))
|
||||
(define caaddr (lambda (x) (#2%caaddr x)))
|
||||
(define cadaar (lambda (x) (#2%cadaar x)))
|
||||
(define cadadr (lambda (x) (#2%cadadr x)))
|
||||
(define caddar (lambda (x) (#2%caddar x)))
|
||||
(define cadddr (lambda (x) (#2%cadddr x)))
|
||||
(define cdaaar (lambda (x) (#2%cdaaar x)))
|
||||
(define cdaadr (lambda (x) (#2%cdaadr x)))
|
||||
(define cdadar (lambda (x) (#2%cdadar x)))
|
||||
(define cdaddr (lambda (x) (#2%cdaddr x)))
|
||||
(define cddaar (lambda (x) (#2%cddaar x)))
|
||||
(define cddadr (lambda (x) (#2%cddadr x)))
|
||||
(define cdddar (lambda (x) (#2%cdddar x)))
|
||||
(define cddddr (lambda (x) (#2%cddddr x)))
|
||||
|
||||
(define $list-length)
|
||||
(define length)
|
||||
(define list-ref)
|
||||
(define list-tail)
|
||||
(define list-head)
|
||||
|
||||
(let ()
|
||||
(define improper-list-error
|
||||
(lambda (who ls)
|
||||
($oops who "~s is not a proper list" ls)))
|
||||
(define circular-list-error
|
||||
(lambda (who ls)
|
||||
($oops who "~s is circular" ls)))
|
||||
(define index-range-error
|
||||
(lambda (who ls n)
|
||||
($oops who "index ~s is out of range for list ~s" n ls)))
|
||||
(define index-type-error
|
||||
(lambda (who n)
|
||||
($oops who "index ~s is not an exact nonnegative integer" n)))
|
||||
(define index-range/improper-list-error
|
||||
(lambda (who tail ls n)
|
||||
(if (null? tail)
|
||||
(index-range-error who ls n)
|
||||
(improper-list-error who ls))))
|
||||
(define list-length
|
||||
(lambda (ls who)
|
||||
(let loop ([hare ls] [i 0])
|
||||
(if (pair? hare)
|
||||
(let ([hare (cdr hare)])
|
||||
(if (pair? hare)
|
||||
(if (fx<= i 10000)
|
||||
(loop (cdr hare) (fx+ i 2))
|
||||
(let loop ([hare hare] [tortoise hare] [i (fx+ i 1)])
|
||||
(if (pair? hare)
|
||||
(let ([hare (cdr hare)])
|
||||
(if (pair? hare)
|
||||
(if (eq? hare tortoise)
|
||||
(circular-list-error who ls)
|
||||
(loop (cdr hare)
|
||||
(cdr tortoise)
|
||||
(fx+ i 2)))
|
||||
(if (null? hare)
|
||||
(fx+ i 1)
|
||||
(improper-list-error who ls))))
|
||||
(if (null? hare)
|
||||
i
|
||||
(improper-list-error who ls)))))
|
||||
(if (null? hare)
|
||||
(fx+ i 1)
|
||||
(improper-list-error who ls))))
|
||||
(if (null? hare)
|
||||
i
|
||||
(improper-list-error who ls))))))
|
||||
(define list-tail-cycle
|
||||
(lambda (ls n)
|
||||
(let loop ((fast (cdr ls)) (i 1))
|
||||
(if (eq? fast ls)
|
||||
(let ((i (remainder n i)))
|
||||
(do ((ls ls (cdr ls)) (i i (fx- i 1)))
|
||||
((fx= i 0) ls)))
|
||||
(loop (cdr fast) (fx+ i 1))))))
|
||||
(define fx-list-tail
|
||||
(lambda (fast slow i)
|
||||
(if (fx> i 0)
|
||||
(if (pair? fast)
|
||||
(let ((fast (cdr fast)))
|
||||
(if (fx> i 1)
|
||||
(if (not (eq? fast slow))
|
||||
(if (pair? fast)
|
||||
(fx-list-tail (cdr fast) (cdr slow) (fx- i 2))
|
||||
(values 'error fast i))
|
||||
(values 'cycle fast (fx- i 1)))
|
||||
(values 'okay fast (fx- i 1))))
|
||||
(values 'error fast i))
|
||||
(values 'okay fast i))))
|
||||
(set! $list-length (lambda (ls who) (list-length ls who)))
|
||||
(set! length
|
||||
(lambda (ls)
|
||||
(list-length ls 'length)))
|
||||
(set! list-ref
|
||||
(lambda (ls n)
|
||||
(cond
|
||||
[(and (fixnum? n) (fx<= 0 n 1000))
|
||||
(let loop ([l ls] [i n])
|
||||
(if (pair? l)
|
||||
(if (fx> i 1)
|
||||
(let ([l (cdr l)])
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (fx- i 2))
|
||||
(index-range/improper-list-error 'list-ref l ls n)))
|
||||
(if (fx= i 0)
|
||||
(car l)
|
||||
(let ([l (cdr l)])
|
||||
(if (pair? l)
|
||||
(car l)
|
||||
(index-range/improper-list-error 'list-ref l ls n)))))
|
||||
(index-range/improper-list-error 'list-ref l ls n)))]
|
||||
[(and (or (fixnum? n) (bignum? n)) (>= n 0))
|
||||
(let ((m (min n (most-positive-fixnum))))
|
||||
(call-with-values
|
||||
(lambda () (fx-list-tail ls ls m))
|
||||
(lambda (what fast i)
|
||||
(cond
|
||||
[(and (eq? what 'okay) (pair? fast))
|
||||
; can't happen with bignum input
|
||||
(car fast)]
|
||||
[(eq? what 'cycle)
|
||||
(car (list-tail-cycle fast (+ i (- n m))))]
|
||||
[else (index-range/improper-list-error 'list-ref fast ls n)]))))]
|
||||
[else (index-type-error 'list-ref n)])))
|
||||
(set! list-tail
|
||||
(lambda (ls n)
|
||||
(cond
|
||||
[(and (fixnum? n) (fx<= 0 n 1000))
|
||||
(let loop ([l ls] [i n])
|
||||
(if (fx> i 1)
|
||||
(if (pair? l)
|
||||
(let ([l (cdr l)])
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (fx- i 2))
|
||||
(index-range/improper-list-error 'list-tail l ls n)))
|
||||
(index-range/improper-list-error 'list-tail l ls n))
|
||||
(if (fx= i 0)
|
||||
l
|
||||
(if (pair? l)
|
||||
(cdr l)
|
||||
(index-range/improper-list-error 'list-tail l ls n)))))]
|
||||
[(and (or (fixnum? n) (bignum? n)) (>= n 0))
|
||||
(let ((m (min n (most-positive-fixnum))))
|
||||
(call-with-values
|
||||
(lambda () (fx-list-tail ls ls m))
|
||||
(lambda (what fast i)
|
||||
(cond
|
||||
[(eq? what 'okay) ; can't happen with bignum input
|
||||
fast]
|
||||
[(eq? what 'cycle) (list-tail-cycle fast (+ i (- n m)))]
|
||||
[else (index-range/improper-list-error 'list-tail fast ls n)]))))]
|
||||
[else (index-type-error 'list-tail n)])))
|
||||
(set! list-head
|
||||
(lambda (orig-ls orig-n)
|
||||
(unless (and (fixnum? orig-n) (fx>= orig-n 0))
|
||||
($oops 'list-head "invalid index ~s" orig-n))
|
||||
(let f ([ls orig-ls] [n orig-n])
|
||||
(cond
|
||||
[(fx<= n 1)
|
||||
(if (fx= n 0)
|
||||
'()
|
||||
(if (pair? ls)
|
||||
(list (car ls))
|
||||
(index-range/improper-list-error 'list-head ls orig-ls orig-n)))]
|
||||
[(pair? ls)
|
||||
(let ([a (car ls)] [ls (cdr ls)])
|
||||
(if (pair? ls)
|
||||
(list* a (car ls) (f (cdr ls) (fx- n 2)))
|
||||
(index-range/improper-list-error 'list-head ls orig-ls orig-n)))]
|
||||
[else (index-range/improper-list-error 'list-head ls orig-ls orig-n)]))))
|
||||
(set! last-pair
|
||||
(lambda (ls)
|
||||
(unless (pair? ls)
|
||||
($oops 'last-pair "~s is not a pair" ls))
|
||||
(let loop ((fast ls) (slow ls))
|
||||
(let ((fast1 (cdr fast)))
|
||||
(if (pair? fast1)
|
||||
(let ((fast2 (cdr fast1)))
|
||||
(if (pair? fast2)
|
||||
(if (not (eq? fast1 slow))
|
||||
(loop fast2 (cdr slow))
|
||||
(circular-list-error 'last-pair ls))
|
||||
fast1))
|
||||
fast))))))
|
||||
|
||||
(define make-list
|
||||
(rec make-list
|
||||
(case-lambda
|
||||
[(n) (make-list n (void))]
|
||||
[(n x)
|
||||
(unless (and (fixnum? n) (fx>= n 0))
|
||||
($oops 'make-list "invalid size ~s" n))
|
||||
(let loop ([n n] [ls '()])
|
||||
(if (fx= n 0) ls (loop (fx- n 1) (cons x ls))))])))
|
||||
|
||||
(define-who list-copy
|
||||
(lambda (ls)
|
||||
($list-length ls who)
|
||||
(let f ([ls ls])
|
||||
(if (null? ls)
|
||||
ls
|
||||
(cons (car ls) (f (cdr ls)))))))
|
||||
|
||||
(define-who append
|
||||
(rec append
|
||||
(case-lambda
|
||||
[() '()]
|
||||
[(x1 x2)
|
||||
($list-length x1 who)
|
||||
(let f ([ls x1])
|
||||
(if (null? ls) x2 (cons (car ls) (f (cdr ls)))))]
|
||||
[(x1 . xr)
|
||||
(let f ([x1 x1] [xr xr])
|
||||
(if (null? xr) x1 (append x1 (f (car xr) (cdr xr)))))])))
|
||||
|
||||
(define-who append!
|
||||
(let ()
|
||||
(define (do-append! x1 x2)
|
||||
(if (null? x1)
|
||||
x2
|
||||
(let f ([ls x1])
|
||||
(if (null? (cdr ls))
|
||||
(begin (set-cdr! ls x2) x1)
|
||||
(f (cdr ls))))))
|
||||
(case-lambda
|
||||
[() '()]
|
||||
[(x1 x2)
|
||||
($list-length x1 who)
|
||||
(do-append! x1 x2)]
|
||||
[(x1 . xr)
|
||||
(let f ([x1 x1] [xr xr])
|
||||
(if (null? xr)
|
||||
x1
|
||||
(begin
|
||||
($list-length x1 who) ; make sure all checks occur before first set-cdr!
|
||||
(do-append! x1 (f (car xr) (cdr xr))))))])))
|
||||
|
||||
(define-who reverse
|
||||
(lambda (ls)
|
||||
($list-length ls who)
|
||||
(do ([ls ls (cdr ls)] [a '() (cons (car ls) a)])
|
||||
((null? ls) a))))
|
||||
|
||||
(define-who reverse!
|
||||
(lambda (ls)
|
||||
(#%$list-length ls who)
|
||||
(let loop ([l ls] [a '()])
|
||||
(cond
|
||||
[(pair? l) (let ([x (cdr l)]) (set-cdr! l a) (loop x l))]
|
||||
[(null? l) a]
|
||||
[else
|
||||
(let loop ([l a] [a l])
|
||||
(let ([x (cdr l)]) (set-cdr! l a) (loop x l)))]))))
|
||||
|
||||
(let ()
|
||||
(define-syntax do-assoc
|
||||
(syntax-rules ()
|
||||
((_ x alist who pred?)
|
||||
(let loop ((fast alist) (slow alist))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(let ((a (car fast)))
|
||||
(if (pair? a)
|
||||
(if (pred? (car a) x)
|
||||
a
|
||||
(let ((fast (cdr fast)))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(let ((a (car fast)))
|
||||
(if (pair? a)
|
||||
(if (pred? (car a) x)
|
||||
a
|
||||
(if (eq? fast slow)
|
||||
(cyclic-alist who alist)
|
||||
(loop (cdr fast) (cdr slow))))
|
||||
(improper-alist who alist)))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-alist who alist)])))
|
||||
(improper-alist who alist)))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-alist who alist)])))))
|
||||
|
||||
(define improper-alist
|
||||
(lambda (who alist)
|
||||
($oops who "improperly formed alist ~s" alist)))
|
||||
|
||||
(define cyclic-alist
|
||||
(lambda (who alist)
|
||||
($oops who "cyclic alist ~s" alist)))
|
||||
|
||||
(define ass-eq?
|
||||
(lambda (x alist who)
|
||||
(do-assoc x alist who eq?)))
|
||||
|
||||
(set! assq
|
||||
(lambda (x alist)
|
||||
(ass-eq? x alist 'assq)))
|
||||
|
||||
(set! assv
|
||||
(lambda (x alist)
|
||||
(if (or (symbol? x) (#%$immediate? x))
|
||||
(ass-eq? x alist 'assv)
|
||||
(do-assoc x alist 'assv eqv?))))
|
||||
|
||||
(set! assoc
|
||||
(lambda (x alist)
|
||||
(cond
|
||||
[(string? x)
|
||||
(do-assoc x alist 'assoc
|
||||
(lambda (x y) (and (string? x) (string=? x y))))]
|
||||
[(or (symbol? x) (#%$immediate? x))
|
||||
(ass-eq? x alist 'assoc)]
|
||||
[else
|
||||
(do-assoc x alist 'assoc equal?)])))
|
||||
|
||||
(set! assp
|
||||
(lambda (pred? alist)
|
||||
(unless (procedure? pred?)
|
||||
($oops 'assp "~s is not a procedure" pred?))
|
||||
(let loop ((fast alist) (slow alist))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(let ((a (car fast)))
|
||||
(if (pair? a)
|
||||
(if (pred? (car a))
|
||||
a
|
||||
(let ((fast (cdr fast)))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(let ((a (car fast)))
|
||||
(if (pair? a)
|
||||
(if (pred? (car a))
|
||||
a
|
||||
(if (eq? fast slow)
|
||||
(cyclic-alist 'assp alist)
|
||||
(loop (cdr fast) (cdr slow))))
|
||||
(improper-alist 'assp alist)))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-alist 'assp alist)])))
|
||||
(improper-alist 'assp alist)))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-alist 'assp alist)]))))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define improper-list
|
||||
(lambda (who ls)
|
||||
($oops who "improper list ~s" ls)))
|
||||
|
||||
(define cyclic-list
|
||||
(lambda (who ls)
|
||||
($oops who "cyclic list ~s" ls)))
|
||||
|
||||
(define-syntax do-member
|
||||
(syntax-rules ()
|
||||
((_ x ls who pred?)
|
||||
(let loop ((fast ls) (slow ls))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(if (pred? (car fast) x)
|
||||
fast
|
||||
(let ((fast (cdr fast)))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(if (pred? (car fast) x)
|
||||
fast
|
||||
(if (eq? fast slow)
|
||||
(cyclic-list who ls)
|
||||
(loop (cdr fast) (cdr slow))))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-list who ls)])))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-list who ls)])))))
|
||||
|
||||
(define mem-eq?
|
||||
(lambda (x ls who)
|
||||
(do-member x ls who eq?)))
|
||||
|
||||
(set! memq
|
||||
(lambda (x ls)
|
||||
(mem-eq? x ls 'memq)))
|
||||
|
||||
(set! memv
|
||||
(lambda (x ls)
|
||||
(if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
|
||||
(mem-eq? x ls 'memv)
|
||||
(do-member x ls 'memv eqv?))))
|
||||
|
||||
(set! member
|
||||
(lambda (x ls)
|
||||
(cond
|
||||
[(string? x)
|
||||
(do-member x ls 'member
|
||||
(lambda (x y) (and (string? x) (string=? x y))))]
|
||||
[(or (symbol? x) (fixnum? x) (char? x) (procedure? x))
|
||||
(mem-eq? x ls 'member)]
|
||||
[else
|
||||
(do-member x ls 'member equal?)])))
|
||||
|
||||
(set! memp
|
||||
(lambda (pred? ls)
|
||||
(unless (procedure? pred?)
|
||||
($oops 'memp "~s is not a procedure" pred?))
|
||||
(let loop ((fast ls) (slow ls))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(if (pred? (car fast))
|
||||
fast
|
||||
(let ((fast (cdr fast)))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(if (pred? (car fast))
|
||||
fast
|
||||
(if (eq? fast slow)
|
||||
(cyclic-list 'memp ls)
|
||||
(loop (cdr fast) (cdr slow))))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-list 'memp ls)])))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-list 'memp ls)]))))
|
||||
|
||||
(set! find
|
||||
(lambda (pred? ls)
|
||||
(unless (procedure? pred?)
|
||||
($oops 'find "~s is not a procedure" pred?))
|
||||
(let loop ((fast ls) (slow ls))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(if (pred? (car fast))
|
||||
(car fast)
|
||||
(let ((fast (cdr fast)))
|
||||
(cond
|
||||
[(pair? fast)
|
||||
(if (pred? (car fast))
|
||||
(car fast)
|
||||
(if (eq? fast slow)
|
||||
(cyclic-list 'find ls)
|
||||
(loop (cdr fast) (cdr slow))))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-list 'find ls)])))]
|
||||
[(null? fast) #f]
|
||||
[else (improper-list 'find ls)]))))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define improper-list
|
||||
(lambda (who ls)
|
||||
($oops who "~s is not a proper list" ls)))
|
||||
|
||||
(define-syntax do-remove
|
||||
(syntax-rules ()
|
||||
((_ x ls pred?)
|
||||
(let f ((x x) (fast ls) (slow ls))
|
||||
(if (pair? fast)
|
||||
(let ((fast1 (cdr fast)))
|
||||
(if (pair? fast1)
|
||||
(and (not (eq? fast1 slow))
|
||||
(let ((fast2 (cdr fast1)))
|
||||
(let ((rest (f x fast2 (cdr slow))))
|
||||
(and rest
|
||||
(if (not (pred? (car fast) x))
|
||||
(if (not (pred? (car fast1) x))
|
||||
(if (eq? rest fast2)
|
||||
fast
|
||||
(list* (car fast) (car fast1) rest))
|
||||
(cons (car fast) rest))
|
||||
(if (not (pred? (car fast1) x))
|
||||
(if (eq? rest fast2)
|
||||
fast1
|
||||
(cons (car fast1) rest))
|
||||
rest))))))
|
||||
(and (null? fast1)
|
||||
(if (not (pred? (car fast) x))
|
||||
fast
|
||||
'()))))
|
||||
(and (null? fast) '()))))))
|
||||
|
||||
(define rem-eq?
|
||||
(lambda (x l)
|
||||
(do-remove x l eq?)))
|
||||
|
||||
(set! remq
|
||||
(lambda (x ls)
|
||||
(or (rem-eq? x ls)
|
||||
(improper-list 'remq ls))))
|
||||
|
||||
(set! remv
|
||||
(lambda (x ls)
|
||||
(or (if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
|
||||
(rem-eq? x ls)
|
||||
(do-remove x ls eqv?))
|
||||
(improper-list 'remv ls))))
|
||||
|
||||
(set! remove
|
||||
(lambda (x ls)
|
||||
(or (cond
|
||||
[(string? x)
|
||||
(do-remove x ls
|
||||
(lambda (x y) (and (string? x) (string=? x y))))]
|
||||
[(or (symbol? x) (fixnum? x) (char? x) (procedure? x))
|
||||
(rem-eq? x ls)]
|
||||
[else
|
||||
(do-remove x ls equal?)])
|
||||
(improper-list 'remove ls))))
|
||||
|
||||
(set! remp
|
||||
(lambda (pred? ls)
|
||||
(unless (procedure? pred?)
|
||||
($oops 'remp "~s is not a procedure" pred?))
|
||||
(or (let f ((pred? pred?) (fast ls) (slow ls))
|
||||
(if (pair? fast)
|
||||
(let ((fast1 (cdr fast)))
|
||||
(if (pair? fast1)
|
||||
(and (not (eq? fast1 slow))
|
||||
(let ((fast2 (cdr fast1)))
|
||||
(let ((rest (f pred? fast2 (cdr slow))))
|
||||
(and rest
|
||||
(if (not (pred? (car fast)))
|
||||
(if (not (pred? (car fast1)))
|
||||
(if (eq? rest fast2)
|
||||
fast
|
||||
(list* (car fast) (car fast1) rest))
|
||||
(cons (car fast) rest))
|
||||
(if (not (pred? (car fast1)))
|
||||
(if (eq? rest fast2)
|
||||
fast1
|
||||
(cons (car fast1) rest))
|
||||
rest))))))
|
||||
(and (null? fast1)
|
||||
(if (not (pred? (car fast)))
|
||||
fast
|
||||
'()))))
|
||||
(and (null? fast) '())))
|
||||
(improper-list 'remp ls))))
|
||||
|
||||
|
||||
(set! filter
|
||||
(lambda (pred? ls)
|
||||
(unless (procedure? pred?)
|
||||
($oops 'filter "~s is not a procedure" pred?))
|
||||
(or (let f ((pred? pred?) (fast ls) (slow ls))
|
||||
(if (pair? fast)
|
||||
(let ((fast1 (cdr fast)))
|
||||
(if (pair? fast1)
|
||||
(and (not (eq? fast1 slow))
|
||||
(let ((fast2 (cdr fast1)))
|
||||
(let ((rest (f pred? fast2 (cdr slow))))
|
||||
(and rest
|
||||
(if (pred? (car fast))
|
||||
(if (pred? (car fast1))
|
||||
(if (eq? rest fast2)
|
||||
fast
|
||||
(list* (car fast) (car fast1) rest))
|
||||
(cons (car fast) rest))
|
||||
(if (pred? (car fast1))
|
||||
(if (eq? rest fast2)
|
||||
fast1
|
||||
(cons (car fast1) rest))
|
||||
rest))))))
|
||||
(and (null? fast1)
|
||||
(if (pred? (car fast))
|
||||
fast
|
||||
'()))))
|
||||
(and (null? fast) '())))
|
||||
(improper-list 'filter ls))))
|
||||
|
||||
(set! partition
|
||||
(lambda (pred? ls)
|
||||
(unless (procedure? pred?)
|
||||
($oops 'partition "~s is not a procedure" pred?))
|
||||
(let f ([pred? pred?] [fast ls] [slow ls] [ls ls])
|
||||
(if (pair? fast)
|
||||
(let ([fast1 (cdr fast)])
|
||||
(if (pair? fast1)
|
||||
(if (eq? fast1 slow)
|
||||
(improper-list 'partition ls)
|
||||
(let ([fast2 (cdr fast1)])
|
||||
(let-values ([(ins outs) (f pred? fast2 (cdr slow) ls)])
|
||||
(if (pred? (car fast))
|
||||
(if (pred? (car fast1))
|
||||
(values
|
||||
(if (eq? ins fast2)
|
||||
fast
|
||||
(list* (car fast) (car fast1) ins))
|
||||
outs)
|
||||
(values
|
||||
(cons (car fast) ins)
|
||||
(if (eq? outs fast2)
|
||||
fast1
|
||||
(cons (car fast1) outs))))
|
||||
(if (pred? (car fast1))
|
||||
(values
|
||||
(if (eq? ins fast2)
|
||||
fast1
|
||||
(cons (car fast1) ins))
|
||||
(cons (car fast) outs))
|
||||
(values
|
||||
ins
|
||||
(if (eq? outs fast2)
|
||||
fast
|
||||
(list* (car fast) (car fast1) outs))))))))
|
||||
(if (null? fast1)
|
||||
(if (pred? (car fast))
|
||||
(values fast '())
|
||||
(values '() fast))
|
||||
(improper-list 'partition ls))))
|
||||
(if (null? fast)
|
||||
(values '() '())
|
||||
(improper-list 'partition ls))))))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define-syntax do-rem!
|
||||
(syntax-rules ()
|
||||
((_ pred?)
|
||||
(rec rem!
|
||||
(lambda (x ls)
|
||||
(if (not (null? ls))
|
||||
(if (not (pred? (car ls) x))
|
||||
(begin
|
||||
(let loop ((ls (cdr ls)) (prev ls))
|
||||
(unless (null? ls)
|
||||
(if (not (pred? (car ls) x))
|
||||
(loop (cdr ls) ls)
|
||||
(set-cdr! prev (rem! x (cdr ls))))))
|
||||
ls)
|
||||
(rem! x (cdr ls)))
|
||||
'()))))))
|
||||
|
||||
(define rem-eq?! (do-rem! eq?))
|
||||
|
||||
(set! remq!
|
||||
(lambda (x ls)
|
||||
($list-length ls 'remq!)
|
||||
(rem-eq?! x ls)))
|
||||
|
||||
(set! remv!
|
||||
(lambda (x ls)
|
||||
($list-length ls 'remv!)
|
||||
(if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
|
||||
(rem-eq?! x ls)
|
||||
((do-rem! eqv?) x ls))))
|
||||
|
||||
(set! remove!
|
||||
(lambda (x ls)
|
||||
($list-length ls 'remove!)
|
||||
(if (or (symbol? x) (fixnum? x) (char? x) (procedure? x))
|
||||
(rem-eq?! x ls)
|
||||
((do-rem! equal?) x ls))))
|
||||
)
|
||||
|
||||
(define substq
|
||||
(lambda (new old tree)
|
||||
(let f ([tree tree])
|
||||
(if (eq? old tree)
|
||||
new
|
||||
(if (pair? tree)
|
||||
(let ([a (f (car tree))] [d (f (cdr tree))])
|
||||
(if (and (eq? a (car tree)) (eq? d (cdr tree)))
|
||||
tree
|
||||
(cons a d)))
|
||||
tree)))))
|
||||
|
||||
(define substq!
|
||||
(lambda (new old tree)
|
||||
(let f ([tree tree])
|
||||
(if (eq? old tree)
|
||||
new
|
||||
(if (pair? tree)
|
||||
(begin
|
||||
(set-car! tree (f (car tree)))
|
||||
(set-cdr! tree (f (cdr tree)))
|
||||
tree)
|
||||
tree)))))
|
||||
|
||||
(define substv
|
||||
(lambda (new old tree)
|
||||
(let f ([tree tree])
|
||||
(if (eqv? old tree)
|
||||
new
|
||||
(if (pair? tree)
|
||||
(let ([a (f (car tree))] [d (f (cdr tree))])
|
||||
(if (and (eq? a (car tree)) (eq? d (cdr tree)))
|
||||
tree
|
||||
(cons a d)))
|
||||
tree)))))
|
||||
|
||||
(define substv!
|
||||
(lambda (new old tree)
|
||||
(let f ([tree tree])
|
||||
(if (eqv? old tree)
|
||||
new
|
||||
(if (pair? tree)
|
||||
(begin
|
||||
(set-car! tree (f (car tree)))
|
||||
(set-cdr! tree (f (cdr tree)))
|
||||
tree)
|
||||
tree)))))
|
||||
|
||||
(define subst
|
||||
(lambda (new old tree)
|
||||
(let f ([tree tree])
|
||||
(if (equal? old tree)
|
||||
new
|
||||
(if (pair? tree)
|
||||
(let ([a (f (car tree))] [d (f (cdr tree))])
|
||||
(if (and (eq? a (car tree)) (eq? d (cdr tree)))
|
||||
tree
|
||||
(cons a d)))
|
||||
tree)))))
|
||||
|
||||
(define subst!
|
||||
(lambda (new old tree)
|
||||
(let f ([tree tree])
|
||||
(if (equal? old tree)
|
||||
new
|
||||
(if (pair? tree)
|
||||
(begin
|
||||
(set-car! tree (f (car tree)))
|
||||
(set-cdr! tree (f (cdr tree)))
|
||||
tree)
|
||||
tree)))))
|
||||
|
||||
(let ()
|
||||
(define ($iota n ls)
|
||||
(if (fx> n 0)
|
||||
($iota (fx- n 2) (list* (fx- n 1) n ls))
|
||||
(if (fx= n 0)
|
||||
(cons 0 ls)
|
||||
ls)))
|
||||
|
||||
; (iota n) => (0 1 ... n-1)
|
||||
(set! iota
|
||||
(lambda (n)
|
||||
(unless (and (fixnum? n) (fx>= n 0))
|
||||
($oops 'iota "~s is not a nonnegative fixnum" n))
|
||||
($iota (fx- n 1) '())))
|
||||
|
||||
; (enumerate '(a1 a2 ... aN)) => (0 1 ... n-1)
|
||||
(set! enumerate
|
||||
(lambda (ls)
|
||||
($iota (fx- ($list-length ls 'enumerate) 1) '()))))
|
||||
)
|
||||
833
s/5_4.ss
Normal file
833
s/5_4.ss
Normal file
|
|
@ -0,0 +1,833 @@
|
|||
;;; 5_4.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; character and string functions
|
||||
|
||||
(begin
|
||||
(define substring
|
||||
(lambda (s1 m n)
|
||||
(unless (string? s1)
|
||||
($oops 'substring "~s is not a string" s1))
|
||||
(let ([k (string-length s1)])
|
||||
(unless (and (fixnum? m) (fixnum? n) (fx<= 0 m n k))
|
||||
($oops 'substring
|
||||
"~s and ~s are not valid start/end indices for ~s"
|
||||
m n s1))
|
||||
(let ([s2 (make-string (fx- n m))])
|
||||
(do ([j 0 (fx+ j 1)] [i m (fx+ i 1)])
|
||||
((fx= i n) s2)
|
||||
(string-set! s2 j (string-ref s1 i)))))))
|
||||
|
||||
(define-who string-append
|
||||
(case-lambda
|
||||
[(s1 s2)
|
||||
(unless (string? s1) ($oops who "~s is not a string" s1))
|
||||
(unless (string? s2) ($oops who "~s is not a string" s2))
|
||||
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
||||
(let ([n (+ n1 n2)])
|
||||
(unless (fixnum? n) ($oops who "result string size ~s is not a fixnum" n))
|
||||
(let ([s (make-string n)])
|
||||
(string-copy! s1 0 s 0 n1)
|
||||
(string-copy! s2 0 s n1 n2)
|
||||
s)))]
|
||||
[args
|
||||
(let f ([ls args] [n 0])
|
||||
(if (null? ls)
|
||||
(if (fixnum? n)
|
||||
(make-string n)
|
||||
($oops who "result string size ~s is not a fixnum" n))
|
||||
(let ([s1 (car ls)])
|
||||
(unless (string? s1) ($oops who "~s is not a string" s1))
|
||||
(let ([m (string-length s1)])
|
||||
(let ([s2 (f (cdr ls) (+ n m))])
|
||||
(string-copy! s1 0 s2 n m)
|
||||
s2)))))]))
|
||||
|
||||
(define string->list
|
||||
(lambda (s)
|
||||
(unless (string? s)
|
||||
($oops 'string->list "~s is not a string" s))
|
||||
(let loop ([i (fx- (string-length s) 1)] [l '()])
|
||||
(if (fx> i 0)
|
||||
(loop (fx- i 2)
|
||||
(list* (string-ref s (fx- i 1))
|
||||
(string-ref s i)
|
||||
l))
|
||||
(if (fx= i 0)
|
||||
(cons (string-ref s 0) l)
|
||||
l)))))
|
||||
|
||||
(define list->string
|
||||
(lambda (x)
|
||||
(let ([s (make-string ($list-length x 'list->string))])
|
||||
(do ([ls x (cdr ls)] [i 0 (fx+ i 1)])
|
||||
((null? ls) s)
|
||||
(let ([c (car ls)])
|
||||
(unless (char? c)
|
||||
($oops 'list->string "~s is not a character" c))
|
||||
(string-set! s i c))))))
|
||||
|
||||
(define-who string-copy
|
||||
(lambda (s1)
|
||||
(unless (string? s1)
|
||||
($oops who "~s is not a string" s1))
|
||||
(let ([n (string-length s1)])
|
||||
(let ([s2 (make-string n)])
|
||||
($byte-copy!
|
||||
s1 (constant string-data-disp)
|
||||
s2 (constant string-data-disp)
|
||||
(fx* n (constant string-char-bytes)))
|
||||
s2))))
|
||||
|
||||
(define-who string-copy!
|
||||
(lambda (s1 i1 s2 i2 k)
|
||||
(unless (string? s1) ($oops who "~s is not a string" s1))
|
||||
(unless (mutable-string? s2) ($oops who "~s is not a mutable string" s2))
|
||||
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
||||
(unless (and (fixnum? i1) (fx>= i1 0))
|
||||
($oops who "invalid start value ~s" i1))
|
||||
(unless (and (fixnum? i2) (fx>= i2 0))
|
||||
($oops who "invalid start value ~s" i2))
|
||||
(unless (and (fixnum? k) (fx>= k 0))
|
||||
($oops who "invalid count ~s" k))
|
||||
(unless (fx<= k (fx- n1 i1)) ; avoid overflow
|
||||
($oops who "index ~s + count ~s is beyond the end of ~s" i1 k s1))
|
||||
(unless (fx<= k (fx- n2 i2)) ; avoid overflow
|
||||
($oops who "index ~s + count ~s is beyond the end of ~s" i2 k s2))
|
||||
; whew!
|
||||
(#3%string-copy! s1 i1 s2 i2 k))))
|
||||
|
||||
(set-who! string->immutable-string
|
||||
(lambda (v)
|
||||
(cond
|
||||
[(immutable-string? v) v]
|
||||
[(eqv? v "") ($tc-field 'null-immutable-string ($tc))]
|
||||
[else
|
||||
(unless (string? v) ($oops who "~s is not a string" v))
|
||||
(let ([v2 (string-copy v)])
|
||||
($string-set-immutable! v2)
|
||||
v2)])))
|
||||
|
||||
(define-who substring-fill!
|
||||
(lambda (s m n c)
|
||||
(unless (mutable-string? s)
|
||||
($oops who "~s is not a mutable string" s))
|
||||
(unless (char? c)
|
||||
($oops who "~s is not a character" c))
|
||||
(let ([k (string-length s)])
|
||||
(unless (and (fixnum? m) (fixnum? n) (fx<= 0 m n k))
|
||||
($oops who
|
||||
"~s and ~s are not valid start/end indices for ~s"
|
||||
m n s))
|
||||
(do ([i m (fx+ i 1)])
|
||||
((fx= i n))
|
||||
(string-set! s i c)))))
|
||||
|
||||
(set! string-for-each
|
||||
(case-lambda
|
||||
[(p s)
|
||||
(unless (procedure? p) ($oops 'string-for-each "~s is not a procedure" p))
|
||||
(unless (string? s) ($oops 'string-for-each "~s is not a string" s))
|
||||
(#3%string-for-each p s)]
|
||||
[(p s t)
|
||||
(unless (procedure? p) ($oops 'string-for-each "~s is not a procedure" p))
|
||||
(unless (string? s) ($oops 'string-for-each "~s is not a string" s))
|
||||
(unless (string? t) ($oops 'string-for-each "~s is not a string" t))
|
||||
(let ([n (string-length s)])
|
||||
(unless (fx= (string-length t) n)
|
||||
($oops 'string-for-each "lengths of input string ~s and ~s differ" s t))
|
||||
(unless (fx= n 0)
|
||||
(let loop ([i 0])
|
||||
(let ([j (fx+ i 1)])
|
||||
(if (fx= j n)
|
||||
(p (string-ref s i) (string-ref t i))
|
||||
(begin
|
||||
(p (string-ref s i) (string-ref t i))
|
||||
(loop j)))))))]
|
||||
[(p s . t*)
|
||||
(unless (procedure? p) ($oops 'string-for-each "~s is not a procedure" p))
|
||||
(unless (string? s) ($oops 'string-for-each "~s is not a string" s))
|
||||
(for-each (lambda (t) (unless (string? t) ($oops 'string-for-each "~s is not a string" t))) t*)
|
||||
(let ([n (string-length s)])
|
||||
(for-each
|
||||
(lambda (t)
|
||||
(unless (fx= (string-length t) n)
|
||||
($oops 'string-for-each "lengths of input string ~s and ~s differ" s t)))
|
||||
t*)
|
||||
(unless (fx= n 0)
|
||||
(let loop ([i 0])
|
||||
(let ([j (fx+ i 1)])
|
||||
(if (fx= j n)
|
||||
(apply p (string-ref s i) (map (lambda (t) (string-ref t i)) t*))
|
||||
(begin
|
||||
(apply p (string-ref s i) (map (lambda (t) (string-ref t i)) t*))
|
||||
(loop j)))))))]))
|
||||
|
||||
;;; The following code is covered by the following copyright/license.
|
||||
|
||||
;;; Copyright (C) 2008 Abdulaziz Ghuloum, R. Kent Dybvig
|
||||
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
||||
;;; copy of this software and associated documentation files (the "Software"),
|
||||
;;; to deal in the Software without restriction, including without limitation
|
||||
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||||
;;; and/or sell copies of the Software, and to permit persons to whom the
|
||||
;;; Software is furnished to do so, subject to the following conditions:
|
||||
;;;
|
||||
;;; The above copyright notice and this permission notice shall be included in
|
||||
;;; all copies or substantial portions of the Software.
|
||||
;;;
|
||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
;;; DEALINGS IN THE SOFTWARE.
|
||||
|
||||
(let ()
|
||||
(include "../unicode/unicode-char-cases.ss")
|
||||
(include "../unicode/unicode-charinfo.ss")
|
||||
|
||||
(define char-error
|
||||
(lambda (who what)
|
||||
($oops who "~s is not a character" what)))
|
||||
|
||||
(define string-error
|
||||
(lambda (who what)
|
||||
($oops who "~s is not a string" what)))
|
||||
|
||||
(set! $string-char-foldcase (lambda (c) ($str-foldcase c)))
|
||||
|
||||
(let ()
|
||||
(define-syntax define-char-op
|
||||
(syntax-rules ()
|
||||
[(_ name unsafe-op)
|
||||
(set-who! name
|
||||
(lambda (c)
|
||||
(if (char? c)
|
||||
(unsafe-op c)
|
||||
($oops who "~s is not a character" c))))]))
|
||||
|
||||
(define-char-op char-upcase $char-upcase)
|
||||
(define-char-op char-downcase $char-downcase)
|
||||
(define-char-op char-titlecase $char-titlecase)
|
||||
(define-char-op char-foldcase $char-foldcase)
|
||||
(define-char-op char-whitespace? $char-whitespace?)
|
||||
(define-char-op char-lower-case? $char-lower-case?)
|
||||
(define-char-op char-upper-case? $char-upper-case?)
|
||||
(define-char-op char-title-case? $char-title-case?)
|
||||
(define-char-op char-numeric? $char-numeric?)
|
||||
(define-char-op char-alphabetic? $char-alphabetic?)
|
||||
(define-char-op char-general-category $char-category)
|
||||
(define-char-op $constituent? $char-constituent?)
|
||||
(define-char-op $subsequent? $char-subsequent?)
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define (check-chars who ls)
|
||||
(let loop ([ls ls])
|
||||
(and (not (null? ls))
|
||||
(let ([x (car ls)])
|
||||
(if (char? x)
|
||||
(loop (cdr ls))
|
||||
(char-error who x))))))
|
||||
|
||||
(define-syntax char-relop
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ name filter) #'(char-relop name name filter)]
|
||||
[(_ name pred filter)
|
||||
(let ()
|
||||
(define (foo xname onearg)
|
||||
#`(set-who! #,xname
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(if (char? x1)
|
||||
(if (char? x2)
|
||||
(#3%pred (filter x1) (filter x2))
|
||||
(char-error who x2))
|
||||
(char-error who x1))]
|
||||
[(x1 x2 x3)
|
||||
(if (char? x1)
|
||||
(if (char? x2)
|
||||
(if (char? x3)
|
||||
(let ([x2 (filter x2)])
|
||||
(and (#3%pred (filter x1) x2)
|
||||
(#3%pred x2 (filter x3))))
|
||||
(char-error who x3))
|
||||
(char-error who x2))
|
||||
(char-error who x1))]
|
||||
#,@(if onearg (list onearg) '())
|
||||
[(x1 x2 . rest)
|
||||
(if (char? x1)
|
||||
(let loop ([x1 (filter x1)] [x2 x2] [ls rest])
|
||||
(if (char? x2)
|
||||
(let ([x2 (filter x2)])
|
||||
(if (#3%pred x1 x2)
|
||||
(or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||||
(check-chars who ls)))
|
||||
(char-error who x2)))
|
||||
(char-error who x1))])))
|
||||
#`(begin
|
||||
#,(foo #'#(r6rs: name) #f)
|
||||
#,(foo #'name #'[(x) (if (char? x) #t (char-error who x))])))])))
|
||||
|
||||
(char-relop char<? values)
|
||||
(char-relop char<=? values)
|
||||
(char-relop char=? values)
|
||||
(char-relop char>=? values)
|
||||
(char-relop char>? values)
|
||||
|
||||
(char-relop char-ci<? char<? $char-foldcase)
|
||||
(char-relop char-ci<=? char<=? $char-foldcase)
|
||||
(char-relop char-ci=? char=? $char-foldcase)
|
||||
(char-relop char-ci>=? char>=? $char-foldcase)
|
||||
(char-relop char-ci>? char>? $char-foldcase)
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define (handle-special str ac)
|
||||
(define (chars ac n)
|
||||
(cond
|
||||
[(null? ac) n]
|
||||
[else
|
||||
(chars (cdr ac)
|
||||
(let f ([p (cdar ac)] [n n])
|
||||
(cond
|
||||
[(pair? p) (f (cdr p) (fx+ n 1))]
|
||||
[else n])))]))
|
||||
(define (extend src ac src-len dst-len)
|
||||
(let f ([str str] [dst (make-string dst-len)] [i 0] [j 0] [ac (reverse ac)] [sigma* '()])
|
||||
(cond
|
||||
[(null? ac)
|
||||
(string-copy! str i dst j (fx- src-len i))
|
||||
(do-sigmas dst sigma*)]
|
||||
[else
|
||||
(let ([idx (caar ac)] [c* (cdar ac)] [ac (cdr ac)])
|
||||
(let ([cnt (fx- idx i)])
|
||||
(string-copy! str i dst j cnt)
|
||||
(let g ([str str] [dst dst]
|
||||
[i (fx+ i cnt)] [j (fx+ j cnt)]
|
||||
[ac ac] [c* c*])
|
||||
(cond
|
||||
[(pair? c*)
|
||||
(string-set! dst j (car c*))
|
||||
(g str dst i (fx+ j 1) ac (cdr c*))]
|
||||
[(char? c*)
|
||||
(string-set! dst j c*)
|
||||
(f str dst (fx+ i 1) (fx+ j 1) ac sigma*)]
|
||||
[else ; assume c* = sigma
|
||||
(f str dst (fx+ i 1) (fx+ j 1) ac (cons j sigma*))]))))])))
|
||||
(define (do-sigmas str sigma*)
|
||||
(define nonfinal-sigma #\x3c3)
|
||||
(define final-sigma #\x3c2)
|
||||
(define (final? i)
|
||||
(define (scan i incr n)
|
||||
(and (not (fx= i n))
|
||||
(or ($char-cased? (string-ref str i))
|
||||
(and ($char-case-ignorable? (string-ref str i))
|
||||
(scan (fx+ i incr) incr n)))))
|
||||
(and (scan (fx- i 1) -1 -1) (not (scan (fx+ i 1) +1 (string-length str)))))
|
||||
; scanning requires we have some character in place...guess nonfinal sigma
|
||||
(for-each (lambda (i) (string-set! str i nonfinal-sigma)) sigma*)
|
||||
(for-each (lambda (i) (when (final? i) (string-set! str i final-sigma))) sigma*)
|
||||
str)
|
||||
(let* ([src-len (string-length str)]
|
||||
[dst-len (chars ac src-len)])
|
||||
(if (fx= dst-len src-len)
|
||||
(do-sigmas str (map car ac))
|
||||
(extend str ac src-len dst-len))))
|
||||
|
||||
(define (string-change-case str cvt-char)
|
||||
(let ([n (string-length str)])
|
||||
(let f ([str str] [dst (make-string n)] [i 0] [n n] [ac '()])
|
||||
(cond
|
||||
[(fx= i n)
|
||||
(if (null? ac)
|
||||
dst
|
||||
(handle-special dst ac))]
|
||||
[else
|
||||
(let ([c/ls (cvt-char (string-ref str i))])
|
||||
(cond
|
||||
[(char? c/ls)
|
||||
(string-set! dst i c/ls)
|
||||
(f str dst (fx+ i 1) n ac)]
|
||||
[else
|
||||
(f str dst (fx+ i 1) n
|
||||
(cons (cons i c/ls) ac))]))]))))
|
||||
|
||||
(set-who! string-upcase
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
(string-change-case s $str-upcase)))
|
||||
|
||||
(set-who! string-foldcase
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
(string-change-case s $str-foldcase)))
|
||||
|
||||
(set-who! string-downcase
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
(string-change-case s $str-downcase)))
|
||||
|
||||
(set-who! string-titlecase
|
||||
(lambda (str)
|
||||
(unless (string? str) (string-error who str))
|
||||
(let* ([n (string-length str)] [dst (make-string n)])
|
||||
(define (trans2 s i seen-cased? ac)
|
||||
(if (fx= i n)
|
||||
(handle-special dst ac)
|
||||
(s i seen-cased? ac)))
|
||||
(define (trans1 s i c/ls seen-cased? ac)
|
||||
(cond
|
||||
[(char? c/ls)
|
||||
(string-set! dst i c/ls)
|
||||
(trans2 s (fx+ i 1) seen-cased? ac)]
|
||||
[else
|
||||
(trans2 s (fx+ i 1) seen-cased? (cons (cons i c/ls) ac))]))
|
||||
(define (trans s i c seen-cased? ac)
|
||||
(if seen-cased?
|
||||
(trans1 s i ($str-downcase c) #t ac)
|
||||
(if ($char-cased? c)
|
||||
(trans1 s i ($str-titlecase c) #t ac)
|
||||
(trans1 s i c #f ac))))
|
||||
; NB: if used as a pattern for word breaking, take care not to break between CR & LF (WB3)
|
||||
; NB: and between regional-indicators (WB13c). also take care not to let handling of WB6 and
|
||||
; NB: WB7 here prevent breaks in, e.g., "a." when not followed by, e.g., another letter.
|
||||
(define (s0 i ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-aletter? c) (trans sAletter i c #f ac)]
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c #f ac)]
|
||||
[($wb-numeric? c) (trans sNumeric i c #f ac)]
|
||||
[($wb-katakana? c) (trans sKatakana i c #f ac)]
|
||||
[($wb-extendnumlet? c) (trans sExtendnumlet i c #f ac)]
|
||||
[($wb-regional-indicator? c) (trans sRegionalIndicator i c #f ac)]
|
||||
[else (string-set! dst i c)
|
||||
(let ([i (fx+ i 1)])
|
||||
(if (fx= i n)
|
||||
(handle-special dst ac)
|
||||
(s0 i ac)))])))
|
||||
(define (extend-format-zwj? c) (or ($wb-extend? c) ($wb-format? c) ($wb-zwj? c)))
|
||||
(define (sAletter i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)] ; WB5
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; WB5
|
||||
[(or ($wb-midletter? c) ($wb-midnumlet? c) ($wb-single-quote? c)) (trans sWB6/WB7/WB7a i c seen-cased? ac)] ; WB6/WB7
|
||||
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)] ; WB9
|
||||
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)] ; WB13a
|
||||
[(extend-format-zwj? c) (trans sAletter i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sHebrewletter i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)] ; WB5
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; WB5
|
||||
[(or ($wb-midletter? c) ($wb-midnumlet? c) ($wb-single-quote? c)) (trans sWB6/WB7/WB7a i c seen-cased? ac)] ; WB6/WB7/WB7a
|
||||
[($wb-double-quote? c) (trans sWB7b/WB7c i c seen-cased? ac)] ; WB7b, WB7c
|
||||
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)] ; WB9
|
||||
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)] ; WB13a
|
||||
[(extend-format-zwj? c) (trans sHebrewletter i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sWB6/WB7/WB7a i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)] ; WB6, WB7
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; WB6, WB7
|
||||
[(extend-format-zwj? c) (trans sWB6/WB7/WB7a i c seen-cased? ac)] ; WB4
|
||||
; word break actually should/could have occurred one character earlier if we got here
|
||||
; from sAletter rather than sHebrewletter but that was before a midlet, midnumlet, or single
|
||||
; quote which has no titlecase
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sWB7b/WB7c i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; WB7b, WB7c
|
||||
[(extend-format-zwj? c) (trans sWB7b/WB7c i c seen-cased? ac)] ; WB4
|
||||
; word break actually should/could have occurred one character earlier
|
||||
; but that was before a double quote which has no titlecase
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sSingleQuote i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)] ; finishing WB6, WB7
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; finishing WB6, WB7
|
||||
[(extend-format-zwj? c) (trans sSingleQuote i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sNumeric i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)] ; WB8
|
||||
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)] ; WB10
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; WB10
|
||||
[(or ($wb-midnum? c) ($wb-midnumlet? c) ($wb-single-quote? c)) (trans sWB11/WB12 i c seen-cased? ac)] ; WB11, WB12
|
||||
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)]
|
||||
[(extend-format-zwj? c) (trans sNumeric i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sWB11/WB12 i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)]
|
||||
[(extend-format-zwj? c) (trans sWB11/WB12 i c seen-cased? ac)] ; WB4
|
||||
; word break actually should/could have occurred one character earlier
|
||||
; but that was before a midnum, midnumlet, or single quote which has no titltecase
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sKatakana i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-katakana? c) (trans sKatakana i c seen-cased? ac)] ; WB13
|
||||
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)] ; WB13a
|
||||
[(extend-format-zwj? c) (trans sKatakana i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sExtendnumlet i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-extendnumlet? c) (trans sExtendnumlet i c seen-cased? ac)] ; WB13a
|
||||
[($wb-aletter? c) (trans sAletter i c seen-cased? ac)] ; WB13b
|
||||
[($wb-hebrew-letter? c) (trans sHebrewletter i c seen-cased? ac)] ; WB13b
|
||||
[($wb-numeric? c) (trans sNumeric i c seen-cased? ac)] ; WB13b
|
||||
[($wb-katakana? c) (trans sKatakana i c seen-cased? ac)] ; WB13b
|
||||
[(extend-format-zwj? c) (trans sExtendnumlet i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(define (sRegionalIndicator i seen-cased? ac)
|
||||
(let ([c (string-ref str i)])
|
||||
(cond
|
||||
[($wb-regional-indicator? c) (trans sRegionalIndicator i c seen-cased? ac)] ; WB13c
|
||||
[(extend-format-zwj? c) (trans sExtendnumlet i c seen-cased? ac)] ; WB4
|
||||
[else (s0 i ac)]))) ; WB14
|
||||
(if (fx= n 0) dst (s0 0 '())))))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define-syntax string-relop
|
||||
(syntax-rules ()
|
||||
[(_ (name x1 x2) pred)
|
||||
(set! name
|
||||
(rec name
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(if (string? x1)
|
||||
(if (string? x2)
|
||||
pred
|
||||
(string-error 'name x2))
|
||||
(string-error 'name x1))]
|
||||
[(x1) (begin (name x1 "") #t)]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [ls rest])
|
||||
(if (or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||||
(name x1 x2)
|
||||
(begin (name x1 x2) #f)))])))]))
|
||||
|
||||
(define-syntax r6rs:string-relop
|
||||
(syntax-rules ()
|
||||
[(_ (name x1 x2) pred)
|
||||
(set-who! #(r6rs: name) ; implies (rec name ---)
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(if (string? x1)
|
||||
(if (string? x2)
|
||||
pred
|
||||
(string-error 'name x2))
|
||||
(string-error 'name x1))]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [ls rest])
|
||||
(if (or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||||
(name x1 x2)
|
||||
(begin (name x1 x2) #f)))]))]))
|
||||
|
||||
(define string-equal?
|
||||
(lambda (s1 s2)
|
||||
(or (eq? s1 s2)
|
||||
(let ([n (string-length s1)])
|
||||
(and (fx= n (string-length s2))
|
||||
(let f ([i 0])
|
||||
(or (fx= i n)
|
||||
(and (char=? (string-ref s1 i) (string-ref s2 i))
|
||||
(f (fx+ i 1))))))))))
|
||||
|
||||
(define string-less?
|
||||
(lambda (s1 s2)
|
||||
(and (not (eq? s1 s2))
|
||||
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
||||
(let f ([i 0])
|
||||
(and (not (fx= i n2))
|
||||
(or (fx= i n1)
|
||||
(let ([c1 (string-ref s1 i)]
|
||||
[c2 (string-ref s2 i)])
|
||||
(or (char<? c1 c2)
|
||||
(and (char=? c1 c2) (f (fx+ i 1))))))))))))
|
||||
|
||||
(define string-ci-equal?
|
||||
(lambda (s1 s2)
|
||||
(or (eq? s1 s2)
|
||||
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
||||
(if (fx= n1 0)
|
||||
(fx= n2 0)
|
||||
(and (not (fx= n2 0))
|
||||
(let f ([i1 1]
|
||||
[i2 1]
|
||||
[c1* ($str-foldcase (string-ref s1 0))]
|
||||
[c2* ($str-foldcase (string-ref s2 0))])
|
||||
(if (char? c1*)
|
||||
(if (char? c2*)
|
||||
(and (char=? c1* c2*)
|
||||
(if (fx= i1 n1)
|
||||
(fx= i2 n2)
|
||||
(and (not (fx= i2 n2))
|
||||
(f (fx+ i1 1) (fx+ i2 1)
|
||||
($str-foldcase (string-ref s1 i1))
|
||||
($str-foldcase (string-ref s2 i2))))))
|
||||
(and (char=? c1* (car c2*))
|
||||
(not (fx= i1 n1))
|
||||
(f (fx+ i1 1) i2
|
||||
($str-foldcase (string-ref s1 i1))
|
||||
(cdr c2*))))
|
||||
(if (char? c2*)
|
||||
(and (char=? (car c1*) c2*)
|
||||
(not (fx= i2 n2))
|
||||
(f i1 (fx+ i2 1) (cdr c1*)
|
||||
($str-foldcase (string-ref s2 i2))))
|
||||
(and (char=? (car c1*) (car c2*))
|
||||
(f i1 i2 (cdr c1*) (cdr c2*))))))))))))
|
||||
|
||||
(define string-ci-less?
|
||||
(lambda (s1 s2)
|
||||
(and (not (eq? s1 s2))
|
||||
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
||||
(and (not (fx= n2 0))
|
||||
(or (fx= n1 0)
|
||||
(let f ([i1 1]
|
||||
[i2 1]
|
||||
[c1* ($str-foldcase (string-ref s1 0))]
|
||||
[c2* ($str-foldcase (string-ref s2 0))])
|
||||
(if (char? c1*)
|
||||
(if (char? c2*)
|
||||
(or (char<? c1* c2*)
|
||||
(and (char=? c1* c2*)
|
||||
(not (fx= i2 n2))
|
||||
(or (fx= i1 n1)
|
||||
(f (fx+ i1 1) (fx+ i2 1)
|
||||
($str-foldcase (string-ref s1 i1))
|
||||
($str-foldcase (string-ref s2 i2))))))
|
||||
(or (char<? c1* (car c2*))
|
||||
(and (char=? c1* (car c2*))
|
||||
(or (fx= i1 n1)
|
||||
(f (fx+ i1 1) i2
|
||||
($str-foldcase (string-ref s1 i1))
|
||||
(cdr c2*))))))
|
||||
(if (char? c2*)
|
||||
(or (char<? (car c1*) c2*)
|
||||
(and (char=? (car c1*) c2*)
|
||||
(not (fx= i2 n2))
|
||||
(f i1 (fx+ i2 1) (cdr c1*)
|
||||
($str-foldcase (string-ref s2 i2)))))
|
||||
(or (char<? (car c1*) (car c2*))
|
||||
(and (char=? (car c1*) (car c2*))
|
||||
(f i1 i2 (cdr c1*) (cdr c2*)))))))))))))
|
||||
|
||||
(string-relop (string=? x1 x2) (string-equal? x1 x2))
|
||||
(string-relop (string<? x1 x2) (string-less? x1 x2))
|
||||
(string-relop (string>? x1 x2) (string-less? x2 x1))
|
||||
(string-relop (string<=? x1 x2) (not (string-less? x2 x1)))
|
||||
(string-relop (string>=? x1 x2) (not (string-less? x1 x2)))
|
||||
|
||||
(string-relop (string-ci=? x1 x2) (string-ci-equal? x1 x2))
|
||||
(string-relop (string-ci<? x1 x2) (string-ci-less? x1 x2))
|
||||
(string-relop (string-ci>? x1 x2) (string-ci-less? x2 x1))
|
||||
(string-relop (string-ci<=? x1 x2) (not (string-ci-less? x2 x1)))
|
||||
(string-relop (string-ci>=? x1 x2) (not (string-ci-less? x1 x2)))
|
||||
|
||||
(r6rs:string-relop (string=? x1 x2) (string-equal? x1 x2))
|
||||
(r6rs:string-relop (string<? x1 x2) (string-less? x1 x2))
|
||||
(r6rs:string-relop (string>? x1 x2) (string-less? x2 x1))
|
||||
(r6rs:string-relop (string<=? x1 x2) (not (string-less? x2 x1)))
|
||||
(r6rs:string-relop (string>=? x1 x2) (not (string-less? x1 x2)))
|
||||
|
||||
(r6rs:string-relop (string-ci=? x1 x2) (string-ci-equal? x1 x2))
|
||||
(r6rs:string-relop (string-ci<? x1 x2) (string-ci-less? x1 x2))
|
||||
(r6rs:string-relop (string-ci>? x1 x2) (string-ci-less? x2 x1))
|
||||
(r6rs:string-relop (string-ci<=? x1 x2) (not (string-ci-less? x2 x1)))
|
||||
(r6rs:string-relop (string-ci>=? x1 x2) (not (string-ci-less? x1 x2)))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(module (hangul-sbase hangul-slimit $hangul-decomp
|
||||
hangul-lbase hangul-llimit
|
||||
hangul-vbase hangul-vlimit
|
||||
hangul-tbase hangul-tlimit
|
||||
hangul-vcount hangul-tcount)
|
||||
; adapted from UAX #15
|
||||
(define SBase #xAC00)
|
||||
(define LBase #x1100)
|
||||
(define VBase #x1161)
|
||||
(define TBase #x11A7)
|
||||
(define LCount 19)
|
||||
(define VCount 21)
|
||||
(define TCount 28)
|
||||
(define NCount (* VCount TCount))
|
||||
(define SCount (* LCount NCount))
|
||||
(define hangul-sbase (integer->char SBase))
|
||||
(define hangul-slimit (integer->char (+ SBase SCount -1)))
|
||||
(define hangul-lbase (integer->char LBase))
|
||||
(define hangul-llimit (integer->char (+ LBase LCount -1)))
|
||||
(define hangul-vbase (integer->char VBase))
|
||||
(define hangul-vlimit (integer->char (+ VBase VCount -1)))
|
||||
(define hangul-tbase (integer->char TBase))
|
||||
(define hangul-tlimit (integer->char (+ TBase TCount -1)))
|
||||
(define hangul-vcount VCount)
|
||||
(define hangul-tcount TCount)
|
||||
(define ($hangul-decomp c)
|
||||
(let ([SIndex (char- c hangul-sbase)])
|
||||
(let ([L (integer->char (fx+ LBase (fxdiv SIndex NCount)))]
|
||||
[V (integer->char (fx+ VBase (fxdiv (fxmod SIndex NCount) TCount)))]
|
||||
[adj (fxmod SIndex TCount)])
|
||||
(if (fx= adj 0)
|
||||
(cons* L V)
|
||||
(cons* L V (integer->char (fx+ TBase adj))))))))
|
||||
|
||||
(define $decompose
|
||||
; might should optimize for sequences of ascii characters
|
||||
(lambda (s canonical?)
|
||||
(let ([n (string-length s)] [ac '()])
|
||||
(define (canonical>? c1 c2)
|
||||
(fx> ($char-combining-class c1) ($char-combining-class c2)))
|
||||
(define (sort-and-flush comb*)
|
||||
(unless (null? comb*)
|
||||
(set! ac (append (list-sort canonical>? comb*) ac))))
|
||||
(define ($char-decomp c)
|
||||
(if (and (char<=? hangul-sbase c) (char<=? c hangul-slimit))
|
||||
($hangul-decomp c)
|
||||
(if canonical?
|
||||
($str-decomp-canon c)
|
||||
($str-decomp-compat c))))
|
||||
(define (push-and-go c* c** i comb*)
|
||||
(if (char? c*)
|
||||
(go c* c** i comb*)
|
||||
(go (car c*) (cons (cdr c*) c**) i comb*)))
|
||||
(define (pop-and-go c** i comb*)
|
||||
(if (null? c**)
|
||||
(if (fx= i n)
|
||||
(sort-and-flush comb*)
|
||||
(go (string-ref s i) '() (fx+ i 1) comb*))
|
||||
(push-and-go (car c**) (cdr c**) i comb*)))
|
||||
(define (go c c** i comb*)
|
||||
(let ([c* ($char-decomp c)])
|
||||
(if (eq? c c*) ; should be eqv?
|
||||
(if (fxzero? ($char-combining-class c))
|
||||
(begin
|
||||
(sort-and-flush comb*)
|
||||
(set! ac (cons c ac))
|
||||
(pop-and-go c** i '()))
|
||||
(pop-and-go c** i (cons c comb*)))
|
||||
(push-and-go c* c** i comb*))))
|
||||
(pop-and-go '() 0 '())
|
||||
(list->string (reverse ac)))))
|
||||
|
||||
(define $compose
|
||||
(let ([comp-table #f])
|
||||
(define (lookup-composite c1 c2)
|
||||
(hashtable-ref comp-table (cons c1 c2) #f))
|
||||
(define (init!)
|
||||
(set! comp-table
|
||||
(make-hashtable
|
||||
(lambda (x)
|
||||
(fxxor
|
||||
(fxsll (char->integer (car x)) 7)
|
||||
(char->integer (cdr x))))
|
||||
(lambda (x y)
|
||||
(and (char=? (car x) (car y))
|
||||
(char=? (cdr x) (cdr y))))))
|
||||
(vector-for-each
|
||||
(lambda (c* c) (hashtable-set! comp-table c* c))
|
||||
(car ($composition-pairs))
|
||||
(cdr ($composition-pairs))))
|
||||
(lambda (s)
|
||||
(unless comp-table (init!))
|
||||
(let ([ac '()] [n (string-length s)])
|
||||
(define (dump c acc)
|
||||
(set! ac (cons c ac))
|
||||
(unless (null? acc) (set! ac (append acc ac))))
|
||||
(define (s0 i)
|
||||
(unless (fx= i n)
|
||||
(let ([c (string-ref s i)])
|
||||
(if (fxzero? ($char-combining-class c))
|
||||
(s1 (fx+ i 1) c)
|
||||
(begin (set! ac (cons c ac)) (s0 (fx+ i 1)))))))
|
||||
(define (s1 i c)
|
||||
(if (fx= i n)
|
||||
(set! ac (cons c ac))
|
||||
(let ([c1 (string-ref s i)])
|
||||
(cond
|
||||
[(and (and (char<=? hangul-lbase c)
|
||||
(char<=? c hangul-llimit))
|
||||
(and (char<=? hangul-vbase c1)
|
||||
(char<=? c1 hangul-vlimit)))
|
||||
(s1 (fx+ i 1)
|
||||
(let ([lindex (char- c hangul-lbase)]
|
||||
[vindex (char- c1 hangul-vbase)])
|
||||
(integer->char
|
||||
(fx+ (char->integer hangul-sbase)
|
||||
(fx* (fx+ (fx* lindex hangul-vcount) vindex)
|
||||
hangul-tcount)))))]
|
||||
[(and (and (char<=? hangul-sbase c)
|
||||
(char<=? c hangul-slimit))
|
||||
(and (char<=? hangul-tbase c1)
|
||||
(char<=? c1 hangul-tlimit))
|
||||
(let ([sindex (char- c hangul-sbase)])
|
||||
(fxzero? (fxmod sindex hangul-tcount))))
|
||||
(let ([tindex (char- c1 hangul-tbase)])
|
||||
(s1 (fx+ i 1) (integer->char (fx+ (char->integer c) tindex))))]
|
||||
[else (s2 i c -1 '())]))))
|
||||
(define (s2 i c class acc)
|
||||
(if (fx= i n)
|
||||
(dump c acc)
|
||||
(let ([c1 (string-ref s i)])
|
||||
(let ([class1 ($char-combining-class c1)])
|
||||
(cond
|
||||
[(and (fx< class class1) (lookup-composite c c1)) =>
|
||||
(lambda (c) (s2 (fx+ i 1) c class acc))]
|
||||
[(fx= class1 0)
|
||||
(dump c acc)
|
||||
(s1 (fx+ i 1) c1)]
|
||||
[else (s2 (fx+ i 1) c class1 (cons c1 acc))])))))
|
||||
(s0 0)
|
||||
(list->string (reverse ac))))))
|
||||
|
||||
(set-who! string-normalize-nfd
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
($decompose s #t)))
|
||||
|
||||
(set-who! string-normalize-nfkd
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
($decompose s #f)))
|
||||
|
||||
(set-who! string-normalize-nfc
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
($compose ($decompose s #t))))
|
||||
|
||||
(set-who! string-normalize-nfkc
|
||||
(lambda (s)
|
||||
(unless (string? s) (string-error who s))
|
||||
($compose ($decompose s #f))))
|
||||
)
|
||||
)
|
||||
)
|
||||
425
s/5_6.ss
Normal file
425
s/5_6.ss
Normal file
|
|
@ -0,0 +1,425 @@
|
|||
;;; 5_6.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; vector and sorting functions
|
||||
|
||||
(let ()
|
||||
(define ($vector->list v n)
|
||||
(let loop ([i (fx- n 1)] [ls '()])
|
||||
(if (fx> i 0)
|
||||
(loop
|
||||
(fx- i 2)
|
||||
(list* (vector-ref v (fx- i 1)) (vector-ref v i) ls))
|
||||
(if (fx= i 0) (cons (vector-ref v 0) ls) ls))))
|
||||
|
||||
(define ($list->vector ls n)
|
||||
(let ([v (make-vector n)])
|
||||
(let loop ([ls ls] [i 0])
|
||||
(unless (null? ls)
|
||||
(vector-set! v i (car ls))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (null? ls)
|
||||
(vector-set! v (fx+ i 1) (car ls))
|
||||
(loop (cdr ls) (fx+ i 2))))))
|
||||
v))
|
||||
|
||||
(define ($vector-copy! v1 v2 n)
|
||||
(if (fx<= n 10)
|
||||
(let loop ([i (fx- n 1)])
|
||||
(cond
|
||||
[(fx> i 0)
|
||||
(vector-set! v2 i (vector-ref v1 i))
|
||||
(let ([i (fx- i 1)]) (vector-set! v2 i (vector-ref v1 i)))
|
||||
(loop (fx- i 2))]
|
||||
[(fx= i 0) (vector-set! v2 i (vector-ref v1 i))]))
|
||||
($ptr-copy! v1 (constant vector-data-disp) v2
|
||||
(constant vector-data-disp) n)))
|
||||
|
||||
(define ($vector-copy v1 n)
|
||||
(let ([v2 (make-vector n)])
|
||||
($vector-copy! v1 v2 n)
|
||||
v2))
|
||||
|
||||
(set! vector->list
|
||||
(lambda (v)
|
||||
(unless (vector? v)
|
||||
($oops 'vector->list "~s is not a vector" v))
|
||||
($vector->list v (vector-length v))))
|
||||
|
||||
(set! list->vector
|
||||
(lambda (ls)
|
||||
($list->vector ls ($list-length ls 'list->vector))))
|
||||
|
||||
(set! vector-copy
|
||||
(lambda (v)
|
||||
(unless (vector? v)
|
||||
($oops 'vector-copy "~s is not a vector" v))
|
||||
($vector-copy v (vector-length v))))
|
||||
|
||||
(set-who! vector->immutable-vector
|
||||
(lambda (v)
|
||||
(cond
|
||||
[(immutable-vector? v) v]
|
||||
[(eqv? v '#()) ($tc-field 'null-immutable-vector ($tc))]
|
||||
[else
|
||||
(unless (vector? v) ($oops who "~s is not a vector" v))
|
||||
(let ([v2 (vector-copy v)])
|
||||
($vector-set-immutable! v2)
|
||||
v2)])))
|
||||
|
||||
(set-who! vector-fill!
|
||||
(lambda (v obj)
|
||||
(unless (mutable-vector? v) ($oops who "~s is not a mutable vector" v))
|
||||
(let ([n (vector-length v)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n))
|
||||
(vector-set! v i obj)))))
|
||||
|
||||
(set! fxvector->list
|
||||
(lambda (v)
|
||||
(unless (fxvector? v)
|
||||
($oops 'fxvector->list "~s is not an fxvector" v))
|
||||
(let loop ([i (fx- (fxvector-length v) 1)] [l '()])
|
||||
(if (fx> i 0)
|
||||
(loop
|
||||
(fx- i 2)
|
||||
(list* (fxvector-ref v (fx- i 1)) (fxvector-ref v i) l))
|
||||
(if (fx= i 0) (cons (fxvector-ref v 0) l) l)))))
|
||||
|
||||
(set! list->fxvector
|
||||
(lambda (x)
|
||||
(let ([v (make-fxvector ($list-length x 'list->fxvector))])
|
||||
(do ([ls x (cdr ls)] [i 0 (fx+ i 1)])
|
||||
((null? ls) v)
|
||||
(let ([n (car ls)])
|
||||
(unless (fixnum? n)
|
||||
($oops 'list->fxvector "~s is not a fixnum" n))
|
||||
(fxvector-set! v i n))))))
|
||||
|
||||
(set! fxvector-copy
|
||||
(lambda (fxv1)
|
||||
(unless (fxvector? fxv1)
|
||||
($oops 'fxvector-copy "~s is not an fxvector" fxv1))
|
||||
(let ([n (fxvector-length fxv1)])
|
||||
(let ([fxv2 (make-fxvector n)])
|
||||
(if (fx<= n 10)
|
||||
(let loop ([i (fx- n 1)])
|
||||
(cond
|
||||
[(fx> i 0)
|
||||
(fxvector-set! fxv2 i (fxvector-ref fxv1 i))
|
||||
(let ([i (fx- i 1)]) (fxvector-set! fxv2 i (fxvector-ref fxv1 i)))
|
||||
(loop (fx- i 2))]
|
||||
[(fx= i 0) (fxvector-set! fxv2 i (fxvector-ref fxv1 i))]))
|
||||
($ptr-copy! fxv1 (constant fxvector-data-disp) fxv2
|
||||
(constant fxvector-data-disp) n))
|
||||
fxv2))))
|
||||
|
||||
(set-who! fxvector->immutable-fxvector
|
||||
(lambda (v)
|
||||
(cond
|
||||
[(immutable-fxvector? v) v]
|
||||
[(eqv? v '#vfx()) ($tc-field 'null-immutable-fxvector ($tc))]
|
||||
[else
|
||||
(unless (fxvector? v) ($oops who "~s is not a fxvector" v))
|
||||
(let ([v2 (fxvector-copy v)])
|
||||
($fxvector-set-immutable! v2)
|
||||
v2)])))
|
||||
|
||||
(set! vector-map
|
||||
(case-lambda
|
||||
[(p v)
|
||||
(unless (procedure? p) ($oops 'vector-map "~s is not a procedure" p))
|
||||
(unless (vector? v) ($oops 'vector-map "~s is not a vector" v))
|
||||
(#3%vector-map p v)]
|
||||
[(p u v)
|
||||
(unless (procedure? p) ($oops 'vector-map "~s is not a procedure" p))
|
||||
(unless (vector? u) ($oops 'vector-map "~s is not a vector" u))
|
||||
(unless (vector? v) ($oops 'vector-map "~s is not a vector" v))
|
||||
(let ([n (vector-length u)])
|
||||
(unless (fx= (vector-length v) n)
|
||||
($oops 'vector-map "lengths of input vectors ~s and ~s differ" u v))
|
||||
(let f ([i (fx- n 1)])
|
||||
(if (fx> i 0)
|
||||
(let ([x1 (p (vector-ref u i) (vector-ref v i))]
|
||||
[x2 (let ([j (fx- i 1)])
|
||||
(p (vector-ref u j) (vector-ref v j)))])
|
||||
(let ([vout (f (fx- i 2))])
|
||||
(vector-set! vout i x1)
|
||||
(vector-set! vout (fx- i 1) x2)
|
||||
vout))
|
||||
(make-vector n
|
||||
(if (fx= i 0)
|
||||
(p (vector-ref u 0) (vector-ref v 0))
|
||||
0)))))]
|
||||
[(p u . v*)
|
||||
(unless (procedure? p) ($oops 'vector-map "~s is not a procedure" p))
|
||||
(unless (vector? u) ($oops 'vector-map "~s is not a vector" u))
|
||||
(for-each (lambda (v) (unless (vector? v) ($oops 'vector-map "~s is not a vector" v))) v*)
|
||||
(let ([n (vector-length u)])
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(unless (fx= (vector-length v) n)
|
||||
($oops 'vector-map "lengths of input vectors ~s and ~s differ" u v)))
|
||||
v*)
|
||||
(let f ([i (fx- n 1)])
|
||||
(if (fx> i 0)
|
||||
(let ([x1 (apply p
|
||||
(vector-ref u i)
|
||||
(map (lambda (v) (vector-ref v i)) v*))]
|
||||
[x2 (let ([j (fx- i 1)])
|
||||
(apply p
|
||||
(vector-ref u j)
|
||||
(map (lambda (v) (vector-ref v j)) v*)))])
|
||||
(let ([vout (f (fx- i 2))])
|
||||
(vector-set! vout i x1)
|
||||
(vector-set! vout (fx- i 1) x2)
|
||||
vout))
|
||||
(make-vector n
|
||||
(if (fx= i 0)
|
||||
(apply p
|
||||
(vector-ref u 0)
|
||||
(map (lambda (v) (vector-ref v 0)) v*))
|
||||
0)))))]))
|
||||
|
||||
(set! vector-for-each
|
||||
(case-lambda
|
||||
[(p v)
|
||||
(unless (procedure? p) ($oops 'vector-for-each "~s is not a procedure" p))
|
||||
(unless (vector? v) ($oops 'vector-for-each "~s is not a vector" v))
|
||||
(#3%vector-for-each p v)]
|
||||
[(p u v)
|
||||
(unless (procedure? p) ($oops 'vector-for-each "~s is not a procedure" p))
|
||||
(unless (vector? u) ($oops 'vector-for-each "~s is not a vector" u))
|
||||
(unless (vector? v) ($oops 'vector-for-each "~s is not a vector" v))
|
||||
(let ([n (vector-length u)])
|
||||
(unless (fx= (vector-length v) n)
|
||||
($oops 'vector-for-each "lengths of input vectors ~s and ~s differ" u v))
|
||||
(unless (fx= n 0)
|
||||
(let loop ([i 0])
|
||||
(let ([j (fx+ i 1)])
|
||||
(if (fx= j n)
|
||||
(p (vector-ref u i) (vector-ref v i))
|
||||
(begin
|
||||
(p (vector-ref u i) (vector-ref v i))
|
||||
(loop j)))))))]
|
||||
[(p u . v*)
|
||||
(unless (procedure? p) ($oops 'vector-for-each "~s is not a procedure" p))
|
||||
(unless (vector? u) ($oops 'vector-for-each "~s is not a vector" u))
|
||||
(for-each (lambda (v) (unless (vector? v) ($oops 'vector-for-each "~s is not a vector" v))) v*)
|
||||
(let ([n (vector-length u)])
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(unless (fx= (vector-length v) n)
|
||||
($oops 'vector-for-each "lengths of input vectors ~s and ~s differ" u v)))
|
||||
v*)
|
||||
(unless (fx= n 0)
|
||||
(let loop ([i 0])
|
||||
(let ([j (fx+ i 1)])
|
||||
(if (fx= j n)
|
||||
(apply p (vector-ref u i) (map (lambda (v) (vector-ref v i)) v*))
|
||||
(begin
|
||||
(apply p (vector-ref u i) (map (lambda (v) (vector-ref v i)) v*))
|
||||
(loop j)))))))]))
|
||||
|
||||
(let ()
|
||||
(module (dovsort!)
|
||||
;; dovsort! is a modified version of Olin Shiver's code for opportunistic
|
||||
;; vector merge sort, based on a version found in the MzScheme Version 360
|
||||
;; source code, which contains the following copyright notice.
|
||||
|
||||
;; This code is
|
||||
;; Copyright (c) 1998 by Olin Shivers.
|
||||
;; The terms are: You may do as you please with this code, as long as
|
||||
;; you do not delete this notice or hold me responsible for any outcome
|
||||
;; related to its use.
|
||||
;;
|
||||
;; Blah blah blah. Don't you think source files should contain more lines
|
||||
;; of code than copyright notice?
|
||||
|
||||
;; This merge sort is "opportunistic" -- the leaves of the merge tree are
|
||||
;; contiguous runs of already sorted elements in the vector. In the best
|
||||
;; case -- an already sorted vector -- it runs in linear time. Worst case
|
||||
;; is still O(n lg n) time.
|
||||
|
||||
;; RKD: performance is a bit worse on average than a straightforward
|
||||
;; merge-sort for random input vectors, but speed for sorted or mostly
|
||||
;; sorted vectors is much better.
|
||||
|
||||
;; RKD: The following issues with the original code have been addressed:
|
||||
;; - tail-len is bound but not used.
|
||||
;; - len is computed before it is known to be needed; it would be
|
||||
;; (marginally) better to remove the binding for len and replace
|
||||
;; (= pfxlen len) with (= pfxlen (- r l)).
|
||||
;; - In the %vector-merge-sort! loop computing pfxlen2, (fx<= j pfxlen)
|
||||
;; should be (fx<= j*2 pfxlen); otherwise pfxlen2 is actually the first
|
||||
;; power of two greater than pfxlen. Fixing this improved performance by
|
||||
;; about 20% for sort using predicate < for a list of 10^6 random
|
||||
;; integers between 0 and 1000. (pfxlen2 computation later flushed
|
||||
;; entirely; just using pfxlen, which is simpler and usually faster.)
|
||||
;; - The temp need not be a copy of the input vector, just a vector of
|
||||
;; the appropriate length.
|
||||
(define (merge elt< target v1 v2 l len1 len2)
|
||||
; assumes target != v1, but v2 may be v1 or target
|
||||
; merge v1[l,l+len1-1] and v2[l+len1,l+len1+len2-1] into target[l,l+len1+len2-1]
|
||||
(let* ([r1 (fx+ l len1)] [r2 (fx+ r1 len2)])
|
||||
(let lp ([i l] [j l] [x (vector-ref v1 l)] [k r1] [y (vector-ref v2 r1)])
|
||||
(if (elt< y x)
|
||||
(let ([k (fx+ k 1)])
|
||||
(vector-set! target i y)
|
||||
(if (fx< k r2)
|
||||
(lp (fx+ i 1) j x k (vector-ref v2 k))
|
||||
(vblit v1 j target (fx+ i 1) r1)))
|
||||
(let ([j (fx+ j 1)])
|
||||
(vector-set! target i x)
|
||||
(if (fx< j r1)
|
||||
(lp (fx+ i 1) j (vector-ref v1 j) k y)
|
||||
(unless (eq? v2 target)
|
||||
(vblit v2 k target (fx+ i 1) r2))))))))
|
||||
(define (vblit fromv j tov i n)
|
||||
(let lp ([j j] [i i])
|
||||
(vector-set! tov i (vector-ref fromv j))
|
||||
(let ([j (fx+ j 1)])
|
||||
(unless (fx= j n) (lp j (fx+ i 1))))))
|
||||
(define (getrun elt< v l r) ; assumes l < r
|
||||
(let lp ([i (fx+ l 1)] [x (vector-ref v l)])
|
||||
(if (fx= i r)
|
||||
(fx- i l)
|
||||
(let ([y (vector-ref v i)])
|
||||
(if (elt< y x) (fx- i l) (lp (fx+ i 1) y))))))
|
||||
(define (dovsort! elt< v0 n)
|
||||
(let ([temp0 (make-vector n)])
|
||||
(define (recur l want)
|
||||
; sort v0[l,l+len-1] for some len where 0 < want <= len <= (n-l).
|
||||
; that is, sort *at least* want elements in v0 starting at index l.
|
||||
; may put the result into either v0[l,l+len-1] or temp0[l,l+len-1].
|
||||
; does not alter either vector outside this range. returns two
|
||||
; values: the number of values sorted and the vector holding the
|
||||
; sorted values.
|
||||
(let lp ([pfxlen (getrun elt< v0 l n)] [v v0] [temp temp0])
|
||||
; v[l,l+pfxlen-1] holds a sorted version of v0[l,l+pfxlen-1]
|
||||
(if (or (fx>= pfxlen want) (fx= pfxlen (fx- n l)))
|
||||
(values pfxlen v)
|
||||
(let-values ([(outlen outvec) (recur (fx+ l pfxlen) pfxlen)])
|
||||
(merge elt< temp v outvec l pfxlen outlen)
|
||||
(lp (fx+ pfxlen outlen) temp v)))))
|
||||
; return v0 or temp0 containing sorted values
|
||||
(let-values ([(outlen outvec) (recur 0 n)]) outvec))))
|
||||
|
||||
(define (dolsort elt< ls n)
|
||||
(cond
|
||||
[(fx= n 1) (cons (car ls) '())]
|
||||
[(fx= n 2)
|
||||
(let ([x (car ls)] [y (cadr ls)])
|
||||
(if (elt< y x) (list y x) (list x y)))]
|
||||
[else
|
||||
(let ([i (fxsrl n 1)])
|
||||
(dolmerge elt<
|
||||
(dolsort elt< ls i)
|
||||
(dolsort elt< (list-tail ls i) (fx- n i))))]))
|
||||
|
||||
(define (dolmerge elt< ls1 ls2)
|
||||
(cond
|
||||
[(null? ls1) ls2]
|
||||
[(null? ls2) ls1]
|
||||
[(elt< (car ls2) (car ls1))
|
||||
(cons (car ls2) (dolmerge elt< ls1 (cdr ls2)))]
|
||||
[else (cons (car ls1) (dolmerge elt< (cdr ls1) ls2))]))
|
||||
|
||||
(define (dolsort! elt< ls n loc)
|
||||
(if (fx= n 1)
|
||||
(begin (set-cdr! ls '()) ls)
|
||||
(let ([i (fxsrl n 1)])
|
||||
(let ([tail (list-tail ls i)])
|
||||
(dolmerge! elt<
|
||||
(dolsort! elt< ls i loc)
|
||||
(dolsort! elt< tail (fx- n i) loc)
|
||||
loc)))))
|
||||
|
||||
(define (dolmerge! elt< ls1 ls2 loc)
|
||||
(let loop ([ls1 ls1] [ls2 ls2] [loc loc])
|
||||
(cond
|
||||
[(null? ls1) (set-cdr! loc ls2)]
|
||||
[(null? ls2) (set-cdr! loc ls1)]
|
||||
[(elt< (car ls2) (car ls1))
|
||||
(set-cdr! loc ls2)
|
||||
(loop ls1 (cdr ls2) ls2)]
|
||||
[else (set-cdr! loc ls1) (loop (cdr ls1) ls2 ls1)]))
|
||||
(cdr loc))
|
||||
|
||||
(set-who! vector-sort
|
||||
(lambda (elt< v)
|
||||
(unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
|
||||
(unless (vector? v) ($oops who "~s is not a vector" v))
|
||||
(let ([n (vector-length v)])
|
||||
(if (fx<= n 1) v (dovsort! elt< ($vector-copy v n) n)))))
|
||||
|
||||
(set-who! vector-sort!
|
||||
(lambda (elt< v)
|
||||
(unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
|
||||
(unless (mutable-vector? v) ($oops who "~s is not a mutable vector" v))
|
||||
(let ([n (vector-length v)])
|
||||
(unless (fx<= n 1)
|
||||
(let ([outvec (dovsort! elt< v n)])
|
||||
(unless (eq? outvec v)
|
||||
($vector-copy! outvec v n)))))))
|
||||
|
||||
(set-who! list-sort
|
||||
(lambda (elt< ls)
|
||||
(unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
|
||||
(let ([n ($list-length ls who)])
|
||||
(if (fx< n 25)
|
||||
(if (fx<= n 1) ls (dolsort elt< ls n))
|
||||
($vector->list (dovsort! elt< ($list->vector ls n) n) n)))))
|
||||
|
||||
(set-who! sort
|
||||
(lambda (elt< ls)
|
||||
(unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
|
||||
(let ([n ($list-length ls who)])
|
||||
(if (fx< n 25)
|
||||
(if (fx<= n 1) ls (dolsort elt< ls n))
|
||||
($vector->list (dovsort! elt< ($list->vector ls n) n) n)))))
|
||||
|
||||
(set-who! merge
|
||||
(lambda (elt< ls1 ls2)
|
||||
(unless (procedure? elt<)
|
||||
($oops who "~s is not a procedure" elt<))
|
||||
($list-length ls1 who)
|
||||
($list-length ls2 who)
|
||||
(dolmerge elt< ls1 ls2)))
|
||||
|
||||
(set-who! sort!
|
||||
(lambda (elt< ls)
|
||||
(unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
|
||||
(let ([n ($list-length ls who)])
|
||||
(if (fx< n 25)
|
||||
(if (fx<= n 1) ls (dolsort! elt< ls n (list '())))
|
||||
(let ([v (dovsort! elt< ($list->vector ls n) n)])
|
||||
(let loop ([ls ls] [i 0])
|
||||
(unless (null? ls)
|
||||
(set-car! ls (vector-ref v i))
|
||||
(let ([ls (cdr ls)])
|
||||
(unless (null? ls)
|
||||
(set-car! ls (vector-ref v (fx+ i 1)))
|
||||
(loop (cdr ls) (fx+ i 2))))))
|
||||
ls)))))
|
||||
|
||||
(set-who! merge!
|
||||
(lambda (elt< ls1 ls2)
|
||||
(unless (procedure? elt<)
|
||||
($oops who "~s is not a procedure" elt<))
|
||||
($list-length ls1 who)
|
||||
($list-length ls2 who)
|
||||
(dolmerge! elt< ls1 ls2 (list '())))))
|
||||
)
|
||||
206
s/5_7.ss
Normal file
206
s/5_7.ss
Normal file
|
|
@ -0,0 +1,206 @@
|
|||
;;; 5_7.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; symbol functions
|
||||
|
||||
(begin
|
||||
(define property-list
|
||||
(lambda (s)
|
||||
(unless (symbol? s)
|
||||
($oops 'property-list "~s is not a symbol" s))
|
||||
(list-copy ($symbol-property-list s))))
|
||||
|
||||
(define putprop
|
||||
(lambda (s p v)
|
||||
(if (symbol? s)
|
||||
(let pt ([pl ($symbol-property-list s)])
|
||||
(cond
|
||||
[(null? pl)
|
||||
($set-symbol-property-list! s
|
||||
(cons p (cons v ($symbol-property-list s))))]
|
||||
[(eq? (car pl) p)
|
||||
(set-car! (cdr pl) v)]
|
||||
[else (pt (cdr (cdr pl)))]))
|
||||
($oops 'putprop "~s is not a symbol" s))))
|
||||
|
||||
(define remprop
|
||||
(lambda (s p)
|
||||
(if (symbol? s)
|
||||
(let pt ([pl ($symbol-property-list s)] [prev #f])
|
||||
(cond
|
||||
[(null? pl) (void)]
|
||||
[(eq? (car pl) p)
|
||||
(if prev
|
||||
(set-cdr! prev (cdr (cdr pl)))
|
||||
($set-symbol-property-list! s (cdr (cdr pl))))]
|
||||
[else (pt (cdr (cdr pl)) (cdr pl))]))
|
||||
($oops 'remprop "~s is not a symbol" s))))
|
||||
|
||||
(define $sgetprop
|
||||
(lambda (s p d)
|
||||
(unless (symbol? s) ($oops '$sgetprop "~s is not a symbol" s))
|
||||
(let gt ([pl ($system-property-list s)])
|
||||
(if (null? pl)
|
||||
d
|
||||
(if (eq? (car pl) p)
|
||||
(car (cdr pl))
|
||||
(gt (cdr (cdr pl))))))))
|
||||
|
||||
(define $sputprop
|
||||
(lambda (s p v)
|
||||
(unless (symbol? s) ($oops '$sputprop "~s is not a symbol" s))
|
||||
(let ((plist ($system-property-list s)))
|
||||
(let pt ([pl plist])
|
||||
(if (null? pl)
|
||||
($set-system-property-list! s (cons p (cons v plist)))
|
||||
(if (eq? (car pl) p)
|
||||
(set-car! (cdr pl) v)
|
||||
(pt (cdr (cdr pl)))))))))
|
||||
|
||||
(define $sremprop
|
||||
(lambda (s p)
|
||||
(unless (symbol? s) ($oops '$sremprop "~s is not a symbol" s))
|
||||
(let rp ([pl ($system-property-list s)] [prev #f])
|
||||
(unless (null? pl)
|
||||
(if (eq? (car pl) p)
|
||||
(if prev
|
||||
(set-cdr! prev (cdr (cdr pl)))
|
||||
($set-system-property-list! s (cdr (cdr pl))))
|
||||
(rp (cdr (cdr pl)) (cdr pl)))))))
|
||||
)
|
||||
|
||||
(eval-when (compile) (optimize-level 3))
|
||||
|
||||
(let ([prefix "g"] [count 0])
|
||||
(define generate-unique-name
|
||||
; a-z must come first in alphabet. separator must not be in alphabet.
|
||||
(let ([suffix 0])
|
||||
(define unique-id (foreign-procedure "(cs)unique_id" () scheme-object))
|
||||
(define (make-session-key)
|
||||
(define alphabet "abcdefghijklmnopqrstuvwxyz0123456789")
|
||||
(define separator #\-)
|
||||
(define b (string-length alphabet))
|
||||
(define digit->char (lambda (n) (string-ref alphabet n)))
|
||||
(list->string
|
||||
(let loop ([n (unique-id)] [a (list separator)])
|
||||
(if (< n b)
|
||||
; ensure name starts with letter. assumes a-z first in alphabet.
|
||||
(if (< n 26)
|
||||
(cons (digit->char n) a)
|
||||
(cons* (string-ref alphabet 0) (digit->char n) a))
|
||||
(loop (quotient n b) (cons (digit->char (remainder n b)) a))))))
|
||||
(define (session-key)
|
||||
(or $session-key
|
||||
(let ([k (make-session-key)])
|
||||
(set! $session-key k)
|
||||
(set! suffix -1)
|
||||
k)))
|
||||
(lambda ()
|
||||
(define alphabet "0123456789")
|
||||
(define b (string-length alphabet))
|
||||
(define digit->char (lambda (n) (string-ref alphabet n)))
|
||||
(let* ([k (session-key)] [n (string-length k)])
|
||||
(set! suffix (fx+ suffix 1))
|
||||
(let f ([i 0])
|
||||
(if (fx= i n)
|
||||
(let g ([suffix suffix] [n (fx+ n 1)])
|
||||
(if (< suffix b)
|
||||
(let ([s (make-string n)])
|
||||
(string-set! s i (digit->char suffix))
|
||||
s)
|
||||
(let ([s (g (quotient suffix b) (fx+ n 1))])
|
||||
(string-set! s (fx+ i (fx- (string-length s) n))
|
||||
(digit->char (remainder suffix b)))
|
||||
s)))
|
||||
(let ([s (f (fx+ i 1))])
|
||||
(string-set! s i (string-ref k i))
|
||||
s)))))))
|
||||
(define generate-pretty-name
|
||||
(lambda ()
|
||||
(let ([count (let ([n count]) (set! count (+ n 1)) n)]
|
||||
[prefix prefix])
|
||||
(if (and (string? prefix) (fixnum? count))
|
||||
(let ([n1 (string-length prefix)])
|
||||
(let l1 ([n (fx+ n1 1)] [d 10])
|
||||
(if (fx> d count)
|
||||
(let ([s (make-string n)])
|
||||
(let l2 ([i (fx- n1 1)])
|
||||
(unless (fx< i 0)
|
||||
(string-set! s i (string-ref prefix i))
|
||||
(l2 (fx- i 1))))
|
||||
(let l3 ([i (fx- n 1)] [q count])
|
||||
(unless (fx< i n1)
|
||||
(string-set! s i
|
||||
(string-ref "0123456789" (fxremainder q 10)))
|
||||
(l3 (fx- i 1) (fxquotient q 10))))
|
||||
s)
|
||||
(l1 (fx+ n 1) (fx* d 10)))))
|
||||
(parameterize ([print-radix 10])
|
||||
(format "~a~a" prefix count))))))
|
||||
(define $strings->gensym
|
||||
(foreign-procedure "(cs)s_strings_to_gensym"
|
||||
(scheme-object scheme-object)
|
||||
scheme-object))
|
||||
(set! $gensym->pretty-name
|
||||
(lambda (x)
|
||||
(with-tc-mutex
|
||||
(cond
|
||||
[($symbol-name x) => cdr] ; someone beat us to it
|
||||
[else
|
||||
(let ([name (generate-pretty-name)])
|
||||
($set-symbol-name! x (cons #f name))
|
||||
name)]))))
|
||||
(set-who! gensym->unique-string
|
||||
(lambda (sym)
|
||||
(unless (symbol? sym) ($oops who "~s is not a gensym" sym))
|
||||
(let ([name ($symbol-name sym)])
|
||||
(or (and (pair? name) (car name)) ; get out quick if name already recorded
|
||||
(begin
|
||||
(unless (or (not name) (pair? name)) ($oops who "~s is not a gensym" sym))
|
||||
(with-tc-mutex
|
||||
; grab name again once safely inside the critical section
|
||||
(let ([name ($symbol-name sym)])
|
||||
(if (not name)
|
||||
(let ([uname (generate-unique-name)])
|
||||
($set-symbol-name! sym
|
||||
(cons uname (generate-pretty-name)))
|
||||
($intern-gensym sym)
|
||||
uname)
|
||||
(or (car name)
|
||||
(let ([uname (generate-unique-name)])
|
||||
(set-car! name uname)
|
||||
($intern-gensym sym)
|
||||
uname))))))))))
|
||||
(set! gensym-prefix
|
||||
(case-lambda
|
||||
[() prefix]
|
||||
[(x) (set! prefix x)]))
|
||||
(set! gensym-count
|
||||
(case-lambda
|
||||
[() count]
|
||||
[(x)
|
||||
(unless (and (or (fixnum? x) (bignum? x)) (>= x 0))
|
||||
($oops 'gensym-count "~s is not a nonnegative integer" x))
|
||||
(set! count x)]))
|
||||
(set-who! gensym
|
||||
(case-lambda
|
||||
[() (#3%gensym)]
|
||||
[(pretty-name)
|
||||
(unless (string? pretty-name) ($oops who "~s is not a string" pretty-name))
|
||||
(#3%gensym pretty-name)]
|
||||
[(pretty-name unique-name)
|
||||
(unless (string? pretty-name) ($oops who "~s is not a string" pretty-name))
|
||||
(unless (string? unique-name) ($oops who "~s is not a string" unique-name))
|
||||
($strings->gensym pretty-name unique-name)])))
|
||||
505
s/6.ss
Normal file
505
s/6.ss
Normal file
|
|
@ -0,0 +1,505 @@
|
|||
;;; 6.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define with-output-to-string
|
||||
(lambda (th)
|
||||
(unless (procedure? th)
|
||||
($oops 'with-output-to-string "~s is not a procedure" th))
|
||||
(parameterize ([current-output-port (open-output-string)])
|
||||
(th)
|
||||
(get-output-string (current-output-port)))))
|
||||
|
||||
(define with-input-from-string
|
||||
(lambda (s th)
|
||||
(unless (string? s)
|
||||
($oops 'with-input-from-string "~s is not a string" s))
|
||||
(unless (procedure? th)
|
||||
($oops 'with-input-from-string "~s is not a procedure" th))
|
||||
(let ([p (open-input-string s)])
|
||||
(call-with-values
|
||||
(lambda () (parameterize ([current-input-port p]) (th)))
|
||||
(lambda v (apply values v))))))
|
||||
|
||||
(let ()
|
||||
(define getwd
|
||||
(if (foreign-entry? "(cs)s_getwd")
|
||||
(foreign-procedure "(cs)s_getwd" () string)
|
||||
(lambda ()
|
||||
(let ([p (process "exec /bin/pwd")])
|
||||
(let ([ip (car p)] [op (open-output-string)])
|
||||
(let f ()
|
||||
(let ([c (read-char ip)])
|
||||
(if (or (eof-object? c) (char=? c #\newline))
|
||||
(begin
|
||||
(close-output-port (cadr p))
|
||||
(close-input-port ip)
|
||||
(get-output-string op))
|
||||
(begin (write-char c op) (f))))))))))
|
||||
(define chdir
|
||||
(foreign-procedure "(cs)s_chdir"
|
||||
(string)
|
||||
integer-32))
|
||||
(define $cd
|
||||
(case-lambda
|
||||
[(who) (or (getwd) ($oops who "cannot determine current directory"))]
|
||||
[(dir who)
|
||||
(unless (string? dir) ($oops who "~s is not a string" dir))
|
||||
(unless (= (chdir dir) 0)
|
||||
($oops who "cannot set current directory to ~s" dir))]))
|
||||
(set-who! current-directory
|
||||
(case-lambda
|
||||
[() ($cd who)]
|
||||
[(dir) ($cd dir who)]))
|
||||
(set-who! cd
|
||||
(case-lambda
|
||||
[() ($cd who)]
|
||||
[(dir) ($cd dir who)])))
|
||||
|
||||
(let ()
|
||||
(define who 'mkdir)
|
||||
|
||||
(define fp (foreign-procedure "(cs)mkdir" (string uptr) ptr))
|
||||
|
||||
(define (do-mkdir path mode)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(unless (fixnum? mode) ($oops who "~s is not a fixnum" mode))
|
||||
(let ([x (fp path mode)])
|
||||
(cond
|
||||
[(eqv? x #t) (void)]
|
||||
[(string? x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"cannot create ~s: ~(~a~)" path x)]
|
||||
[else
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"cannot create ~s" path)])))
|
||||
|
||||
(set! mkdir
|
||||
(case-lambda
|
||||
[(path) (do-mkdir path #o777)]
|
||||
[(path mode) (do-mkdir path mode)])))
|
||||
|
||||
(define-who chmod
|
||||
(let ([fp (foreign-procedure "(cs)chmod" (string fixnum) ptr)])
|
||||
(lambda (path mode)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(unless (fixnum? mode) ($oops who "~s is not a fixnum" mode))
|
||||
(let ([x (fp path mode)])
|
||||
(cond
|
||||
[(eqv? x #t) (void)]
|
||||
[(string? x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"cannot modify ~s: ~(~a~)" path x)]
|
||||
[else
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"cannot modify ~s" path)])))))
|
||||
|
||||
(define-who get-mode
|
||||
(let ([fp (foreign-procedure "(cs)getmod" (string boolean) ptr)])
|
||||
(rec get-mode
|
||||
(case-lambda
|
||||
[(path) (get-mode path #t)]
|
||||
[(path follow?)
|
||||
(define (err x)
|
||||
(if (string? x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~s: ~(~a~)" path x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~s" path)))
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(let ([x (fp path follow?)])
|
||||
(if (fixnum? x)
|
||||
x
|
||||
(err x)))]))))
|
||||
|
||||
(let ()
|
||||
(define file-x-time
|
||||
(lambda (who path-fp fd-fp file follow?)
|
||||
(define (path-err path x)
|
||||
(if (string? x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~s: ~(~a~)" path x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~s" path)))
|
||||
(unless (or (string? file) (and (port? file) (file-port? file)))
|
||||
($oops who "~s is not a string or file port" file))
|
||||
(if (string? file)
|
||||
(let ([x (path-fp file follow?)])
|
||||
(if (pair? x)
|
||||
(make-time 'time-utc (cdr x) (car x))
|
||||
(path-err file x)))
|
||||
(let ([x (fd-fp (port-file-descriptor file))])
|
||||
(cond
|
||||
[(pair? x) (make-time 'time-utc (cdr x) (car x))]
|
||||
[(string? x) ($oops who "failed for ~s: ~(~a~)" file x)]
|
||||
[else ($oops who "failed for ~s" file)])))))
|
||||
|
||||
(define-syntax define-file-x-time
|
||||
(syntax-rules ()
|
||||
[(_ name path-name fd-name)
|
||||
(set-who! name
|
||||
(let ([path-fp (foreign-procedure path-name (string boolean) ptr)]
|
||||
[fd-fp (foreign-procedure fd-name (fixnum) ptr)])
|
||||
(case-lambda
|
||||
[(file) (file-x-time who path-fp fd-fp file #t)]
|
||||
[(file follow?) (file-x-time who path-fp fd-fp file follow?)])))]))
|
||||
|
||||
(define-file-x-time file-access-time "(cs)path_atime" "(cs)fd_atime")
|
||||
(define-file-x-time file-change-time "(cs)path_ctime" "(cs)fd_atime")
|
||||
(define-file-x-time file-modification-time "(cs)path_mtime" "(cs)fd_mtime"))
|
||||
|
||||
(define directory-separator
|
||||
(lambda ()
|
||||
(#2%directory-separator)))
|
||||
|
||||
(define directory-separator?
|
||||
(lambda (c)
|
||||
(unless (char? c)
|
||||
($oops 'directory-separator? "~s is not a character" c))
|
||||
(#3%directory-separator? c)))
|
||||
|
||||
(define-who directory-list
|
||||
(let ([dl (if-feature windows
|
||||
(let ([wl (foreign-procedure "(cs)find_files" (string) scheme-object)])
|
||||
(lambda (path)
|
||||
(let ([n (string-length path)])
|
||||
(unless (and (fx> n 0)
|
||||
(let nostars? ([i 0])
|
||||
(or (fx= i n)
|
||||
(and (not (char=? (string-ref path i) #\*))
|
||||
(nostars? (fx+ i 1))))))
|
||||
($oops who "invalid directory name ~s" path))
|
||||
(wl (if (memv (string-ref path (fx- n 1)) '(#\\ #\/ #\:))
|
||||
(string-append path "*")
|
||||
(string-append path "\\*"))))))
|
||||
(foreign-procedure "(cs)directory_list" (string) scheme-object))])
|
||||
(lambda (path)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(let ([bv* (dl path)])
|
||||
(if (string? bv*)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~a: ~(~a~)" path bv*)
|
||||
(remp (lambda (s)
|
||||
(let ([n (string-length s)])
|
||||
(or (and (fx= n 1) (char=? (string-ref s 0) #\.))
|
||||
(and (fx= n 2)
|
||||
(char=? (string-ref s 0) #\.)
|
||||
(char=? (string-ref s 1) #\.)))))
|
||||
(map (if-feature windows
|
||||
(lambda (bv) (utf16->string bv 'little #t))
|
||||
utf8->string)
|
||||
bv*)))))))
|
||||
|
||||
(define-who file-exists?
|
||||
(let ([fp (foreign-procedure "(cs)file_existsp" (string boolean) boolean)])
|
||||
(rec file-exists?
|
||||
(case-lambda
|
||||
[(path) (file-exists? path #t)]
|
||||
[(path follow?)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(fp path follow?)]))))
|
||||
|
||||
(define-who #(r6rs: file-exists?)
|
||||
(lambda (path)
|
||||
(#2%file-exists? path #t)))
|
||||
|
||||
(define-who file-regular?
|
||||
(let ([fp (foreign-procedure "(cs)file_regularp" (string boolean) boolean)])
|
||||
(rec file-regular?
|
||||
(case-lambda
|
||||
[(path) (file-regular? path #t)]
|
||||
[(path follow?)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(fp path follow?)]))))
|
||||
|
||||
(define-who file-directory?
|
||||
(let ([fp (foreign-procedure "(cs)file_directoryp" (string boolean) boolean)])
|
||||
(rec file-directory?
|
||||
(case-lambda
|
||||
[(path) (file-directory? path #t)]
|
||||
[(path follow?)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(fp path follow?)]))))
|
||||
|
||||
(define-who file-symbolic-link?
|
||||
(let ([fp (foreign-procedure "(cs)file_symbolic_linkp" (string) boolean)])
|
||||
(lambda (path)
|
||||
(unless (string? path) ($oops who "~s is not a string" path))
|
||||
(fp path))))
|
||||
|
||||
(let ()
|
||||
(define fp-delete-file
|
||||
(foreign-procedure "(cs)delete_file"
|
||||
(string)
|
||||
scheme-object))
|
||||
|
||||
(define fp-delete-directory
|
||||
(foreign-procedure "(cs)delete_directory"
|
||||
(string)
|
||||
scheme-object))
|
||||
|
||||
(define (do-delete who fp path error?)
|
||||
(unless (string? path)
|
||||
($oops who "~s is not a string" path))
|
||||
(let ([x (fp path)])
|
||||
(if error?
|
||||
(cond
|
||||
[(eqv? x #t) (void)]
|
||||
[(string? x)
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~a: ~(~a~)" path x)]
|
||||
[else
|
||||
($oops/c who
|
||||
(make-i/o-filename-error path)
|
||||
"failed for ~a" path)])
|
||||
(eq? x #t))))
|
||||
|
||||
(set-who! delete-file
|
||||
(case-lambda
|
||||
[(path) (do-delete who fp-delete-file path #f)]
|
||||
[(path error?) (do-delete who fp-delete-file path error?)]))
|
||||
|
||||
(set-who! #(r6rs: delete-file) ; implicit rec
|
||||
(lambda (path)
|
||||
(do-delete who fp-delete-file path #t)))
|
||||
|
||||
(set-who! delete-directory
|
||||
(case-lambda
|
||||
[(path) (do-delete who fp-delete-directory path #f)]
|
||||
[(path error?) (do-delete who fp-delete-directory path error?)])))
|
||||
|
||||
(let ()
|
||||
(define fp (foreign-procedure "(cs)rename_file" (string string) ptr))
|
||||
|
||||
(set-who! rename-file
|
||||
(lambda (path1 path2)
|
||||
(unless (string? path1)
|
||||
($oops who "~s is not a string" path1))
|
||||
(unless (string? path2)
|
||||
($oops who "~s is not a string" path2))
|
||||
(let ([x (fp path1 path2)])
|
||||
(cond
|
||||
[(eqv? x #t) (void)]
|
||||
[(string? x)
|
||||
($oops/c who
|
||||
(condition
|
||||
(make-i/o-filename-error path1)
|
||||
(make-i/o-filename-error path2))
|
||||
"cannot rename ~s to ~s: ~(~a~)" path1 path2 x)]
|
||||
[else
|
||||
($oops/c who
|
||||
(condition
|
||||
(make-i/o-filename-error path1)
|
||||
(make-i/o-filename-error path2))
|
||||
"cannot rename ~s to ~s" path1 path2)])))))
|
||||
|
||||
;;; path procedures
|
||||
|
||||
(let ()
|
||||
(define windows? (if-feature windows #t #f))
|
||||
|
||||
(define directory-separator-predicate
|
||||
(lambda (s)
|
||||
(if (and windows?
|
||||
(string? s)
|
||||
(let ([n (string-length s)])
|
||||
(and (fx>= n 4)
|
||||
(char=? (string-ref s 0) #\\)
|
||||
(char=? (string-ref s 1) #\\)
|
||||
(char=? (string-ref s 2) #\?)
|
||||
(char=? (string-ref s 3) #\\))))
|
||||
(lambda (c) (char=? c #\\))
|
||||
directory-separator?)))
|
||||
|
||||
(define path-base
|
||||
(lambda (s n)
|
||||
(cond
|
||||
[(and windows?
|
||||
(fx>= n 2)
|
||||
(char=? (string-ref s 1) #\:)
|
||||
(let ([c (string-ref s 0)])
|
||||
(or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
|
||||
(if (and (fx>= n 3) (directory-separator? (string-ref s 2))) 3 2)]
|
||||
[(and windows?
|
||||
(fx>= n 4)
|
||||
(char=? (string-ref s 0) #\\)
|
||||
(char=? (string-ref s 1) #\\)
|
||||
(char=? (string-ref s 2) #\?)
|
||||
(char=? (string-ref s 3) #\\))
|
||||
(cond
|
||||
[(and (fx>= n 6)
|
||||
(char=? (string-ref s 5) #\:)
|
||||
(let ([c (string-ref s 4)])
|
||||
(or (char<=? #\a c #\z) (char<=? #\A c #\Z))))
|
||||
(if (and (fx>= n 7) (char=? (string-ref s 6) #\\)) 7 6)]
|
||||
[(and windows?
|
||||
(fx>= n 8)
|
||||
(char-ci=? (string-ref s 4) #\U)
|
||||
(char-ci=? (string-ref s 5) #\N)
|
||||
(char-ci=? (string-ref s 6) #\C)
|
||||
(char=? (string-ref s 7) #\\))
|
||||
(let loop ([i (if (and (fx>= n 9) (char=? (string-ref s 8) #\\)) 9 8)])
|
||||
(if (or (fx= i n) (char=? (string-ref s i) #\\))
|
||||
i
|
||||
(loop (fx+ i 1))))]
|
||||
[else 4])]
|
||||
[(and windows?
|
||||
(fx>= n 2)
|
||||
(directory-separator? (string-ref s 0))
|
||||
(directory-separator? (string-ref s 1)))
|
||||
(let loop ([i 2])
|
||||
(if (or (fx= i n) (directory-separator? (string-ref s i)))
|
||||
i
|
||||
(loop (fx+ i 1))))]
|
||||
[(and (fx>= n 1) (directory-separator? (string-ref s 0))) 1]
|
||||
[(and (fx>= n 1) (char=? (string-ref s 0) #\.))
|
||||
(if (or (fx= n 1) (directory-separator? (string-ref s 1)))
|
||||
1
|
||||
(if (and (char=? (string-ref s 1) #\.)
|
||||
(or (fx= n 2) (directory-separator? (string-ref s 2))))
|
||||
2
|
||||
0))]
|
||||
[(and (fx>= n 1) (char=? (string-ref s 0) #\~))
|
||||
(if (or (fx= n 1) (directory-separator? (string-ref s 1)))
|
||||
1
|
||||
(let loop ([i 2])
|
||||
(if (or (fx= i n) (directory-separator? (string-ref s i)))
|
||||
i
|
||||
(loop (fx+ i 1)))))]
|
||||
[else 0])))
|
||||
|
||||
(set-who! path-absolute?
|
||||
(lambda (s)
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let ([n (string-length s)])
|
||||
(or (and (fx>= n 1) (directory-separator? (string-ref s 0)))
|
||||
(and (fx>= n 1) (char=? (string-ref s 0) #\~))
|
||||
(and windows?
|
||||
(fx>= n 3)
|
||||
(char=? (string-ref s 1) #\:)
|
||||
(let ([c (string-ref s 0)])
|
||||
(or (char<=? #\a c #\z) (char<=? #\A c #\Z)))
|
||||
(directory-separator? (string-ref s 2)))))))
|
||||
|
||||
(set-who! path-extension
|
||||
(lambda (s)
|
||||
(define directory-separator? (directory-separator-predicate s))
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let* ([n (string-length s)] [base (path-base s n)])
|
||||
(let loop ([i n])
|
||||
(let ([i (fx- i 1)])
|
||||
(if (or (fx< i base) (directory-separator? (string-ref s i)))
|
||||
""
|
||||
(if (char=? (string-ref s i) #\.)
|
||||
(if (and (fx= i (fx- n 1))
|
||||
(or (fx= i base)
|
||||
(directory-separator? (string-ref s (fx- i 1)))
|
||||
(and (char=? (string-ref s (fx- i 1)) #\.)
|
||||
(or (fx= (fx- i 1) base)
|
||||
(directory-separator? (string-ref s (fx- i 2)))))))
|
||||
""
|
||||
(substring s (fx+ i 1) n))
|
||||
(loop i))))))))
|
||||
|
||||
(set-who! path-root
|
||||
(lambda (s)
|
||||
(define directory-separator? (directory-separator-predicate s))
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let* ([n (string-length s)] [base (path-base s n)])
|
||||
(let loop ([i n])
|
||||
(let ([i (fx- i 1)])
|
||||
(if (or (fx< i base) (directory-separator? (string-ref s i)))
|
||||
s
|
||||
(if (char=? (string-ref s i) #\.)
|
||||
(if (and (fx= i (fx- n 1))
|
||||
(or (fx= i base)
|
||||
(directory-separator? (string-ref s (fx- i 1)))
|
||||
(and (char=? (string-ref s (fx- i 1)) #\.)
|
||||
(or (fx= (fx- i 1) base)
|
||||
(directory-separator? (string-ref s (fx- i 2)))))))
|
||||
s
|
||||
(substring s 0 i))
|
||||
(loop i))))))))
|
||||
|
||||
(set-who! path-last
|
||||
(lambda (s)
|
||||
(define directory-separator? (directory-separator-predicate s))
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let* ([n (string-length s)] [base (path-base s n)])
|
||||
(let loop ([i n])
|
||||
(cond
|
||||
[(fx= i base) (if (fx= base 0) s (substring s base n))]
|
||||
[(directory-separator? (string-ref s (fx- i 1))) (substring s i n)]
|
||||
[else (loop (fx- i 1))])))))
|
||||
|
||||
(set-who! path-parent
|
||||
(lambda (s)
|
||||
(define directory-separator? (directory-separator-predicate s))
|
||||
(define (skip-sep-backward s i base)
|
||||
(let ([i (fx- i 1)])
|
||||
(if (or (fx= i base) (not (directory-separator? (string-ref s (fx- i 1)))))
|
||||
i
|
||||
(skip-sep-backward s i base))))
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let* ([n (string-length s)] [base (path-base s n)])
|
||||
(let loop ([i n])
|
||||
(cond
|
||||
[(fx= i base) (substring s 0 base)]
|
||||
[(directory-separator? (string-ref s (fx- i 1)))
|
||||
(substring s 0 (skip-sep-backward s i base))]
|
||||
[else (loop (fx- i 1))])))))
|
||||
|
||||
(set-who! path-first
|
||||
(lambda (s)
|
||||
(define directory-separator? (directory-separator-predicate s))
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let* ([n (string-length s)] [base (path-base s n)])
|
||||
(if (fx= base 0)
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(fx= i n) ""]
|
||||
[(directory-separator? (string-ref s i)) (substring s 0 i)]
|
||||
[else (loop (fx+ i 1))]))
|
||||
(if (fx= base n) s (substring s 0 base))))))
|
||||
|
||||
(set-who! path-rest
|
||||
(lambda (s)
|
||||
(define directory-separator? (directory-separator-predicate s))
|
||||
(define (skip-sep s i n)
|
||||
(if (or (fx= i n) (not (directory-separator? (string-ref s i))))
|
||||
i
|
||||
(skip-sep s (fx+ i 1) n)))
|
||||
(unless (string? s) ($oops who "~s is not a string" s))
|
||||
(let* ([n (string-length s)] [base (path-base s n)])
|
||||
(if (fx= base 0)
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(fx= i n) s]
|
||||
[(directory-separator? (string-ref s i))
|
||||
(substring s (skip-sep s (fx+ i 1) n) n)]
|
||||
[else (loop (fx+ i 1))]))
|
||||
(substring s (skip-sep s base n) n)))))
|
||||
)
|
||||
)
|
||||
19
s/Mf-a6fb
Normal file
19
s/Mf-a6fb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6fb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6fb
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-a6le
Normal file
19
s/Mf-a6le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6le
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-a6nb
Normal file
19
s/Mf-a6nb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6nb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6nb
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-a6nt
Normal file
19
s/Mf-a6nt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6nt
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6nt
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-a6ob
Normal file
19
s/Mf-a6ob
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6ob
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6ob
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-a6osx
Normal file
19
s/Mf-a6osx
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6osx
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6osx
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-a6s2
Normal file
19
s/Mf-a6s2
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-a6s2
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = a6s2
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-arm32le
Normal file
19
s/Mf-arm32le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-arm32le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = arm32le
|
||||
archincludes = arm32.ss
|
||||
|
||||
include Mf-base
|
||||
596
s/Mf-base
Normal file
596
s/Mf-base
Normal file
|
|
@ -0,0 +1,596 @@
|
|||
# Mf-base
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
MAKEFLAGS += --no-print-directory
|
||||
|
||||
# the following flags control various compiler options. flags prefixed by an x
|
||||
# separately control the options used while compiling a cross compiler.
|
||||
|
||||
# o determines the optimize level
|
||||
o = 3
|
||||
|
||||
# d is the debug level at which the system should be built
|
||||
d = 0
|
||||
|
||||
# cl determines the commonization level
|
||||
cl = (commonization-level)
|
||||
|
||||
# i determines whether inspector-information is generated: f for false, t for true
|
||||
i = f
|
||||
|
||||
# cp0 determines the number of cp0 (source optimizer) iterations run
|
||||
cp0 = 2
|
||||
|
||||
# fc determines whether fasl objects are compressed
|
||||
fc = t
|
||||
|
||||
# xf determines the compression format
|
||||
xf = (compress-format)
|
||||
|
||||
# xl determine the compression level
|
||||
xl = (compress-level)
|
||||
|
||||
# p (xp) determines whether source profiling is enabled: f for false, t for true.
|
||||
p = f
|
||||
xp = f
|
||||
|
||||
# bp (xpb) determines whether binary profiling is enabled: f for false, t for true.
|
||||
bp = f
|
||||
xbp = f
|
||||
|
||||
# c determines whether covin files are generated: f for false, t for true.
|
||||
c = f
|
||||
|
||||
# loadspd determines whether source-profile data is loaded: f for false, t for true
|
||||
loadspd = f
|
||||
|
||||
# dumpspd determines whether source-profile data is dumped: f for false, t for true
|
||||
dumpspd = f
|
||||
|
||||
# loadbpd determines whether binary-profile data is loaded: f for false, t for true
|
||||
loadbpd = f
|
||||
|
||||
# dumpbpd determines whether binary-profile data is dumped: f for false, t for true
|
||||
dumpbpd = f
|
||||
|
||||
# compile determines the entry point for compilng files
|
||||
# another useful value for this is compile-with-asm, defined in debug.ss
|
||||
compile = compile-file
|
||||
|
||||
# pdhtml determines whether profile-dump-html is called at the end of a build
|
||||
pdhtml = f
|
||||
|
||||
# gac determines whether cost-center allocation counts are generated: f for false, t for true
|
||||
gac = f
|
||||
|
||||
# gic determines whether cost-center instruction counts are generated: f for false, t for true
|
||||
gic = f
|
||||
|
||||
# pps determines whether pass timings are printed
|
||||
pps = f
|
||||
|
||||
# Explicit ".exe" needed for WSL
|
||||
ifeq ($(OS),Windows_NT)
|
||||
ExeSuffix = .exe
|
||||
else
|
||||
ExeSuffix =
|
||||
endif
|
||||
|
||||
# The following control where files sit and typically don't need to be changed, except
|
||||
# that Scheme and SCHEMEHEAPDIRS are set by Mf-cross to point to the host Scheme
|
||||
# implementation
|
||||
Scheme = ../bin/$m/scheme${ExeSuffix}
|
||||
export SCHEMEHEAPDIRS=../boot/%m
|
||||
export CHEZSCHEMELIBDIRS=.
|
||||
|
||||
# Define the libdirs separator character
|
||||
ifeq ($(OS),Windows_NT)
|
||||
dirsep = ;
|
||||
else
|
||||
dirsep = :
|
||||
endif
|
||||
|
||||
ProfileDumpSource = source.pd
|
||||
ProfileDumpBlock = block.pd
|
||||
PetiteBoot = ../boot/$m/petite.boot
|
||||
SchemeBoot = ../boot/$m/scheme.boot
|
||||
Cheader = ../boot/$m/scheme.h
|
||||
Cequates = ../boot/$m/equates.h
|
||||
Revision = ../boot/$m/revision
|
||||
|
||||
# The following controls the patch files loaded before compiling, typically used only
|
||||
# to load a new compiler for cross compilation
|
||||
patchfile =
|
||||
patch = patch
|
||||
|
||||
# putting cpnanopass.patch early for maximum make --jobs=2 benefit
|
||||
patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\
|
||||
cp0.patch cpvalid.patch cpcommonize.patch cpletrec.patch\
|
||||
reloc.patch\
|
||||
compile.patch fasl.patch syntax.patch env.patch\
|
||||
read.patch interpret.patch ftype.patch strip.patch\
|
||||
ubify.patch back.patch
|
||||
|
||||
#ordering constraints:
|
||||
#first: library, prims, mathprims, front, 5_?
|
||||
#last: back
|
||||
#newhash before read
|
||||
#io before read
|
||||
#event before 4
|
||||
#ftype after syntax
|
||||
#layout and record before strnum (first define-record)
|
||||
#date before 7
|
||||
#(there may be other constraints as well)
|
||||
|
||||
basesrc =\
|
||||
library.ss prims.ss mathprims.ss record.ss 5_1.ss 5_2.ss 5_3.ss\
|
||||
strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\
|
||||
event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\
|
||||
format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\
|
||||
interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpcommonize.ss cpletrec.ss inspect.ss\
|
||||
enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\
|
||||
exceptions.ss pretty.ss env.ss\
|
||||
fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
|
||||
|
||||
baseobj = ${basesrc:%.ss=%.$m}
|
||||
|
||||
compilersrc =\
|
||||
cpnanopass.ss compile.ss cback.ss
|
||||
|
||||
compilerobj = ${compilersrc:%.ss=%.$m}
|
||||
|
||||
src = ${basesrc} ${compilersrc}
|
||||
obj = ${baseobj} ${compilerobj}
|
||||
asm = $(basesrc:%.ss=%.asm)
|
||||
|
||||
macroobj =\
|
||||
cmacros.so priminfo.so primvars.so env.so setup.so
|
||||
|
||||
allsrc =\
|
||||
${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\
|
||||
base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\
|
||||
np-languages.ss
|
||||
|
||||
# doit uses a different Scheme process to compile each target
|
||||
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Revision}
|
||||
|
||||
# all uses a single Scheme process to compile all targets. this is typically
|
||||
# faster when most of the targets need to be recompiled.
|
||||
all: bootall ${Cheader} ${Cequates} ${Revision}
|
||||
|
||||
# allx runs all up to three times and checks to see if the new boot file is the
|
||||
# same as the last, i.e., the system is properly bootstrapped.
|
||||
allx: prettyclean saveboot
|
||||
$(MAKE) all
|
||||
if $(MAKE) checkboot > /dev/null 2>&1; then echo fine ; else\
|
||||
$(MAKE) prettyclean saveboot &&\
|
||||
$(MAKE) all &&\
|
||||
if $(MAKE) checkboot > /dev/null 2>&1; then echo fine ; else\
|
||||
$(MAKE) prettyclean saveboot &&\
|
||||
$(MAKE) all &&\
|
||||
$(MAKE) checkboot ;\
|
||||
fi\
|
||||
fi
|
||||
$(MAKE) restoreboot
|
||||
ifneq ($(OS),Windows_NT)
|
||||
$(MAKE) resetbootlinks
|
||||
endif
|
||||
|
||||
# bootstrap runs allx if any sources have changed since the last bootstrap
|
||||
bootstrap: ${allsrc} | ${Revision}
|
||||
$(MAKE) allx
|
||||
touch bootstrap
|
||||
|
||||
# source eagerly creates links to most of the files that might be needed
|
||||
source: ${allsrc} mkheader.ss script.all
|
||||
|
||||
# profiled goes through the involved process of building a profile-optimized boot file
|
||||
profiled:
|
||||
$(MAKE) profileclean
|
||||
$(MAKE) all p=t
|
||||
$(MAKE) prettyclean
|
||||
$(MAKE) io.$m dumpspd=t
|
||||
$(MAKE) prettyclean
|
||||
$(MAKE) all loadspd=t bp=t PetiteBoot=../boot/$m/xpetite.boot SchemeBoot=../boot/$m/xscheme.boot
|
||||
$(MAKE) prettyclean
|
||||
$(MAKE) io.$m loadspd=t dumpbpd=t Scheme="../bin/$m/scheme -b ../boot/$m/xpetite.boot -b ../boot/$m/xscheme.boot"
|
||||
rm -f ../boot/$m/xpetite.boot ../boot/$m/xscheme.boot
|
||||
$(MAKE) prettyclean
|
||||
$(MAKE) all loadspd=t loadbpd=t
|
||||
|
||||
# clean removes the products of the targets above
|
||||
clean: profileclean
|
||||
rm -f bootstrap
|
||||
rm -f Make.out
|
||||
|
||||
# the remaining targets are typically not useful except to support those above
|
||||
|
||||
.SUFFIXES:
|
||||
.SUFFIXES: .ss .$m .patch .so .asm
|
||||
|
||||
.ss.$m:
|
||||
echo '(reset-handler abort)'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
'(when #$(bp) (compile-profile (quote block)))'\
|
||||
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
|
||||
'(when #$(loadbpd) (profile-load-data "${ProfileDumpBlock}"))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(generate-allocation-counts #${gac})'\
|
||||
'(generate-instruction-counts #${gic})'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(run-cp0 (lambda (cp0 x)'\
|
||||
' (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
|
||||
' ((fx= i 0) x))))'\
|
||||
'(collect-trip-bytes (expt 2 24))'\
|
||||
'(collect-request-handler (lambda () (collect 0 1)))'\
|
||||
'(collect 1 2)'\
|
||||
'(delete-file "$*.covin")'\
|
||||
'(time (${compile} "$*.ss" "$*.$m" (quote $m)))'\
|
||||
'(when #${pdhtml} (profile-dump-html))'\
|
||||
'(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\
|
||||
'(when #${dumpbpd} (profile-dump-data "${ProfileDumpBlock}"))'\
|
||||
| ${Scheme} -q ${macroobj} ${patchfile}
|
||||
|
||||
.ss.asm:
|
||||
echo '(reset-handler abort)'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
'(when #$(bp) (compile-profile (quote block)))'\
|
||||
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
|
||||
'(when #$(loadbpd) (profile-load-data "${ProfileDumpBlock}"))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(generate-allocation-counts #${gac})'\
|
||||
'(generate-instruction-counts #${gic})'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(run-cp0 (lambda (cp0 x)'\
|
||||
' (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
|
||||
' ((fx= i 0) x))))'\
|
||||
'(collect-trip-bytes (expt 2 24))'\
|
||||
'(collect-request-handler (lambda () (collect 0 1)))'\
|
||||
'(collect 1 2)'\
|
||||
'(print-gensym (quote pretty/suffix))'\
|
||||
'(delete-file "$*.covin")'\
|
||||
'(compile-with-asm "$*.ss" "$*.$m" (quote $m))'\
|
||||
'(when #${pdhtml} (profile-dump-html))'\
|
||||
'(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\
|
||||
'(when #${dumpbpd} (profile-dump-data "${ProfileDumpBlock}"))'\
|
||||
| ${Scheme} -q ${macroobj} ${patchfile}
|
||||
|
||||
.ss.so:
|
||||
echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(subset-mode (quote system))'\
|
||||
'(compile-file "$*.ss" "$*.so")'\
|
||||
| ${Scheme} -q cmacros.so priminfo.so
|
||||
|
||||
.ss.patch:
|
||||
echo '(reset-handler abort)'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$(xp) (compile-profile (quote source)))'\
|
||||
'(when #$(xbp) (compile-profile (quote block)))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(run-cp0 (lambda (cp0 x)'\
|
||||
' (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
|
||||
' ((fx= i 0) x))))'\
|
||||
'(collect-trip-bytes (expt 2 24))'\
|
||||
'(collect-request-handler (lambda () (collect 0 1)))'\
|
||||
'(collect 1 2)'\
|
||||
'(time (${compile} "$*.ss" "$*.patch" (quote $m)))'\
|
||||
| ${Scheme} -q ${macroobj}
|
||||
|
||||
saveboot:
|
||||
cp -p -f ${PetiteBoot} ../boot/$m/sbb
|
||||
cp -p -f ${SchemeBoot} ../boot/$m/scb
|
||||
|
||||
checkboot:
|
||||
@echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(begin'\
|
||||
'(#%$$fasl-file-equal? "../boot/$m/sbb" "../boot/$m/petite.boot" #t)'\
|
||||
'(#%$$fasl-file-equal? "../boot/$m/scb" "../boot/$m/scheme.boot" #t)'\
|
||||
'(printf "bootfile comparison succeeded\n"))'\
|
||||
| ../bin/$m/scheme${ExeSuffix} -b ../boot/$m/sbb -q
|
||||
|
||||
xcheckboot: ${macroobj} ${patchfile}
|
||||
@echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(begin'\
|
||||
'(#%$$fasl-file-equal? "../boot/$m/sbb" "../boot/$m/petite.boot" #t)'\
|
||||
'(#%$$fasl-file-equal? "../boot/$m/scb" "../boot/$m/scheme.boot" #t)'\
|
||||
'(printf "bootfile comparison succeeded\n"))'\
|
||||
| ${Scheme} -q ${macroobj} ${patchfile}
|
||||
|
||||
restoreboot:
|
||||
-mv -f ../boot/$m/sbb ${PetiteBoot}
|
||||
-mv -f ../boot/$m/scb ${SchemeBoot}
|
||||
|
||||
resetbootlinks:
|
||||
-@echo '(reset-handler abort)'\
|
||||
'(for-each'\
|
||||
'(lambda (fn)'\
|
||||
'(let ([fn (symbol->string fn)])'\
|
||||
'(unless (file-symbolic-link? fn)'\
|
||||
'(when (guard (c [else #f]) (#%$$fasl-file-equal? (format "../~a" fn) fn))'\
|
||||
'(system (format "ln -sf ../../~a ~a" fn fn))'\
|
||||
'(void)))))'\
|
||||
'(list (quote ${SchemeBoot}) (quote ${PetiteBoot})))'\
|
||||
| ${Scheme} -q
|
||||
|
||||
${PetiteBoot}: ${macroobj} ${patchfile} ${baseobj}
|
||||
echo '(reset-handler abort)'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
|
||||
' (map symbol->string (quote (${baseobj}))))'\
|
||||
| ${Scheme} -q ${macroobj} ${patchfile}
|
||||
|
||||
${SchemeBoot}: ${macroobj} ${patchfile} ${compilerobj}
|
||||
echo '(reset-handler abort)'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
|
||||
' (map symbol->string (quote (${compilerobj}))))'\
|
||||
| ${Scheme} -q ${macroobj} ${patchfile}
|
||||
|
||||
cmacros.so: cmacros.ss machine.def layout.ss
|
||||
echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(subset-mode (quote system))'\
|
||||
'(compile-file "$*.ss" "$*.so")'\
|
||||
| ${Scheme} -q
|
||||
|
||||
priminfo.so: priminfo.ss primdata.ss cmacros.so
|
||||
echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(subset-mode (quote system))'\
|
||||
'(compile-file "$*.ss" "$*.so")'\
|
||||
| ${Scheme} -q cmacros.so
|
||||
|
||||
# supply primvars.so as well as cmacros.so
|
||||
mkheader.so: mkheader.ss cmacros.so primvars.so env.so
|
||||
echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(subset-mode (quote system))'\
|
||||
'(compile-file "$*.ss" "$*.so")'\
|
||||
| ${Scheme} -q cmacros.so priminfo.so primvars.so env.so
|
||||
|
||||
nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss
|
||||
echo '(reset-handler abort)'\
|
||||
'(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\
|
||||
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(collect-trip-bytes (expt 2 24))'\
|
||||
'(collect-request-handler (lambda () (collect 0 1)))'\
|
||||
'(collect 1 2)'\
|
||||
'(compile-library "../nanopass/nanopass.ss" "nanopass.so")'\
|
||||
| ${Scheme} -q --libdirs "../nanopass${dirsep}${dirsep}." --compile-imported-libraries
|
||||
|
||||
rootsrc = $(shell cd ../../s; echo *)
|
||||
${rootsrc}:
|
||||
ifeq ($(OS),Windows_NT)
|
||||
cp -p ../../s/$@ $@
|
||||
else
|
||||
ln -s ../../s/$@ $@
|
||||
endif
|
||||
|
||||
script.all: Mf-base
|
||||
|
||||
script.all makescript:
|
||||
echo '(reset-handler abort)'\
|
||||
'(for-each load (command-line-arguments))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
'(when #$(bp) (compile-profile (quote block)))'\
|
||||
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
|
||||
'(when #$(loadbpd) (profile-load-data "${ProfileDumpBlock}"))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(generate-allocation-counts #${gac})'\
|
||||
'(generate-instruction-counts #${gic})'\
|
||||
'(#%$$enable-pass-timing #${pps})'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(run-cp0 (lambda (cp0 x)'\
|
||||
' (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
|
||||
' ((fx= i 0) x))))'\
|
||||
'(collect-trip-bytes (expt 2 24))'\
|
||||
'(collect-request-handler (lambda () (collect 0 1)))'\
|
||||
'(for-each (lambda (x) (delete-file (string-append (path-root (symbol->string x)) ".covin"))) (quote (${obj})))'\
|
||||
'(time (for-each (lambda (x y)'\
|
||||
' (collect 1 2)'\
|
||||
' (${compile} (symbol->string x)'\
|
||||
' (symbol->string y)'\
|
||||
' (quote $m)))'\
|
||||
' (quote (${src}))'\
|
||||
' (quote (${obj}))))'\
|
||||
'(when #${pps} (#%$$print-pass-stats))'\
|
||||
'(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
|
||||
' (map symbol->string (quote (${baseobj}))))'\
|
||||
'(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
|
||||
' (map symbol->string (quote (${compilerobj}))))'\
|
||||
'(when #${pdhtml} (profile-dump-html))'\
|
||||
'(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\
|
||||
'(when #${dumpbpd} (profile-dump-data "${ProfileDumpBlock}"))'\
|
||||
> script.all
|
||||
|
||||
script-static.all:
|
||||
echo '(reset-handler abort)'\
|
||||
'(for-each load (command-line-arguments))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
'(when #$(bp) (compile-profile (quote block)))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(generate-allocation-counts #${gac})'\
|
||||
'(generate-instruction-counts #${gic})'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(run-cp0 (lambda (cp0 x)'\
|
||||
' (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
|
||||
' ((fx= i 0) x))))'\
|
||||
'(for-each (lambda (x) (delete-file (string-append (path-root (symbol->string x)) ".covin"))) (quote (${obj})))'\
|
||||
'(compile-with-setup-closure-counts (quote (${closure-opt})) (quote (${src})) (quote (${obj})) (quote $m) #$r)'\
|
||||
'(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
|
||||
' (map symbol->string (quote (${baseobj}))))'\
|
||||
'(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
|
||||
' (map symbol->string (quote (${compilerobj}))))'\
|
||||
'(when #${pdhtml} (profile-dump-html))'\
|
||||
> script-static.all
|
||||
|
||||
script-dynamic.all:
|
||||
echo '(reset-handler abort)'\
|
||||
'(for-each load (command-line-arguments))'\
|
||||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
'(when #$(bp) (compile-profile (quote block)))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
'(generate-allocation-counts #${gac})'\
|
||||
'(generate-instruction-counts #${gic})'\
|
||||
'(generate-covin-files #$c)'\
|
||||
'(run-cp0 (lambda (cp0 x)'\
|
||||
' (do ([i ${cp0} (fx- i 1)] [x x (cp0 x)])'\
|
||||
' ((fx= i 0) x))))'\
|
||||
'(for-each (lambda (x) (delete-file (string-append (path-root (symbol->string x)) ".covin"))) (quote (${obj})))'\
|
||||
'(compile-with-closure-counts (quote (${closure-opt})) (quote (${src})) (quote (${obj})) (quote $m) #$r)'\
|
||||
'(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\
|
||||
' (map symbol->string (quote (${baseobj}))))'\
|
||||
'(delete-file (string-append (path-root "${SchemeBoot}") ".covin"))'\
|
||||
'(apply #%$$make-boot-file "${SchemeBoot}" (quote $m) (quote ("petite"))'\
|
||||
' (map symbol->string (quote (${compilerobj}))))'\
|
||||
'(when #${pdhtml} (profile-dump-html))'\
|
||||
> script-dynamic.all
|
||||
|
||||
closure-counts: ${allsrc} ${patchfile} ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss script-static.all script-dynamic.all
|
||||
${Scheme} -q ${macroobj} ${patchfile} --script script-static.all
|
||||
$(MAKE) ${PetiteBoot} ${SchemeBoot}
|
||||
${Scheme} -q ${macroobj} ${patchfile} --script script-dynamic.all
|
||||
$(MAKE) all
|
||||
|
||||
bootall: ${allsrc} ${patchfile} ${macroobj} nanopass.so makescript
|
||||
${Scheme} -q ${macroobj} ${patchfile} --script script.all
|
||||
|
||||
${patch}: ${patchobj}
|
||||
rm -f ${patch}
|
||||
cat ${patchobj} > ${patch}
|
||||
|
||||
${asm} ${obj} mkheader.so: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss ${patchfile}
|
||||
primvars.so setup.so mkheader.so env.so: cmacros.so priminfo.so primref.ss
|
||||
setup.so: debug.ss
|
||||
|
||||
${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss
|
||||
cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss ${archincludes}
|
||||
5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss
|
||||
|
||||
${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
|
||||
(if [ -r ${Cheader} ]; then mv -f ${Cheader} ${Cheader}.bak; fi)
|
||||
echo '(reset-handler abort)'\
|
||||
'(mkscheme.h "${Cheader}" (quote $m))' |\
|
||||
${Scheme} -q ${macroobj} mkheader.so
|
||||
(if `cmp -s ${Cheader} ${Cheader}.bak`;\
|
||||
then mv -f ${Cheader}.bak ${Cheader};\
|
||||
else rm -f ${Cheader}.bak; fi)
|
||||
|
||||
${Cequates}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
|
||||
(if [ -r ${Cequates} ]; then mv -f ${Cequates} ${Cequates}.bak; fi)
|
||||
echo '(reset-handler abort)'\
|
||||
'(mkequates.h "${Cequates}")' |\
|
||||
${Scheme} -q ${macroobj} mkheader.so
|
||||
(if `cmp -s ${Cequates} ${Cequates}.bak`;\
|
||||
then mv -f ${Cequates}.bak ${Cequates};\
|
||||
else rm -f ${Cequates}.bak; fi)
|
||||
|
||||
.PHONY: ${Revision}
|
||||
${Revision}: update-revision
|
||||
@./update-revision > ${Revision}
|
||||
|
||||
examples:
|
||||
( cd ../examples && ${MAKE} all Scheme="${Scheme} ../s/${patchfile}" )
|
||||
|
||||
prettyclean:
|
||||
rm -f *.$m xpatch ${patch} *.patch *.so *.covin *.asm script.all header.tmp *.html
|
||||
rm -rf nanopass
|
||||
|
||||
profileclean: prettyclean
|
||||
rm -f ${ProfileDumpSource} ${ProfileDumpBlock}
|
||||
44
s/Mf-cross
Normal file
44
s/Mf-cross
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
# Mf-cross
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
# Usage: make -f Mf-cross m=host xm=target, e.g.:
|
||||
# make -f Mf-cross m=i3le xm=i3osx
|
||||
# to cross-compile to i3osx from i3le
|
||||
|
||||
what = all examples
|
||||
base = ../..
|
||||
|
||||
xdoit: xboot
|
||||
|
||||
include Mf-${xm}
|
||||
|
||||
Scheme=$(base)/bin/${m}/scheme
|
||||
export SCHEMEHEAPDIRS=$(base)/boot/${m}
|
||||
o = 2
|
||||
i = t
|
||||
d = 3
|
||||
|
||||
xpatch = xpatch
|
||||
xpatchobj = ${patchobj}
|
||||
|
||||
xboot: ${xpatch}
|
||||
$(MAKE) -f Mf-${xm} ${what} m=${xm} patchfile=${xpatch} Scheme="${Scheme}" SCHEMEHEAPDIRS=${SCHEMEHEAPDIRS}
|
||||
|
||||
${xpatch}: ${xpatchobj}
|
||||
cat ${xpatchobj} > ${xpatch}
|
||||
|
||||
x$(xm).$(m):
|
||||
$(MAKE) -f Mf-cross m=$(m) xm=$(xm) i=f o=3 d=0 xpatch
|
||||
mv xpatch x$(xm).$(m)
|
||||
19
s/Mf-i3fb
Normal file
19
s/Mf-i3fb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3fb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3fb
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3le
Normal file
19
s/Mf-i3le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3le
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3nb
Normal file
19
s/Mf-i3nb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3nb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3nb
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3nt
Normal file
19
s/Mf-i3nt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3nt
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3nt
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3ob
Normal file
19
s/Mf-i3ob
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3ob
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3ob
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3osx
Normal file
19
s/Mf-i3osx
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3osx
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3osx
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3qnx
Normal file
19
s/Mf-i3qnx
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3qnx
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3qnx
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-i3s2
Normal file
19
s/Mf-i3s2
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-i3s2
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = i3s2
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ppc32le
Normal file
19
s/Mf-ppc32le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ppc32le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ppc32le
|
||||
archincludes = ppc32.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6fb
Normal file
19
s/Mf-ta6fb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6fb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6fb
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6le
Normal file
19
s/Mf-ta6le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6le
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6nb
Normal file
19
s/Mf-ta6nb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6nb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6nb
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6nt
Normal file
19
s/Mf-ta6nt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6nt
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6nt
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6ob
Normal file
19
s/Mf-ta6ob
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6ob
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6ob
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6osx
Normal file
19
s/Mf-ta6osx
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6osx
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6osx
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ta6s2
Normal file
19
s/Mf-ta6s2
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ta6s2
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ta6s2
|
||||
archincludes = x86_64.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3fb
Normal file
19
s/Mf-ti3fb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3fb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3fb
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3le
Normal file
19
s/Mf-ti3le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3le
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3nb
Normal file
19
s/Mf-ti3nb
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3nb
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3nb
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3nt
Normal file
19
s/Mf-ti3nt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3nt
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3nt
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3ob
Normal file
19
s/Mf-ti3ob
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3ob
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3ob
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3osx
Normal file
19
s/Mf-ti3osx
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3osx
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3osx
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-ti3s2
Normal file
19
s/Mf-ti3s2
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-ti3s2
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = ti3s2
|
||||
archincludes = x86.ss
|
||||
|
||||
include Mf-base
|
||||
19
s/Mf-tppc32le
Normal file
19
s/Mf-tppc32le
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
# Mf-tppc32le
|
||||
# Copyright 1984-2017 Cisco Systems, Inc.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
m = tppc32le
|
||||
archincludes = ppc32.ss
|
||||
|
||||
include Mf-base
|
||||
50
s/a6fb.def
Normal file
50
s/a6fb.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6fb.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6fb))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 64)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long int")
|
||||
(define-constant typedef-uptr "unsigned long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long")
|
||||
(define-constant typedef-u64 "unsigned long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor)
|
||||
50
s/a6le.def
Normal file
50
s/a6le.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6le.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6le))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 64)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long int")
|
||||
(define-constant typedef-uptr "unsigned long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long")
|
||||
(define-constant typedef-u64 "unsigned long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor)
|
||||
50
s/a6nb.def
Normal file
50
s/a6nb.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6nb.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6nb))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 64)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long int")
|
||||
(define-constant typedef-uptr "unsigned long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long")
|
||||
(define-constant typedef-u64 "unsigned long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor)
|
||||
50
s/a6nt.def
Normal file
50
s/a6nt.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6nt.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6nt))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 16)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long long int")
|
||||
(define-constant typedef-uptr "unsigned long long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor windows)
|
||||
50
s/a6ob.def
Normal file
50
s/a6ob.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6ob.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6ob))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 64)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long int")
|
||||
(define-constant typedef-uptr "unsigned long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long")
|
||||
(define-constant typedef-u64 "unsigned long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor)
|
||||
50
s/a6osx.def
Normal file
50
s/a6osx.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6osx.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6osx))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 64)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long int")
|
||||
(define-constant typedef-uptr "unsigned long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long")
|
||||
(define-constant typedef-u64 "unsigned long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor)
|
||||
50
s/a6s2.def
Normal file
50
s/a6s2.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; a6s2.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-a6s2))
|
||||
(define-constant architecture 'x86_64)
|
||||
(define-constant address-bits 64)
|
||||
(define-constant ptr-bits 64)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 64)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 64)
|
||||
(define-constant ptrdiff_t-bits 64)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "long int")
|
||||
(define-constant typedef-uptr "unsigned long int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long")
|
||||
(define-constant typedef-u64 "unsigned long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 3)
|
||||
(features iconv expeditor)
|
||||
3097
s/arm32.ss
Normal file
3097
s/arm32.ss
Normal file
File diff suppressed because it is too large
Load diff
50
s/arm32le.def
Normal file
50
s/arm32le.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; arm32le.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-arm32le))
|
||||
(define-constant architecture 'arm32)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 5)
|
||||
(define-constant asm-arg-reg-cnt 3)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #f)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #f)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
214
s/back.ss
Normal file
214
s/back.ss
Normal file
|
|
@ -0,0 +1,214 @@
|
|||
;;; back.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who trace-output-port
|
||||
($make-thread-parameter
|
||||
(console-output-port)
|
||||
(lambda (x)
|
||||
(unless (and (output-port? x) (textual-port? x))
|
||||
($oops who "~s is not a textual output port" x))
|
||||
x)))
|
||||
|
||||
(define-who trace-print
|
||||
($make-thread-parameter
|
||||
pretty-print
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
($oops who "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define suppress-greeting (make-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define-who eval-syntax-expanders-when
|
||||
($make-thread-parameter '(compile load eval)
|
||||
(lambda (x)
|
||||
(unless (let check ([x x] [l '(compile load eval visit revisit)])
|
||||
(or (null? x)
|
||||
(and (pair? x)
|
||||
(memq (car x) l)
|
||||
(check (cdr x) (remq (car x) l)))))
|
||||
($oops who "invalid eval-when list ~s" x))
|
||||
x)))
|
||||
|
||||
(define-who collect-maximum-generation
|
||||
(let ([$get-maximum-generation (foreign-procedure "(cs)maxgen" () fixnum)]
|
||||
[$set-maximum-generation! (foreign-procedure "(cs)set_maxgen" (fixnum) void)])
|
||||
(case-lambda
|
||||
[() ($get-maximum-generation)]
|
||||
[(g)
|
||||
(unless (and (fixnum? g) (fx>= g 0)) ($oops who "invalid generation ~s" g))
|
||||
(when (fx= g 0) ($oops who "new maximum generation must be at least 1"))
|
||||
(let ([limit (fx- (constant static-generation) 1)])
|
||||
(when (fx> g limit) ($oops who "~s exceeds maximum supported value ~s" g limit)))
|
||||
($set-maximum-generation! g)])))
|
||||
|
||||
(define-who release-minimum-generation
|
||||
(let ([$get-release-minimum-generation (foreign-procedure "(cs)minfreegen" () fixnum)]
|
||||
[$set-release-minimum-generation! (foreign-procedure "(cs)set_minfreegen" (fixnum) void)])
|
||||
(case-lambda
|
||||
[() ($get-release-minimum-generation)]
|
||||
[(g)
|
||||
(unless (and (fixnum? g) (fx>= g 0)) ($oops who "invalid generation ~s" g))
|
||||
(unless (fx<= g (collect-maximum-generation))
|
||||
($oops who "new release minimum generation must not be be greater than collect-maximum-generation"))
|
||||
($set-release-minimum-generation! g)])))
|
||||
|
||||
(define-who enable-object-counts
|
||||
(let ([$get-enable-object-counts (foreign-procedure "(cs)enable_object_counts" () boolean)]
|
||||
[$set-enable-object-counts (foreign-procedure "(cs)set_enable_object_counts" (boolean) void)])
|
||||
(case-lambda
|
||||
[() ($get-enable-object-counts)]
|
||||
[(b) ($set-enable-object-counts b)])))
|
||||
|
||||
(define-who collect-trip-bytes
|
||||
(make-parameter
|
||||
(constant default-collect-trip-bytes)
|
||||
(lambda (x)
|
||||
(unless (and (fixnum? x) (fx< 0 x))
|
||||
($oops who "~s is not a positive fixnum" x))
|
||||
($set-collect-trip-bytes x)
|
||||
x)))
|
||||
|
||||
(define-who heap-reserve-ratio
|
||||
(case-lambda
|
||||
[() $heap-reserve-ratio]
|
||||
[(x) (unless (number? x)
|
||||
($oops who "~s is not a number" x))
|
||||
(let ([y (inexact x)])
|
||||
(unless (and (flonum? y) (>= y 0))
|
||||
($oops who "invalid heap reserve ratio ~s" x))
|
||||
(set! $heap-reserve-ratio y))]))
|
||||
|
||||
(define-who $assembly-output
|
||||
($make-thread-parameter #f
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(or (not x) (and (output-port? x) (textual-port? x))) x]
|
||||
[(eq? x #t) (current-output-port)]
|
||||
[else ($oops who "~s is not a textual output port or #f" x)]))))
|
||||
|
||||
(define-who expand-output
|
||||
($make-thread-parameter #f
|
||||
(lambda (x)
|
||||
(unless (or (not x) (and (output-port? x) (textual-port? x)))
|
||||
($oops who "~s is not a textual output port or #f" x))
|
||||
x)))
|
||||
|
||||
(define-who expand/optimize-output
|
||||
($make-thread-parameter #f
|
||||
(lambda (x)
|
||||
(unless (or (not x) (and (output-port? x) (textual-port? x)))
|
||||
($oops who "~s is not a textual output port or #f" x))
|
||||
x)))
|
||||
|
||||
(define generate-wpo-files
|
||||
($make-thread-parameter #f
|
||||
(lambda (x)
|
||||
(and x #t))))
|
||||
|
||||
(define-who generate-covin-files
|
||||
($make-thread-parameter #f
|
||||
(lambda (x)
|
||||
(and x #t))))
|
||||
|
||||
(define $enable-check-prelex-flags
|
||||
($make-thread-parameter #f
|
||||
(lambda (x)
|
||||
(and x #t))))
|
||||
|
||||
(define-who run-cp0
|
||||
($make-thread-parameter
|
||||
(default-run-cp0)
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
($oops who "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define fasl-compressed
|
||||
($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define compile-file-message
|
||||
($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define compile-imported-libraries
|
||||
($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define-who compile-library-handler
|
||||
($make-thread-parameter
|
||||
(lambda (ifn ofn) (compile-library ifn ofn))
|
||||
(lambda (x)
|
||||
(unless (procedure? x) ($oops who "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define-who compile-program-handler
|
||||
($make-thread-parameter
|
||||
(lambda (ifn ofn) (compile-program ifn ofn))
|
||||
(lambda (x)
|
||||
(unless (procedure? x) ($oops who "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define-who compress-format
|
||||
(case-lambda
|
||||
[()
|
||||
(let ([x ($tc-field 'compress-format ($tc))])
|
||||
(cond
|
||||
[(eqv? x (constant COMPRESS-GZIP)) 'gzip]
|
||||
[(eqv? x (constant COMPRESS-LZ4)) 'lz4]
|
||||
[else ($oops who "unexpected $compress-format value ~s" x)]))]
|
||||
[(x)
|
||||
($tc-field 'compress-format ($tc)
|
||||
(case x
|
||||
[(gzip) (constant COMPRESS-GZIP)]
|
||||
[(lz4) (constant COMPRESS-LZ4)]
|
||||
[else ($oops who "~s is not a supported format" x)]))]))
|
||||
|
||||
(define-who compress-level
|
||||
(case-lambda
|
||||
[()
|
||||
(let ([x ($tc-field 'compress-level ($tc))])
|
||||
(cond
|
||||
[(eqv? x (constant COMPRESS-MIN)) 'minimum]
|
||||
[(eqv? x (constant COMPRESS-LOW)) 'low]
|
||||
[(eqv? x (constant COMPRESS-MEDIUM)) 'medium]
|
||||
[(eqv? x (constant COMPRESS-HIGH)) 'high]
|
||||
[(eqv? x (constant COMPRESS-MAX)) 'maximum]
|
||||
[else ($oops who "unexpected $compress-level value ~s" x)]))]
|
||||
[(x)
|
||||
($tc-field 'compress-level ($tc)
|
||||
(case x
|
||||
[(minimum) (constant COMPRESS-MIN)]
|
||||
[(low) (constant COMPRESS-LOW)]
|
||||
[(medium) (constant COMPRESS-MEDIUM)]
|
||||
[(high) (constant COMPRESS-HIGH)]
|
||||
[(maximum) (constant COMPRESS-MAX)]
|
||||
[else ($oops who "~s is not a supported level" x)]))]))
|
||||
|
||||
(define-who debug-level
|
||||
($make-thread-parameter
|
||||
1
|
||||
(lambda (x)
|
||||
(unless (and (fixnum? x) (<= 0 x 3))
|
||||
($oops who "invalid level ~s" x))
|
||||
x)))
|
||||
|
||||
(define internal-defines-as-letrec*
|
||||
($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define self-evaluating-vectors
|
||||
($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(set! $scheme-version (string->symbol ($format-scheme-version (constant scheme-version))))
|
||||
)
|
||||
260
s/base-lang.ss
Normal file
260
s/base-lang.ss
Normal file
|
|
@ -0,0 +1,260 @@
|
|||
;;; base-lang.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc
|
||||
lookup-primref primref? primref-name primref-level primref-flags primref-arity
|
||||
sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
|
||||
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec
|
||||
prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set!
|
||||
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
|
||||
target-fixnum? target-bignum?)
|
||||
|
||||
(module (lookup-primref primref? primref-name primref-flags primref-arity primref-level)
|
||||
(include "primref.ss")
|
||||
|
||||
(define $lookup-primref
|
||||
(lambda (level name)
|
||||
(unless (symbol? name)
|
||||
(sorry! 'lookup-primref "invalid primitive name ~s" name))
|
||||
(or ($sgetprop name
|
||||
(case level
|
||||
[(2) '*prim2*]
|
||||
[(3) '*prim3*]
|
||||
[else ($oops 'lookup-primref "invalid level ~s" level)])
|
||||
#f)
|
||||
($oops 'lookup-primref "unrecognized prim ~s" name))))
|
||||
|
||||
(define-syntax lookup-primref
|
||||
(lambda (x)
|
||||
(define exact-integer?
|
||||
(lambda (x)
|
||||
(and (integer? x) (exact? x))))
|
||||
(define constant-level&name
|
||||
(lambda (level name)
|
||||
(unless (and (exact-integer? level) (memv level '(2 3)))
|
||||
(syntax-error x (format "invalid level ~s" level)))
|
||||
(unless (symbol? name)
|
||||
(syntax-error x (format "invalid name ~s" name)))
|
||||
(let ([primref ($sgetprop name (if (eqv? level 2) '*prim2* '*prim3*) #f)])
|
||||
(unless primref (syntax-error x (format "unknown primitive ~s" name)))
|
||||
#`'#,primref)))
|
||||
(define constant-name
|
||||
(lambda (?level name)
|
||||
(unless (symbol? name)
|
||||
(syntax-error x (format "invalid name ~s" name)))
|
||||
(let ([primref2 ($sgetprop name '*prim2* #f)]
|
||||
[primref3 ($sgetprop name '*prim3* #f)])
|
||||
(unless (and primref2 primref3)
|
||||
(syntax-error x (format "unknown primitive ~s" name)))
|
||||
#`(let ([level #,?level])
|
||||
(case level
|
||||
[(2) '#,primref2]
|
||||
[(3) '#,primref3]
|
||||
[else (sorry! 'lookup-primref "invalid level ~s" level)])))))
|
||||
(syntax-case x (quote)
|
||||
[(_ (quote level) (quote name))
|
||||
(constant-level&name (datum level) (datum name))]
|
||||
[(_ level (quote name))
|
||||
(exact-integer? (datum level))
|
||||
(constant-level&name (datum level) (datum name))]
|
||||
[(_ ?level (quote name))
|
||||
(constant-name #'?level (datum name))]
|
||||
[(k ?level ?name) #'($lookup-primref ?level ?name)]))))
|
||||
|
||||
(module (prelex? make-prelex
|
||||
prelex-name prelex-name-set!
|
||||
prelex-flags prelex-flags-set!
|
||||
prelex-source
|
||||
prelex-operand prelex-operand-set!
|
||||
prelex-uname)
|
||||
(define-record-type prelex
|
||||
(nongenerative #{prelex grpmhtzqa9bflxfggfu6pp-0})
|
||||
(sealed #t)
|
||||
(fields (mutable name) (mutable flags) source (mutable operand) (mutable $uname))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (name flags source operand)
|
||||
(new name flags source operand #f)))))
|
||||
(define prelex-uname
|
||||
(lambda (id)
|
||||
(or (prelex-$uname id)
|
||||
(let ([uname (gensym (symbol->string (prelex-name id)))])
|
||||
(with-tc-mutex
|
||||
(or (prelex-$uname id)
|
||||
(begin (prelex-$uname-set! id uname) uname)))))))
|
||||
(record-writer (record-type-descriptor prelex)
|
||||
(lambda (x p wr)
|
||||
(fprintf p "~s" (prelex-name x)))))
|
||||
|
||||
(define make-prelex*
|
||||
(case-lambda
|
||||
[() (make-prelex (gensym) 0 #f #f)]
|
||||
[(name) (make-prelex name 0 #f #f)]))
|
||||
|
||||
; TODO: use sorry! where appropriate
|
||||
(define sorry!
|
||||
(lambda (who str . arg*)
|
||||
($oops 'compiler-internal "~@[~a: ~]~?" who str arg*)))
|
||||
|
||||
(define maybe-source-object?
|
||||
(lambda (x)
|
||||
(or (eq? x #f) (source-object? x))))
|
||||
|
||||
(define rcd?
|
||||
(lambda (x)
|
||||
(or (record-constructor-descriptor? x) #t))) ; rcd should be restricted to rcd or ctrcd
|
||||
|
||||
(define exact-integer?
|
||||
(lambda (x)
|
||||
(and (integer? x) (exact? x))))
|
||||
|
||||
(meta-cond
|
||||
[(= (constant fixnum-bits) (fixnum-width))
|
||||
(define target-fixnum? fixnum?)
|
||||
(define target-bignum? bignum?)]
|
||||
[(< (constant fixnum-bits) (fixnum-width))
|
||||
(define target-fixnum?
|
||||
(lambda (x)
|
||||
(and (fixnum? x)
|
||||
(fx<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))
|
||||
(define target-bignum?
|
||||
(lambda (x)
|
||||
(or (bignum? x)
|
||||
(and (fixnum? x)
|
||||
(not (fx<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))))]
|
||||
[else
|
||||
(define target-fixnum?
|
||||
(lambda (x)
|
||||
(or (fixnum? x)
|
||||
(and (bignum? x)
|
||||
(<= (constant most-negative-fixnum) x (constant most-positive-fixnum))))))
|
||||
(define target-bignum?
|
||||
(lambda (x)
|
||||
(and (bignum? x)
|
||||
(not (<= (constant most-negative-fixnum) x (constant most-positive-fixnum))))))])
|
||||
|
||||
(define $prelex?
|
||||
(lambda (x)
|
||||
(prelex? x)))
|
||||
|
||||
(define datum?
|
||||
(lambda (x)
|
||||
#t))
|
||||
|
||||
(define convention?
|
||||
(lambda (x)
|
||||
(symbol? x)))
|
||||
|
||||
(define-record-type preinfo
|
||||
(nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2})
|
||||
(fields src (mutable sexpr))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(case-lambda
|
||||
[() (new #f #f)]
|
||||
[(src) (new src #f)]
|
||||
[(src sexpr) (new src sexpr)]))))
|
||||
|
||||
(define-record-type preinfo-lambda
|
||||
(nongenerative #{preinfo-lambda e23pkvo5btgapnzomqgegm-4})
|
||||
(parent preinfo)
|
||||
(sealed #t)
|
||||
(fields libspec (mutable name) flags)
|
||||
(protocol
|
||||
(lambda (pargs->new)
|
||||
(case-lambda
|
||||
[() ((pargs->new) #f #f 0)]
|
||||
[(src) ((pargs->new src) #f #f 0)]
|
||||
[(src sexpr) ((pargs->new src sexpr) #f #f 0)]
|
||||
[(src sexpr libspec) ((pargs->new src sexpr) libspec #f 0)]
|
||||
[(src sexpr libspec name) ((pargs->new src sexpr) libspec name 0)]
|
||||
[(src sexpr libspec name flags) ((pargs->new src sexpr) libspec name flags)]))))
|
||||
|
||||
; language of foreign types
|
||||
(define-language Ltype
|
||||
(nongenerative-id #{Ltype czp82kxwe75y4e18-1})
|
||||
(terminals
|
||||
(exact-integer (bits))
|
||||
($ftd (ftd)))
|
||||
(Type (t)
|
||||
(fp-integer bits)
|
||||
(fp-unsigned bits)
|
||||
(fp-void)
|
||||
(fp-scheme-object)
|
||||
(fp-u8*)
|
||||
(fp-u16*)
|
||||
(fp-u32*)
|
||||
(fp-fixnum)
|
||||
(fp-double-float)
|
||||
(fp-single-float)
|
||||
(fp-ftd ftd)
|
||||
(fp-ftd& ftd)))
|
||||
|
||||
(define arity?
|
||||
(lambda (x)
|
||||
(or (eq? x #f)
|
||||
(for-all fixnum? x))))
|
||||
|
||||
(define maybe-string? (lambda (x) (or (eq? x #f) (string? x))))
|
||||
|
||||
; source language used by the passes leading up to the compiler or interpreter
|
||||
(define-language Lsrc
|
||||
(nongenerative-id #{Lsrc czsa1fcfzdeh493n-3})
|
||||
(terminals
|
||||
(preinfo (preinfo))
|
||||
($prelex (x))
|
||||
(datum (d))
|
||||
(record-type-descriptor (rtd))
|
||||
(rcd (rcd))
|
||||
(source-object (src))
|
||||
(maybe-source-object (maybe-src))
|
||||
(Ltype (arg-type result-type)) => unparse-Ltype
|
||||
(fixnum (interface index flags level))
|
||||
(arity (arity))
|
||||
(box (box))
|
||||
(convention (conv))
|
||||
(maybe-string (name))
|
||||
(symbol (sym type))
|
||||
(primref (pr)))
|
||||
(Expr (e body rtd-expr)
|
||||
pr
|
||||
(moi)
|
||||
(ref maybe-src x) => x
|
||||
(quote d)
|
||||
(if e0 e1 e2)
|
||||
(seq e0 e1)
|
||||
(set! maybe-src x e) => (set! x e)
|
||||
(pariah)
|
||||
(case-lambda preinfo cl ...) => (case-lambda cl ...)
|
||||
(letrec ([x* e*] ...) body)
|
||||
(letrec* ([x* e*] ...) body)
|
||||
(call preinfo e0 e1 ...) => (e0 e1 ...)
|
||||
(record-type rtd e)
|
||||
(record-cd rcd rtd-expr e)
|
||||
(immutable-list (e* ...) e)
|
||||
(record rtd rtd-expr e* ...)
|
||||
(record-ref rtd type index e)
|
||||
(record-set! rtd type index e1 e2)
|
||||
(cte-optimization-loc box e)
|
||||
(foreign (conv* ...) name e (arg-type* ...) result-type)
|
||||
(fcallable (conv* ...) e (arg-type* ...) result-type)
|
||||
(profile src) => (profile)
|
||||
; used only in cpvalid
|
||||
(cpvalid-defer e))
|
||||
(CaseLambdaClause (cl)
|
||||
(clause (x* ...) interface body) => [(x* ...) interface body]))
|
||||
|
||||
(define-language-node-counter count-Lsrc Lsrc)
|
||||
)
|
||||
1516
s/bytevector.ss
Normal file
1516
s/bytevector.ss
Normal file
File diff suppressed because it is too large
Load diff
217
s/cafe.ss
Normal file
217
s/cafe.ss
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
;;; cafe.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define default-prompt-and-read
|
||||
(lambda (n)
|
||||
(unless (and (integer? n) (>= n 0))
|
||||
($oops 'default-prompt-and-read
|
||||
"~s is not a nonnegative integer"
|
||||
n))
|
||||
(let ([prompt (waiter-prompt-string)])
|
||||
(unless (string=? prompt "")
|
||||
(do ([n n (- n 1)])
|
||||
((= n 0)
|
||||
(write-char #\space (console-output-port))
|
||||
(flush-output-port (console-output-port)))
|
||||
(display prompt (console-output-port))))
|
||||
(let ([x (read (console-input-port))])
|
||||
(when (and (eof-object? x) (not (string=? prompt "")))
|
||||
(newline (console-output-port))
|
||||
(flush-output-port (console-output-port)))
|
||||
x))))
|
||||
|
||||
(define waiter-prompt-and-read
|
||||
($make-thread-parameter
|
||||
default-prompt-and-read
|
||||
(lambda (p)
|
||||
(unless (procedure? p)
|
||||
($oops 'waiter-prompt-and-read "~s is not a procedure" p))
|
||||
p)))
|
||||
|
||||
(define waiter-write
|
||||
($make-thread-parameter
|
||||
(lambda (x)
|
||||
(unless (eq? x (void))
|
||||
(pretty-print x (console-output-port)))
|
||||
(flush-output-port (console-output-port)))
|
||||
(lambda (p)
|
||||
(unless (procedure? p)
|
||||
($oops 'waiter-write "~s is not a procedure" p))
|
||||
p)))
|
||||
|
||||
(define waiter-prompt-string
|
||||
($make-thread-parameter
|
||||
">"
|
||||
(lambda (s)
|
||||
(unless (string? s)
|
||||
($oops 'waiter-prompt-string "~s is not a string" s))
|
||||
s)))
|
||||
|
||||
(define new-cafe)
|
||||
|
||||
(let ()
|
||||
(define-threaded waiter-expr)
|
||||
(define-threaded waiter-stat1)
|
||||
(define-threaded waiter-stat2)
|
||||
(define-threaded waiter-total-stats)
|
||||
|
||||
(define sstats-sum
|
||||
(lambda (a b)
|
||||
(define sstats-time-add
|
||||
(lambda (f a b)
|
||||
(add-duration (f a) (f b))))
|
||||
(make-sstats
|
||||
(sstats-time-add sstats-cpu a b)
|
||||
(sstats-time-add sstats-real a b)
|
||||
(+ (sstats-bytes a) (sstats-bytes b))
|
||||
(+ (sstats-gc-count a) (sstats-gc-count b))
|
||||
(sstats-time-add sstats-gc-cpu a b)
|
||||
(sstats-time-add sstats-gc-real a b)
|
||||
(+ (sstats-gc-bytes a) (sstats-gc-bytes b)))))
|
||||
|
||||
(define waiter
|
||||
(lambda (cafe eval)
|
||||
(let ([x ((waiter-prompt-and-read) cafe)])
|
||||
(when (eof-object? x) (exit))
|
||||
(fluid-let ([waiter-total-stats (make-sstats
|
||||
(make-time 'time-duration 0 0)
|
||||
(make-time 'time-duration 0 0)
|
||||
0
|
||||
0
|
||||
(make-time 'time-duration 0 0)
|
||||
(make-time 'time-duration 0 0)
|
||||
0)]
|
||||
[waiter-expr x]
|
||||
[waiter-stat1 (void)]
|
||||
[waiter-stat2 (void)])
|
||||
(dynamic-wind #t
|
||||
(lambda ()
|
||||
(set! waiter-stat1 (statistics))
|
||||
(set! waiter-stat2 (statistics)))
|
||||
(lambda ()
|
||||
(parameterize ([$interrupt waiter-interrupt])
|
||||
(top-level eval x)))
|
||||
(lambda ()
|
||||
(let ([s (statistics)])
|
||||
(set! waiter-total-stats
|
||||
(sstats-sum (sstats-difference
|
||||
(sstats-difference s waiter-stat2)
|
||||
(sstats-difference waiter-stat2
|
||||
waiter-stat1))
|
||||
waiter-total-stats)))))))
|
||||
(waiter cafe eval)))
|
||||
|
||||
; This marks the "top-level" continuation for the debugger
|
||||
(define top-level
|
||||
(lambda (eval x)
|
||||
(call/cc ; grab continuation & start a new stack segment
|
||||
(rec new-cafe
|
||||
(lambda (k)
|
||||
($current-stack-link $null-continuation) ; toss what's below
|
||||
(call-with-values
|
||||
(lambda () (eval x))
|
||||
(lambda args (for-each (waiter-write) args)))
|
||||
(k))))))
|
||||
|
||||
(define waiter-interrupt
|
||||
(lambda ()
|
||||
(call/cc
|
||||
(lambda (k)
|
||||
(parameterize ([$interrupt void])
|
||||
(let ([s (statistics)])
|
||||
(set! waiter-total-stats
|
||||
(sstats-sum (sstats-difference
|
||||
(sstats-difference s waiter-stat2)
|
||||
(sstats-difference waiter-stat2
|
||||
waiter-stat1))
|
||||
waiter-total-stats)))
|
||||
(clear-input-port (console-input-port))
|
||||
(let ([waiter (call/cc
|
||||
(lambda (k)
|
||||
(rec f (lambda () (k f)))))])
|
||||
(fprintf (console-output-port) "break> ")
|
||||
(flush-output-port (console-output-port))
|
||||
(case (let ([x (parameterize ([$interrupt waiter]
|
||||
[reset-handler waiter])
|
||||
(read (console-input-port)))])
|
||||
(if (eof-object? x)
|
||||
(begin (newline (console-output-port))
|
||||
(flush-output-port (console-output-port))
|
||||
'exit)
|
||||
x))
|
||||
[(exit e)
|
||||
(void)]
|
||||
[(statistics s)
|
||||
(parameterize ([print-level 2] [print-length 2])
|
||||
(fprintf (console-output-port)
|
||||
"(time ~s)~%"
|
||||
waiter-expr))
|
||||
(sstats-print waiter-total-stats (console-output-port))
|
||||
(flush-output-port (console-output-port))
|
||||
(waiter)]
|
||||
[(reset r quit q)
|
||||
(reset)]
|
||||
[(abort a)
|
||||
(abort)]
|
||||
[(new-cafe n)
|
||||
(new-cafe)
|
||||
(waiter)]
|
||||
[(inspect i)
|
||||
(inspect k)
|
||||
(waiter)]
|
||||
[(?)
|
||||
(fprintf (console-output-port) "
|
||||
Type e to exit interrupt handler and continue
|
||||
r or q to reset scheme
|
||||
a to abort scheme
|
||||
n to enter new cafe
|
||||
i to inspect current continuation
|
||||
s to display statistics
|
||||
|
||||
")
|
||||
(flush-output-port (console-output-port))
|
||||
(waiter)]
|
||||
[else
|
||||
(fprintf (console-output-port)
|
||||
"Invalid command. Type ? for options.~%")
|
||||
(flush-output-port (console-output-port))
|
||||
(waiter)]))
|
||||
(set! waiter-stat1 (statistics))
|
||||
(set! waiter-stat2 (statistics)))))))
|
||||
|
||||
(set! $cafe ($make-thread-parameter 0))
|
||||
|
||||
(set! new-cafe
|
||||
(let ()
|
||||
(rec new-cafe
|
||||
(case-lambda
|
||||
[() (new-cafe eval)]
|
||||
[(eval)
|
||||
(unless (procedure? eval)
|
||||
($oops 'new-cafe "~s is not a procedure" eval))
|
||||
(call/cc
|
||||
(lambda (k1)
|
||||
(parameterize ([exit-handler k1] [reset-handler (reset-handler)])
|
||||
(let ((k2 k1))
|
||||
(reset-handler (lambda () (k2)))
|
||||
(call/cc (lambda (k) (set! k2 k)))
|
||||
(parameterize ([$cafe (+ ($cafe) 1)] [$interrupt reset])
|
||||
(with-exception-handler
|
||||
(lambda (c) ((base-exception-handler) c))
|
||||
(lambda ()
|
||||
(waiter ($cafe) eval))))))))]))))
|
||||
)
|
||||
)
|
||||
19
s/cback.ss
Normal file
19
s/cback.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
;;; cback.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(current-eval compile)
|
||||
(define $compiler-is-loaded? #t)
|
||||
)
|
||||
2677
s/cmacros.ss
Normal file
2677
s/cmacros.ss
Normal file
File diff suppressed because it is too large
Load diff
2121
s/compile.ss
Normal file
2121
s/compile.ss
Normal file
File diff suppressed because it is too large
Load diff
161
s/costctr.ss
Normal file
161
s/costctr.ss
Normal file
|
|
@ -0,0 +1,161 @@
|
|||
;;; costctr.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(module ($cost-center)
|
||||
(if-feature pthreads
|
||||
(define-record-type ($cost-center $make-cost-center $cost-center?)
|
||||
(fields
|
||||
(mutable level)
|
||||
(mutable instr-count)
|
||||
(mutable alloc-count)
|
||||
(mutable time-ns)
|
||||
(mutable time-s)
|
||||
(immutable mutex))
|
||||
(nongenerative #{cost-center fgbx8g23emx4rf0txn2sr0-1})
|
||||
(opaque #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda ()
|
||||
(new (make-thread-parameter 0) 0 0 0 0 (make-mutex))))))
|
||||
(define-record-type ($cost-center $make-cost-center $cost-center?)
|
||||
(fields
|
||||
(mutable level)
|
||||
(mutable instr-count)
|
||||
(mutable alloc-count)
|
||||
(mutable time-ns)
|
||||
(mutable time-s))
|
||||
(nongenerative #{cost-center fgbx8g23emx4rf0txn2sr0-2})
|
||||
(opaque #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda () (new 0 0 0 0 0))))))
|
||||
|
||||
(define-syntax cc-level
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ x)
|
||||
(if-feature pthreads
|
||||
#'(($cost-center-level x))
|
||||
#'($cost-center-level x))])))
|
||||
|
||||
(define-syntax cc-level-set!
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ x v)
|
||||
(if-feature pthreads
|
||||
#'(($cost-center-level x) v)
|
||||
#'($cost-center-level-set! x v))])))
|
||||
|
||||
(define $with-cost-center
|
||||
(let ()
|
||||
(define who 'with-cost-center)
|
||||
(define-syntax with-mutex-if-threaded
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ mexp e0 e1 ...)
|
||||
(if-feature pthreads
|
||||
#'(with-mutex mexp e0 e1 ...)
|
||||
#'(begin e0 e1 ...))])))
|
||||
(define mod-
|
||||
(lambda (x y)
|
||||
(let ([r (- x y)])
|
||||
(if (< r 0) (+ (expt 2 64) r) r))))
|
||||
(lambda (timed? cc th)
|
||||
(define-record-type saved
|
||||
(sealed #t)
|
||||
(nongenerative)
|
||||
(fields (mutable alloc) (mutable intr) (mutable time)))
|
||||
(unless ($cost-center? cc) ($oops who "~s is not a cost center" cc))
|
||||
(unless (procedure? th) ($oops who "~s is not a procedure" th))
|
||||
(let ([saved (make-saved 0 0 #f)])
|
||||
(dynamic-wind #t
|
||||
(lambda ()
|
||||
(let ([level (cc-level cc)])
|
||||
(cc-level-set! cc (fx+ level 1))
|
||||
(when (fx= level 0)
|
||||
(saved-alloc-set! saved ($object-ref 'unsigned-64 ($tc) (constant tc-alloc-counter-disp)))
|
||||
(saved-intr-set! saved ($object-ref 'unsigned-64 ($tc) (constant tc-instr-counter-disp)))
|
||||
(when timed? (saved-time-set! saved (current-time 'time-thread))))))
|
||||
th
|
||||
(lambda ()
|
||||
(let ([level (cc-level cc)])
|
||||
(cc-level-set! cc (fx- level 1))
|
||||
(when (fx= level 1)
|
||||
; grab time first -- to use up as little as possible
|
||||
(let* ([curr-time (and timed? (current-time 'time-thread))]
|
||||
[alloc-count (mod- ($object-ref 'unsigned-64 ($tc) (constant tc-alloc-counter-disp))
|
||||
(saved-alloc saved))]
|
||||
[instr-count (mod- ($object-ref 'unsigned-64 ($tc) (constant tc-instr-counter-disp))
|
||||
(saved-intr saved))])
|
||||
(with-mutex-if-threaded ($cost-center-mutex cc)
|
||||
($cost-center-alloc-count-set! cc
|
||||
(+ ($cost-center-alloc-count cc) alloc-count))
|
||||
($cost-center-instr-count-set! cc
|
||||
(+ ($cost-center-instr-count cc) instr-count))
|
||||
(when timed?
|
||||
(let ([saved-time (saved-time saved)])
|
||||
(let-values ([(s ns) (let ([ns (- (time-nanosecond curr-time) (time-nanosecond saved-time))]
|
||||
[s (- (time-second curr-time) (time-second saved-time))])
|
||||
(if (< ns 0)
|
||||
(values (- s 1) (+ ns (expt 10 9)))
|
||||
(values s ns)))])
|
||||
(let-values ([(s ns) (let ([ns (+ ($cost-center-time-ns cc) ns)]
|
||||
[s (+ ($cost-center-time-s cc) s)])
|
||||
(if (>= ns (expt 10 9))
|
||||
(values (+ s 1) (- ns (expt 10 9)))
|
||||
(values s ns)))])
|
||||
($cost-center-time-s-set! cc s)
|
||||
($cost-center-time-ns-set! cc ns)))))))))))))))
|
||||
|
||||
(set-who! cost-center-instruction-count
|
||||
(lambda (cc)
|
||||
(unless ($cost-center? cc) ($oops who "~s is not a cost center" cc))
|
||||
($cost-center-instr-count cc)))
|
||||
|
||||
(set-who! cost-center-allocation-count
|
||||
(lambda (cc)
|
||||
(unless ($cost-center? cc) ($oops who "~s is not a cost center" cc))
|
||||
(ash ($cost-center-alloc-count cc) (constant log2-ptr-bytes))))
|
||||
|
||||
(set-who! cost-center-time
|
||||
(lambda (cc)
|
||||
(unless ($cost-center? cc) ($oops who "~s is not a cost center" cc))
|
||||
(make-time 'time-duration ($cost-center-time-ns cc) ($cost-center-time-s cc))))
|
||||
|
||||
(set-who! reset-cost-center!
|
||||
(lambda (cc)
|
||||
(unless ($cost-center? cc) ($oops who "~s is not a cost center" cc))
|
||||
($cost-center-instr-count-set! cc 0)
|
||||
($cost-center-alloc-count-set! cc 0)
|
||||
($cost-center-time-s-set! cc 0)
|
||||
($cost-center-time-ns-set! cc 0)))
|
||||
|
||||
(set! cost-center? (lambda (x) ($cost-center? x)))
|
||||
|
||||
(set! make-cost-center (lambda () ($make-cost-center)))
|
||||
|
||||
(set! with-cost-center
|
||||
(rec with-cost-center
|
||||
(case-lambda
|
||||
[(cc th) ($with-cost-center #f cc th)]
|
||||
[(timed? cc th) ($with-cost-center timed? cc th)])))
|
||||
|
||||
(record-writer (record-type-descriptor $cost-center)
|
||||
(lambda (x p wr)
|
||||
(let ([ns ($cost-center-time-ns x)] [s ($cost-center-time-s x)])
|
||||
(fprintf p "#<cost center~[~2*~:; t=~d.~9,'0d~]~[~:; i=~:*~s~]~[~:; a=~:*~s~]>"
|
||||
(+ ns s) s ns
|
||||
($cost-center-instr-count x)
|
||||
($cost-center-alloc-count x))))))
|
||||
210
s/cpcheck.ss
Normal file
210
s/cpcheck.ss
Normal file
|
|
@ -0,0 +1,210 @@
|
|||
;;; cpcheck.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; cpcheck checks argument counts in calls to primitives and user-defined
|
||||
;;; procedures, where it can recognize them. by running it after cp0, we
|
||||
;;; catch more potentially incorrect calls, including calls to the record
|
||||
;;; constructors and accessors constructed by cp0. running it after cp0 can
|
||||
;;; also lead to bogus warnings on rare occasions, as in:
|
||||
;;;
|
||||
;;; (define (f b)
|
||||
;;; (define h (lambda (b f) (if b (f 1) (f 1 2))))
|
||||
;;; (if b
|
||||
;;; (h b (lambda (x) x))
|
||||
;;; (h b (lambda (x y) y))))
|
||||
;;;
|
||||
;;; where the calls (f 1) and (f 1 2) will be identified as having possible
|
||||
;;; incorrect argument counts. it seems like a reasonable tradeoff.
|
||||
|
||||
(define $cpcheck
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
|
||||
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
|
||||
(define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
|
||||
|
||||
(define maybe-remake-rtd
|
||||
(lambda (rtd)
|
||||
(if (eq? ($target-machine) (machine-type))
|
||||
rtd
|
||||
($remake-rtd rtd (let () (include "layout.ss") compute-field-offsets)))))
|
||||
|
||||
(define record-field-offset
|
||||
(lambda (rtd index)
|
||||
(let ([rtd (maybe-remake-rtd rtd)])
|
||||
(fld-byte (list-ref (rtd-flds rtd) index)))))
|
||||
|
||||
(define-pass cpcheck : Lsrc (ir) -> Lsrc ()
|
||||
(definitions
|
||||
(define-record-type call-context
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(fields cnt (mutable err))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (cnt) (new cnt #f)))))
|
||||
|
||||
(define check!
|
||||
(lambda (ctxt interface*)
|
||||
(define interface-okay?
|
||||
(lambda (interface* cnt)
|
||||
(ormap
|
||||
(lambda (interface)
|
||||
(if (fx< interface 0)
|
||||
(fx>= cnt (lognot interface))
|
||||
(fx= cnt interface)))
|
||||
interface*)))
|
||||
(when ctxt
|
||||
(unless (interface-okay? interface* (call-context-cnt ctxt))
|
||||
(call-context-err-set! ctxt #t)))))
|
||||
|
||||
(define record-lambda!
|
||||
(lambda (id val)
|
||||
(unless (prelex-assigned id)
|
||||
(nanopass-case (Lsrc Expr) val
|
||||
[(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...)
|
||||
(prelex-operand-set! id interface*)]
|
||||
[else (void)]))))
|
||||
|
||||
(define-syntax with-record-lambda
|
||||
(syntax-rules ()
|
||||
[(_ ids vals body)
|
||||
(begin
|
||||
(for-each record-lambda! ids vals)
|
||||
(let ([x body])
|
||||
(for-each (lambda (id) (prelex-operand-set! id #f)) ids)
|
||||
x))]))
|
||||
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define build-sequence
|
||||
(lambda (x* body)
|
||||
(fold-left (lambda (body x) `(seq ,x ,body)) body x*)))
|
||||
|
||||
(define argcnt-error
|
||||
(lambda (preinfo f args)
|
||||
(let ([call (parameterize ([print-gensym #f] [print-level 3] [print-length 6])
|
||||
(format "~s" (preinfo-sexpr preinfo)))])
|
||||
`(seq ,f
|
||||
,(build-sequence args
|
||||
(cond
|
||||
[(preinfo-src preinfo) =>
|
||||
(lambda (src)
|
||||
($source-warning 'compile src #t
|
||||
"possible incorrect argument count in call ~a"
|
||||
call)
|
||||
`(call ,preinfo
|
||||
,(lookup-primref 2 '$source-violation)
|
||||
(quote #f)
|
||||
(quote ,src)
|
||||
(quote #t)
|
||||
(quote "incorrect argument count in call ~a")
|
||||
(quote ,call)))]
|
||||
[else
|
||||
`(call ,preinfo
|
||||
,(lookup-primref 2 '$oops)
|
||||
(quote #f)
|
||||
(quote "incorrect argument count in call ~a")
|
||||
(quote ,call))]))))))))
|
||||
(Expr : Expr (ir [ctxt #f]) -> Expr ()
|
||||
[(quote ,d) ir]
|
||||
[(ref ,maybe-src ,x)
|
||||
(cond
|
||||
[(prelex-operand x) =>
|
||||
(lambda (interface*)
|
||||
(and (list? interface*)
|
||||
(check! ctxt interface*)))])
|
||||
`(ref ,maybe-src ,x)]
|
||||
[(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)]
|
||||
[(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)]
|
||||
[(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
||||
(check! ctxt (list (length arg-type*)))
|
||||
`(foreign (,conv* ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
|
||||
[(fcallable (,conv* ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
|
||||
`(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)]
|
||||
[(call ,preinfo0
|
||||
(case-lambda ,preinfo1
|
||||
(clause (,x* ...) ,interface ,body)
|
||||
,cl* ...)
|
||||
,[e* #f -> e*] ...)
|
||||
(guard (fx= (length e*) interface))
|
||||
`(call ,preinfo0
|
||||
(case-lambda ,preinfo1
|
||||
(clause (,x* ...) ,interface
|
||||
,(with-record-lambda x* e* (Expr body ctxt))))
|
||||
,e* ...)]
|
||||
[(call ,preinfo ,e ,[e* #f -> e*] ...)
|
||||
(let ([sexpr (preinfo-sexpr preinfo)])
|
||||
(define ugly-gensym? ; gensym w/no pretty name
|
||||
(lambda (x)
|
||||
(and (gensym? x)
|
||||
(let ([name ($symbol-name x)])
|
||||
(or (not (pair? name)) (not (cdr name)))))))
|
||||
(if (and sexpr (and (pair? sexpr) (not (ugly-gensym? (car sexpr)))))
|
||||
(let ([ctxt (make-call-context (length e*))])
|
||||
(let ([e (Expr e ctxt)])
|
||||
(if (call-context-err ctxt)
|
||||
(argcnt-error preinfo e e*)
|
||||
`(call ,preinfo ,e ,e* ...))))
|
||||
`(call ,preinfo ,(Expr e #f) ,e* ...)))]
|
||||
[(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* #f -> body*]) ...)
|
||||
(check! ctxt interface*)
|
||||
`(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...)]
|
||||
[(letrec ([,x* ,e*] ...) ,body)
|
||||
(with-record-lambda x* e*
|
||||
`(letrec ([,x* ,(map (lambda (e) (Expr e #f)) e*)] ...)
|
||||
,(Expr body ctxt)))]
|
||||
[,pr (let ([arity (primref-arity pr)]) (when arity (check! ctxt arity))) pr]
|
||||
[(record-ref ,rtd ,type ,index ,[e #f -> e])
|
||||
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-ref)
|
||||
(quote ,type) ,e (quote ,(record-field-offset rtd index)))]
|
||||
[(record-set! ,rtd ,type ,index ,[e1 #f -> e1] ,[e2 #f -> e2])
|
||||
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
|
||||
(quote ,type) ,e1 (quote ,(record-field-offset rtd index)) ,e2)]
|
||||
[(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...)
|
||||
(let ([rtd (maybe-remake-rtd rtd)])
|
||||
(let ([fld* (rtd-flds rtd)] [rec-t (make-prelex*)])
|
||||
(safe-assert (fx= (length e*) (length fld*)))
|
||||
(let ([filler* (fold-right
|
||||
(lambda (fld e filler*)
|
||||
(let ([type (fld-type fld)])
|
||||
(if (eq? (filter-foreign-type type) 'scheme-object)
|
||||
filler*
|
||||
(cons
|
||||
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
|
||||
(quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
|
||||
filler*))))
|
||||
'() fld* e*)])
|
||||
(if (null? filler*)
|
||||
`(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
|
||||
(begin
|
||||
(set-prelex-referenced! rec-t #t)
|
||||
(set-prelex-multiply-referenced! rec-t #t)
|
||||
`(call ,(make-preinfo)
|
||||
(case-lambda ,(make-preinfo-lambda)
|
||||
(clause (,rec-t) 1 ,(build-sequence filler* `(ref #f ,rec-t))))
|
||||
(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr
|
||||
,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg]))
|
||||
(make-record-call-args fld* (rtd-size rtd) e*))
|
||||
...)))))))]
|
||||
[(cte-optimization-loc ,box ,[e #f -> e]) e]
|
||||
[(immutable-list (,e* ...) ,[e]) e]
|
||||
[(moi) ir]
|
||||
[(pariah) ir]
|
||||
[(profile ,src) ir]
|
||||
[else (sorry! who "unhandled record ~s" ir)]))
|
||||
|
||||
(lambda (x) (cpcheck x))))
|
||||
579
s/cpcommonize.ss
Normal file
579
s/cpcommonize.ss
Normal file
|
|
@ -0,0 +1,579 @@
|
|||
;;; cpcommonize.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who commonization-level
|
||||
($make-thread-parameter
|
||||
0
|
||||
(lambda (x)
|
||||
(unless (and (fixnum? x) (<= 0 x 9))
|
||||
($oops who "invalid level ~s" x))
|
||||
x)))
|
||||
|
||||
(define $cpcommonize
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
|
||||
(define-record-type binding
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(fields x (mutable e) size helper-box (mutable helper-b) (mutable helper-arg*))
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (x e size helper-box)
|
||||
(new x e size helper-box #f #f)))))
|
||||
|
||||
(define-language Lcommonize1 (extends Lsrc)
|
||||
(terminals
|
||||
(+ (fixnum (size))))
|
||||
(Expr (e body rtd-expr)
|
||||
(- (letrec ([x* e*] ...) body))
|
||||
(+ (letrec ([x* e* size] ...) body))))
|
||||
|
||||
(define-language Lcommonize2 (extends Lcommonize1)
|
||||
(terminals
|
||||
(- (fixnum (size)))
|
||||
(+ (binding (b helper-b))))
|
||||
(Expr (e body rtd-expr)
|
||||
(- (letrec ([x* e* size] ...) body))
|
||||
(+ (letrec (helper-b* ...) (b* ...) body))))
|
||||
|
||||
(define-syntax iffalse
|
||||
(syntax-rules ()
|
||||
[(_ e1 e2) e1 #;(or e1 (begin e2 #f))]))
|
||||
|
||||
(define-syntax iftrue
|
||||
(syntax-rules ()
|
||||
[(_ e1 e2) e1 #;(let ([t e1]) (and t (begin e2 t)))]))
|
||||
|
||||
(define Lcommonize1-lambda?
|
||||
(lambda (e)
|
||||
(nanopass-case (Lcommonize1 Expr) e
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[else #f])))
|
||||
|
||||
(define-pass cpcommonize0 : Lsrc (ir) -> Lcommonize1 ()
|
||||
(Expr : Expr (ir) -> Expr (1)
|
||||
[(set! ,maybe-src ,x ,[e size])
|
||||
(values `(set! ,maybe-src ,x ,e) (fx+ 1 size))]
|
||||
[(seq ,[e1 size1] ,[e2 size2])
|
||||
(values `(seq ,e1 ,e2) (fx+ size1 size2))]
|
||||
[(if ,[e1 size1] ,[e2 size2] ,[e3 size3])
|
||||
(values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))]
|
||||
[(foreign (,conv* ...) ,name ,[e size] (,arg-type* ...) ,result-type)
|
||||
(values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
|
||||
[(fcallable (,conv* ...) ,[e size] (,arg-type* ...) ,result-type)
|
||||
(values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
|
||||
; ($top-level-value 'x) adds just 1 to the size
|
||||
[(call ,preinfo ,pr (quote ,d))
|
||||
(guard (eq? (primref-name pr) '$top-level-value))
|
||||
(values `(call ,preinfo ,pr (quote ,d)) 1)]
|
||||
; (let ([x* e*] ...) body) splits into letrec binding unassigned variables to lambdas plus a let for the remaining bindings
|
||||
[(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,[body size])) ,[e* -> e* size*] ...)
|
||||
(guard (fx= (length e*) interface))
|
||||
(define-record-type fudge (nongenerative) (sealed #t) (fields x e size))
|
||||
(let-values ([(lb* ob*) (partition
|
||||
(lambda (b)
|
||||
(and (not (prelex-assigned (fudge-x b)))
|
||||
(Lcommonize1-lambda? (fudge-e b))))
|
||||
(map make-fudge x* e* size*))])
|
||||
(values
|
||||
(let ([body (if (null? ob*)
|
||||
body
|
||||
`(call ,preinfo1
|
||||
(case-lambda ,preinfo2
|
||||
(clause (,(map fudge-x ob*) ...) ,(length ob*) ,body))
|
||||
,(map fudge-e ob*) ...))])
|
||||
(if (null? lb*)
|
||||
body
|
||||
`(letrec ([,(map fudge-x lb*) ,(map fudge-e lb*) ,(map fudge-size lb*)] ...) ,body)))
|
||||
(apply fx+ size size*)))]
|
||||
[(call ,preinfo ,[e size] ,[e* size*] ...)
|
||||
(values `(call ,preinfo ,e ,e* ...) (apply fx+ size size*))]
|
||||
[(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* size*]) ...)
|
||||
(values `(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...) (apply fx+ 1 size*))]
|
||||
[(letrec ([,x* ,[e* size*]] ...) ,[body size])
|
||||
(values `(letrec ([,x* ,e* ,size*] ...) ,body) (apply fx+ size size*))]
|
||||
[(record-ref ,rtd ,type ,index ,[e size])
|
||||
(values `(record-ref ,rtd ,type ,index ,e) (fx+ size 1))]
|
||||
[(record-set! ,rtd ,type ,index ,[e1 size1] ,[e2 size2])
|
||||
(values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))]
|
||||
[(record ,rtd ,[rtd-expr size] ,[e* size*] ...)
|
||||
(values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))]
|
||||
[(cte-optimization-loc ,box ,[e size])
|
||||
(values `(cte-optimization-loc ,box ,e) size)]
|
||||
[(immutable-list (,[e* size*] ...) ,[e size])
|
||||
(values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))]
|
||||
[(quote ,d) (values `(quote ,d) 1)]
|
||||
[(ref ,maybe-src ,x) (values `(ref ,maybe-src ,x) 1)]
|
||||
[,pr (values pr 1)]
|
||||
[(moi) (values `(moi) 1)]
|
||||
[(pariah) (values `(pariah) 0)]
|
||||
[(profile ,src) (values `(profile ,src) 0)]
|
||||
[else (sorry! who "unhandled record ~s" ir)])
|
||||
(let-values ([(e size) (Expr ir)]) e))
|
||||
|
||||
(define-pass cpcommonize1 : Lcommonize1 (ir worthwhile-size) -> Lcommonize2 ()
|
||||
(definitions
|
||||
(define worthwhile-size?
|
||||
(lambda (expr-size)
|
||||
(fx>= expr-size worthwhile-size)))
|
||||
(define worthwhile-ratio?
|
||||
(lambda (expr-size subst-count)
|
||||
(or (fx= subst-count 0)
|
||||
(fx>= (div expr-size subst-count) 4))))
|
||||
(define-record-type subst
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(fields t e1 e2))
|
||||
(define-record-type frob
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(fields subst* e b))
|
||||
(define ht (make-hashtable values fx=))
|
||||
(define make-sym
|
||||
(lambda x*
|
||||
(string->symbol (apply string-append (map (lambda (x) (if (prelex? x) (symbol->string (prelex-name x)) x)) x*)))))
|
||||
(define same-preinfo?
|
||||
(lambda (p1 p2)
|
||||
; ignore differences in src and sexpr
|
||||
#t))
|
||||
(define same-preinfo-lambda?
|
||||
(lambda (p1 p2)
|
||||
; ignore differences src, sexpr, and name
|
||||
(eq? (preinfo-lambda-libspec p1) (preinfo-lambda-libspec p2))))
|
||||
(define-who same-type?
|
||||
(lambda (ty1 ty2)
|
||||
(nanopass-case (Ltype Type) ty1
|
||||
[(fp-integer ,bits1)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-integer ,bits2) (= bits1 bits2)]
|
||||
[else #f])]
|
||||
[(fp-unsigned ,bits1)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-unsigned ,bits2) (= bits1 bits2)]
|
||||
[else #f])]
|
||||
[(fp-void)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-void) #t]
|
||||
[else #f])]
|
||||
[(fp-scheme-object)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-scheme-object) #t]
|
||||
[else #f])]
|
||||
[(fp-u8*)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-u8*) #t]
|
||||
[else #f])]
|
||||
[(fp-u16*)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-u16*) #t]
|
||||
[else #f])]
|
||||
[(fp-u32*)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-u32*) #t]
|
||||
[else #f])]
|
||||
[(fp-fixnum)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-fixnum) #t]
|
||||
[else #f])]
|
||||
[(fp-double-float)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-double-float) #t]
|
||||
[else #f])]
|
||||
[(fp-single-float)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-single-float) #t]
|
||||
[else #f])]
|
||||
[(fp-ftd ,ftd1)
|
||||
(nanopass-case (Ltype Type) ty2
|
||||
[(fp-ftd ,ftd2) (eq? ftd1 ftd2)]
|
||||
[else #f])]
|
||||
[else (sorry! who "unhandled foreign type ~s" ty1)])))
|
||||
(define okay-to-subst?
|
||||
(lambda (e)
|
||||
(define free?
|
||||
(lambda (x)
|
||||
(and (not (prelex-operand x)) #t)))
|
||||
(nanopass-case (Lcommonize1 Expr) e
|
||||
[(ref ,maybe-src1 ,x1) (and (not (prelex-assigned x1)) (free? x1))]
|
||||
[(quote ,d) #t]
|
||||
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
|
||||
[else #f])))
|
||||
(define constant-equal?
|
||||
(lambda (x y)
|
||||
(define record-equal?
|
||||
(lambda (x y e?)
|
||||
(let ([rtd ($record-type-descriptor x)])
|
||||
(and (eq? ($record-type-descriptor y) rtd)
|
||||
(let f ([field-name* (csv7:record-type-field-names rtd)] [i 0])
|
||||
(or (null? field-name*)
|
||||
(and (let ([accessor (csv7:record-field-accessor rtd i)])
|
||||
(e? (accessor x) (accessor y)))
|
||||
(f (cdr field-name*) (fx+ i 1)))))))))
|
||||
(parameterize ([default-record-equal-procedure record-equal?])
|
||||
; equal? should be okay since even mutable constants aren't supposed to be mutated
|
||||
(equal? x y))))
|
||||
(define same?
|
||||
(lambda (e1 e2)
|
||||
(nanopass-case (Lcommonize1 Expr) e1
|
||||
[(ref ,maybe-src1 ,x1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(ref ,maybe-src2 ,x2)
|
||||
(or (eq? x1 x2)
|
||||
(eq? (prelex-operand x1) x2))]
|
||||
[else #f])]
|
||||
[(quote ,d1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(quote ,d2) (constant-equal? d1 d2)]
|
||||
[else #f])]
|
||||
[,pr1
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[,pr2 (eq? pr1 pr2)]
|
||||
[else #f])]
|
||||
[(moi)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(moi) #t]
|
||||
[else #f])]
|
||||
[(pariah)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(pariah) #t]
|
||||
[else #f])]
|
||||
[(profile ,src1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(profile ,src2) (eq? src1 src2)]
|
||||
[else #f])]
|
||||
[(call ,preinfo1 ,pr1 (quote ,d1))
|
||||
(guard (eq? (primref-name pr1) '$top-level-value))
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(call ,preinfo2 ,pr2 (quote ,d2))
|
||||
(guard (eq? (primref-name pr2) '$top-level-value))
|
||||
(and (same-preinfo? preinfo1 preinfo2) (eq? d1 d2))]
|
||||
[else #f])]
|
||||
[else #f])))
|
||||
(define-who unify
|
||||
(lambda (e1 e2)
|
||||
(module (with-env)
|
||||
(define $with-env
|
||||
(lambda (x1* x2* th)
|
||||
(dynamic-wind
|
||||
(lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 x2) (prelex-operand-set! x2 #t)) x1* x2*))
|
||||
th
|
||||
(lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 #f) (prelex-operand-set! x2 #f)) x1* x2*)))))
|
||||
(define-syntax with-env
|
||||
(syntax-rules ()
|
||||
[(_ x1* x2* e) ($with-env x1* x2* (lambda () e))])))
|
||||
(call/cc
|
||||
(lambda (return)
|
||||
(let ([subst* '()])
|
||||
(define lookup-subst
|
||||
(lambda (e1 e2)
|
||||
(define same-subst?
|
||||
(lambda (x)
|
||||
(and (same? (subst-e1 x) e1) (same? (subst-e2 x) e2))))
|
||||
(cond
|
||||
[(find same-subst? subst*) =>
|
||||
(lambda (subst)
|
||||
(let ([t (subst-t subst)])
|
||||
(set-prelex-multiply-referenced! t #t)
|
||||
t))]
|
||||
[else #f])))
|
||||
(let ([e (with-output-language (Lcommonize1 Expr)
|
||||
(let ()
|
||||
(define fclause
|
||||
(lambda (cl1 cl2)
|
||||
(nanopass-case (Lcommonize1 CaseLambdaClause) cl1
|
||||
[(clause (,x1* ...) ,interface1 ,body1)
|
||||
(nanopass-case (Lcommonize1 CaseLambdaClause) cl2
|
||||
[(clause (,x2* ...) ,interface2 ,body2)
|
||||
(if (fx= interface1 interface2)
|
||||
(with-env x1* x2*
|
||||
(with-output-language (Lcommonize1 CaseLambdaClause)
|
||||
`(clause (,x1* ...) ,interface1 ,(f body1 body2))))
|
||||
(return (iffalse #f (printf "lambda interfaces don't match\n")) '()))])])))
|
||||
(define f
|
||||
(case-lambda
|
||||
[(e1 e2) (f e1 e2 #f)]
|
||||
[(e1 e2 call-position?)
|
||||
(or (cond
|
||||
[(same? e1 e2) e1]
|
||||
[(and (not call-position?) (okay-to-subst? e1) (okay-to-subst? e2))
|
||||
`(ref #f ,(or (lookup-subst e1 e2)
|
||||
(let ([t (make-prelex*)])
|
||||
(set-prelex-referenced! t #t)
|
||||
(set! subst* (cons (make-subst t e1 e2) subst*))
|
||||
t)))]
|
||||
[else
|
||||
(nanopass-case (Lcommonize1 Expr) e1
|
||||
[(ref ,maybe-src1 ,x1) #f]
|
||||
[(quote ,d) #f]
|
||||
[,pr #f]
|
||||
[(moi) #f]
|
||||
[(profile ,src1) #f]
|
||||
; reject non-same top-level-value calls with constant symbol so they
|
||||
; don't end up being abstracted over the symbol in the residual code
|
||||
[(call ,preinfo ,pr (quote ,d))
|
||||
(guard (eq? (primref-name pr) '$top-level-value))
|
||||
#f]
|
||||
; don't allow abstraction of first (type) argument to $object-ref, foreign-ref, etc.,
|
||||
; since they can't be inlined without a constant type.
|
||||
; ditto for $tc-field's first (field) argument.
|
||||
; there are many other primitives we don't catch here for which the compiler generates
|
||||
; more efficient code when certain arguments are constant.
|
||||
[(call ,preinfo1 ,pr1 (quote ,d1) ,e1* ...)
|
||||
(guard (memq (primref-name pr1) '($object-ref $swap-object-ref $object-set foreign-ref foreign-set! $tc-field)))
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(call ,preinfo2 ,pr2 (quote ,d2) ,e2* ...)
|
||||
(guard (eq? pr2 pr1) (eq? d1 d2))
|
||||
(and (same-preinfo? preinfo1 preinfo2)
|
||||
(fx= (length e1*) (length e2*))
|
||||
`(call ,preinfo1 ,pr1 (quote ,d1) ,(map f e1* e2*) ...))]
|
||||
[else #f])]
|
||||
[(call ,preinfo1 ,e1 ,e1* ...)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(call ,preinfo2 ,e2 ,e2* ...)
|
||||
(and (fx= (length e1*) (length e2*))
|
||||
(same-preinfo? preinfo1 preinfo2)
|
||||
`(call ,preinfo1 ,(f e1 e2 #t) ,(map f e1* e2*) ...))]
|
||||
[else #f])]
|
||||
[(if ,e10 ,e11 ,e12)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(if ,e20 ,e21 ,e22)
|
||||
`(if ,(f e10 e20) ,(f e11 e21) ,(f e12 e22))]
|
||||
[else #f])]
|
||||
[(case-lambda ,preinfo1 ,cl1* ...)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(case-lambda ,preinfo2 ,cl2* ...)
|
||||
(and (fx= (length cl1*) (length cl2*))
|
||||
(same-preinfo-lambda? preinfo1 preinfo2)
|
||||
`(case-lambda ,preinfo1 ,(map fclause cl1* cl2*) ...))]
|
||||
[else #f])]
|
||||
[(seq ,e11 ,e12)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(seq ,e21 ,e22) `(seq ,(f e11 e21) ,(f e12 e22))]
|
||||
[else #f])]
|
||||
[(set! ,maybe-src1 ,x1 ,e1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(set! ,maybe-src2 ,x2 ,e2)
|
||||
(and (eq? x1 x2)
|
||||
`(set! ,maybe-src1 ,x1 ,(f e1 e2)))]
|
||||
[else #f])]
|
||||
[(letrec ([,x1* ,e1* ,size1*] ...) ,body1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(letrec ([,x2* ,e2* ,size2*] ...) ,body2)
|
||||
(and (fx= (length x2*) (length x1*))
|
||||
(andmap fx= size1* size2*)
|
||||
(with-env x1* x2*
|
||||
`(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))]
|
||||
[else #f])]
|
||||
[(foreign (,conv1* ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(foreign (,conv2* ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2)
|
||||
(and (equal? conv1* conv2*)
|
||||
(equal? name1 name2)
|
||||
(fx= (length arg-type1*) (length arg-type2*))
|
||||
(andmap same-type? arg-type1* arg-type2*)
|
||||
(same-type? result-type1 result-type2)
|
||||
`(foreign (,conv1* ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
|
||||
[else #f])]
|
||||
[(fcallable (,conv1* ...) ,e1 (,arg-type1* ...) ,result-type1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(fcallable (,conv2* ...) ,e2 (,arg-type2* ...) ,result-type2)
|
||||
(and (equal? conv1* conv2*)
|
||||
(fx= (length arg-type1*) (length arg-type2*))
|
||||
(andmap same-type? arg-type1* arg-type2*)
|
||||
(same-type? result-type1 result-type2)
|
||||
`(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
|
||||
[else #f])]
|
||||
[(cte-optimization-loc ,box1 ,e1)
|
||||
(nanopass-case (Lcommonize1 Expr) e2
|
||||
[(cte-optimization-loc ,box2 ,e2)
|
||||
(and (eq? box1 box2)
|
||||
`(cte-optimization-loc ,box1 ,(f e1 e2)))]
|
||||
[else #f])]
|
||||
[else (sorry! who "unhandled record ~s" e1)])])
|
||||
(return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))]))
|
||||
(f e1 e2)))])
|
||||
(values e subst*)))))))
|
||||
(define sort-substs
|
||||
; reestablish original argument order for substituted variables where possible
|
||||
; so the arguments to an abstracted procedure aren't shuffled around in the
|
||||
; call to the generated helper.
|
||||
(lambda (subst0* x1* x2*)
|
||||
(define (this? x x*) (and (not (null? x*)) (eq? x (car x*))))
|
||||
(define (next x*) (if (null? x*) x* (cdr x*)))
|
||||
(let-values ([(new-subst* subst*) (let f ([x1* x1*] [x2* x2*] [subst* subst0*] [n (length subst0*)])
|
||||
(cond
|
||||
[(fx= n 0) (values '() subst*)]
|
||||
[(find (lambda (subst)
|
||||
(define (is-this-arg? e x*)
|
||||
(nanopass-case (Lcommonize1 Expr) e
|
||||
[(ref ,maybe-src ,x) (this? x x*)]
|
||||
[else #f]))
|
||||
(or (is-this-arg? (subst-e1 subst) x1*)
|
||||
(is-this-arg? (subst-e2 subst) x2*)))
|
||||
subst*) =>
|
||||
(lambda (subst)
|
||||
(let-values ([(new-subst* subst*) (f (next x1*) (next x2*) (remq subst subst*) (fx- n 1))])
|
||||
(values (cons subst new-subst*) subst*)))]
|
||||
[else
|
||||
(let-values ([(new-subst* subst*) (f (next x1*) (next x2*) subst* (fx- n 1))])
|
||||
(values (cons (car subst*) new-subst*) (cdr subst*)))]))])
|
||||
(safe-assert (null? subst*))
|
||||
(safe-assert (fx= (length new-subst*) (length subst0*)))
|
||||
new-subst*)))
|
||||
(define find-match
|
||||
(lambda (b1 ht)
|
||||
(and (iffalse (worthwhile-size? (binding-size b1)) (printf "skipping b1: under worthwhile size ~s ~s\n" (binding-size b1) worthwhile-size))
|
||||
(ormap (lambda (b2)
|
||||
(iffalse #f (printf "checking ~s & ~s:" (prelex-name (binding-x b1)) (prelex-name (binding-x b2))))
|
||||
(nanopass-case (Lcommonize1 Expr) (binding-e b1)
|
||||
; NB: restricting to one clause for now...handling multiple
|
||||
; NB: clauses should be straightforward with a helper per
|
||||
; NB: common clause.
|
||||
[(case-lambda ,preinfo1 (clause (,x1* ...) ,interface1 ,body1))
|
||||
; NB: no rest interface for now. should be straightforward
|
||||
(guard (fxnonnegative? interface1))
|
||||
(and
|
||||
(nanopass-case (Lcommonize1 Expr) (binding-e b2)
|
||||
[(case-lambda ,preinfo2 (clause (,x2* ...) ,interface2 ,body2))
|
||||
(guard (fxnonnegative? interface2))
|
||||
(let-values ([(e subst*) (unify body1 body2)])
|
||||
(and e
|
||||
(iffalse (worthwhile-ratio? (binding-size b1) (length subst*)) (printf " no, not worthwhile ratio ~s ~s\n" (binding-size b1) (length subst*)))
|
||||
(let ([subst* (sort-substs subst* x1* x2*)])
|
||||
(iffalse #f (printf " yes\n"))
|
||||
(make-frob subst* e b2))))]
|
||||
[else (iffalse #f (printf " no, b2 does not meet lambda restrictions\n"))]))]
|
||||
[else (iffalse #f (printf " no, b1 does not meet lambda restrictions\n"))]))
|
||||
(hashtable-ref ht (binding-size b1) '())))))
|
||||
(define record-helper!
|
||||
(lambda (b next e*)
|
||||
(binding-helper-b-set! b next)
|
||||
(binding-helper-arg*-set! b e*)))
|
||||
(define build-helper
|
||||
(lambda (t t* body size helper-box)
|
||||
(make-binding t
|
||||
(with-output-language (Lcommonize1 Expr)
|
||||
`(case-lambda ,(make-preinfo-lambda) (clause (,t* ...) ,(length t*) ,body)))
|
||||
size
|
||||
helper-box)))
|
||||
(define commonize-letrec
|
||||
(lambda (x* e* size* body) ; e* and body have not been processed
|
||||
(define (prune-and-process! b)
|
||||
(let ([b* (remq b (hashtable-ref ht (binding-size b) '()))])
|
||||
(if (null? b*)
|
||||
(hashtable-delete! ht (binding-size b))
|
||||
(hashtable-set! ht (binding-size b) b*)))
|
||||
(unless (binding-helper-b b) (binding-e-set! b (Expr (binding-e b)))))
|
||||
(if (null? x*)
|
||||
body
|
||||
(let ([helper-box (box '())])
|
||||
(let ([b* (map (lambda (x e size) (make-binding x e size helper-box)) x* e* size*)])
|
||||
(let ([body (let f ([b* b*])
|
||||
(if (null? b*)
|
||||
(Expr body)
|
||||
(let ([b (car b*)])
|
||||
(let ([frob (find-match b ht)])
|
||||
(if frob
|
||||
(let* ([outer-b (frob-b frob)]
|
||||
[helper-box (binding-helper-box outer-b)]
|
||||
[helper-b (let ([t (make-prelex* (make-sym (binding-x b) "&" (binding-x outer-b)))])
|
||||
(build-helper t (map subst-t (frob-subst* frob)) (frob-e frob) (binding-size outer-b) helper-box))])
|
||||
(set-box! helper-box (cons helper-b (unbox helper-box)))
|
||||
(record-helper! b helper-b (map subst-e1 (frob-subst* frob)))
|
||||
(record-helper! outer-b helper-b (map subst-e2 (frob-subst* frob)))
|
||||
(hashtable-update! ht (binding-size outer-b) (lambda (b*) (cons helper-b (remq outer-b b*))) '())
|
||||
(f (cdr b*)))
|
||||
(begin
|
||||
(hashtable-update! ht (binding-size b) (lambda (b*) (cons b b*)) '())
|
||||
(let ([body (f (cdr b*))])
|
||||
(prune-and-process! b)
|
||||
body)))))))])
|
||||
(let ([helper-b* (unbox helper-box)])
|
||||
(for-each prune-and-process! helper-b*)
|
||||
(with-output-language (Lcommonize2 Expr)
|
||||
`(letrec (,helper-b* ...) (,b* ...) ,body))))))))))
|
||||
(Expr : Expr (ir) -> Expr ()
|
||||
[(letrec ([,x* ,e* ,size*] ...) ,body)
|
||||
; only unassigned lambda bindings post-cpletrec
|
||||
(safe-assert (andmap (lambda (x) (not (prelex-assigned x))) x*))
|
||||
(safe-assert (andmap (lambda (e) (Lcommonize1-lambda? e)) e*))
|
||||
(commonize-letrec x* e* size* body)]
|
||||
[(letrec* ([,x* ,e*] ...) ,body)
|
||||
; no letrec* run post-cpletrec
|
||||
(assert #f)]))
|
||||
|
||||
(define-pass cpcommonize2 : Lcommonize2 (ir) -> Lsrc ()
|
||||
(definitions
|
||||
(define build-caller
|
||||
(lambda (e helper-b helper-arg*)
|
||||
(define-who Arg
|
||||
(lambda (e)
|
||||
(with-output-language (Lsrc Expr)
|
||||
(nanopass-case (Lcommonize1 Expr) e
|
||||
[(ref ,maybe-src ,x) `(ref ,maybe-src ,x)]
|
||||
[(quote ,d) `(quote ,d)]
|
||||
[else (sorry! who "unexpected helper arg ~s" e)]))))
|
||||
(define propagate
|
||||
(lambda (alist)
|
||||
(lambda (e)
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(ref ,maybe-src ,x)
|
||||
(cond
|
||||
[(assq x alist) => cdr]
|
||||
[else e])]
|
||||
[else e]))))
|
||||
(nanopass-case (Lcommonize1 Expr) e
|
||||
[(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
|
||||
(with-output-language (Lsrc Expr)
|
||||
`(case-lambda ,preinfo
|
||||
(clause (,x* ...) ,interface
|
||||
,(let loop ([helper-b helper-b] [e* (map Arg helper-arg*)])
|
||||
(if (binding-helper-b helper-b)
|
||||
(nanopass-case (Lcommonize1 Expr) (binding-e helper-b)
|
||||
[(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
|
||||
(loop (binding-helper-b helper-b) (map (propagate (map cons x* e*)) (map Arg (binding-helper-arg* helper-b))))])
|
||||
`(call ,(make-preinfo)
|
||||
,(let ([t (binding-x helper-b)])
|
||||
(if (prelex-referenced t)
|
||||
(set-prelex-multiply-referenced! t #t)
|
||||
(set-prelex-referenced! t #t))
|
||||
`(ref #f ,t))
|
||||
,e* ...))))))])))
|
||||
(define maybe-build-caller
|
||||
(lambda (b)
|
||||
(let ([helper-b (binding-helper-b b)] [e (binding-e b)])
|
||||
(if helper-b
|
||||
(build-caller e helper-b (binding-helper-arg* b))
|
||||
(Expr e))))))
|
||||
(Expr : Expr (ir) -> Expr ()
|
||||
[(letrec (,helper-b* ...) (,b* ...) ,[body])
|
||||
(let loop ([rb* (reverse helper-b*)] [x* (map binding-x b*)] [e* (map maybe-build-caller b*)])
|
||||
(if (null? rb*)
|
||||
`(letrec ([,x* ,e*] ...) ,body)
|
||||
(let ([b (car rb*)] [rb* (cdr rb*)])
|
||||
(if (prelex-referenced (binding-x b))
|
||||
(loop rb* (cons (binding-x b) x*) (cons (maybe-build-caller b) e*))
|
||||
(loop rb* x* e*)))))]))
|
||||
|
||||
(lambda (x)
|
||||
(let ([level (commonization-level)])
|
||||
(if (fx= level 0)
|
||||
x
|
||||
(let ([worthwhile-size (expt 2 (fx- 10 level))])
|
||||
(cpcommonize2 (cpcommonize1 (cpcommonize0 x) worthwhile-size))))))))
|
||||
)
|
||||
392
s/cpletrec.ss
Normal file
392
s/cpletrec.ss
Normal file
|
|
@ -0,0 +1,392 @@
|
|||
;;; cpletrec.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
#|
|
||||
Notes:
|
||||
- cpletrec does not consider a record-ref form or call to a restricted
|
||||
primitive, like car, to be pure even at optimize-level 3 because it's
|
||||
possible it will be moved ahead of an explicit test within a sequence
|
||||
of letrec* bindings.
|
||||
|#
|
||||
|
||||
#|
|
||||
Handling letrec and letrec*
|
||||
- call cpletrec on each rhs recursively to determine the new rhs,
|
||||
whether it's pure, and which of the lhs variables are free in it
|
||||
- call cpletrec on the body
|
||||
- build a graph. For letrec, create a link from b1 to b2 iff b2 is free
|
||||
in b1. for letrec*, also create a link from b1 to b2 if neither is
|
||||
pure and b1 originally appeared before b2.
|
||||
- determine the strongly connected components of the graph, partially
|
||||
sorted so that SCC1 comes before SCC2 if there exists a binding b2
|
||||
in SCC2 that has a link to a binding b1 in SCC1.
|
||||
- process each SCC as a separate set of letrec/letrec* bindings:
|
||||
- for letrec*, sort the bindings of the SCC by their original relative
|
||||
positions. for letrec, any order will do.
|
||||
- if SCC contains a single binding b where LHS(b) is not assigned
|
||||
and RHS(b) is a lambda expression, bind using pure letrec,
|
||||
- otherwise, if SCC contains a single binding b where LHS(b) is
|
||||
not free in RHS(b), bind using let
|
||||
- otherwise, partition into lambda bindings lb ... and complex
|
||||
bindings cb ... where a binding b is lambda iff LHS(b) is not
|
||||
assigned and RHS(b) is a lambda expression. Generate:
|
||||
(let ([LHS(cb) (void)] ...)
|
||||
(letrec ([LHS(lb) RHS(cb)] ...)
|
||||
(set! LHS(cb) RHS(cb)) ...
|
||||
body))
|
||||
- assimilate nested pure letrec forms
|
||||
|#
|
||||
|
||||
(define $cpletrec
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
|
||||
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
|
||||
|
||||
(define-pass lift-profile-forms : Lsrc (ir) -> Lsrc ()
|
||||
(definitions
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define lift-profile-forms
|
||||
; pull out profile forms from simple subforms so the profile
|
||||
; forms won't interfere with downstream optimizations
|
||||
(lambda (e* k)
|
||||
(define extract-profile
|
||||
(lambda (e profile*)
|
||||
(define profile?
|
||||
(lambda (e)
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(profile ,src) #t]
|
||||
[(seq ,e1 ,e2) (and (profile? e1) (profile? e2))]
|
||||
[else #f])))
|
||||
(define simple?
|
||||
(lambda (e)
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(quote ,d) #t]
|
||||
[(ref ,maybe-src ,x) #t]
|
||||
[,pr #t]
|
||||
[(call ,preinfo ,pr ,e*) (eq? (primref-name pr) '$top-level-value)]
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[else #f])))
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(seq ,e1 ,e2)
|
||||
(guard (and (profile? e1) (simple? e2)))
|
||||
(values e2 (cons e1 profile*))]
|
||||
[else (values e profile*)])))
|
||||
(let f ([e* e*] [re* '()] [profile* '()])
|
||||
(if (null? e*)
|
||||
(fold-left (lambda (e profile) `(seq ,profile ,e))
|
||||
(k (reverse re*))
|
||||
profile*)
|
||||
(let-values ([(e profile*) (extract-profile (car e*) profile*)])
|
||||
(f (cdr e*) (cons e re*) profile*))))))))
|
||||
(Expr : Expr (ir) -> Expr ()
|
||||
[(call ,preinfo ,[e] ,[e*] ...)
|
||||
(lift-profile-forms (cons e e*)
|
||||
(lambda (e*)
|
||||
`(call ,preinfo ,(car e*) ,(cdr e*) ...)))]
|
||||
[(letrec ([,x* ,[e*]] ...) ,[body])
|
||||
(lift-profile-forms e*
|
||||
(lambda (e*)
|
||||
`(letrec ([,x* ,e*] ...) ,body)))]
|
||||
[(letrec* ([,x* ,[e*]] ...) ,[body])
|
||||
(lift-profile-forms e*
|
||||
(lambda (e*)
|
||||
`(letrec* ([,x* ,e*] ...) ,body)))]))
|
||||
|
||||
(define-pass cpletrec : Lsrc (ir) -> Lsrc ()
|
||||
(definitions
|
||||
(define with-initialized-ids
|
||||
(lambda (old-id* proc)
|
||||
(let ([new-id* (map (lambda (old-id)
|
||||
(let ([new-id (make-prelex
|
||||
(prelex-name old-id)
|
||||
(let ([flags (prelex-flags old-id)])
|
||||
(fxlogor
|
||||
(fxlogand flags (constant prelex-sticky-mask))
|
||||
(fxsll (fxlogand flags (constant prelex-is-mask))
|
||||
(constant prelex-was-flags-offset))))
|
||||
(prelex-source old-id)
|
||||
#f)])
|
||||
(prelex-operand-set! old-id new-id)
|
||||
new-id))
|
||||
old-id*)])
|
||||
(let-values ([v* (proc new-id*)])
|
||||
(for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*)
|
||||
(apply values v*)))))
|
||||
(define (Expr* e*)
|
||||
(if (null? e*)
|
||||
(values '() #t)
|
||||
(let-values ([(e e-pure?) (Expr (car e*))]
|
||||
[(e* e*-pure?) (Expr* (cdr e*))])
|
||||
(values (cons e e*) (and e-pure? e*-pure?)))))
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define build-seq
|
||||
(lambda (e* body)
|
||||
(fold-right (lambda (e body) `(seq ,e ,body)) body e*)))
|
||||
(define build-let
|
||||
(lambda (call-preinfo lambda-preinfo lhs* rhs* body)
|
||||
(if (null? lhs*)
|
||||
body
|
||||
(let ([interface (length lhs*)])
|
||||
`(call ,call-preinfo
|
||||
(case-lambda ,lambda-preinfo
|
||||
(clause (,lhs* ...) ,interface ,body))
|
||||
,rhs* ...)))))
|
||||
(module (cpletrec-letrec)
|
||||
(define-record-type binding
|
||||
(fields (immutable lhs) (immutable pos) (mutable rhs) (mutable pure?) (mutable recursive?))
|
||||
(nongenerative)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (lhs pos)
|
||||
(new lhs pos #f #f #f)))))
|
||||
(define-record-type node ; isolate stuff needed for compute-sccs!
|
||||
(parent binding)
|
||||
(fields (mutable link*) (mutable root) (mutable done))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (make-new)
|
||||
(lambda (lhs pos)
|
||||
((make-new lhs pos) '() #f #f)))))
|
||||
(define (lambda? x)
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[else #f]))
|
||||
(define (cpletrec-bindings *? lhs* rhs*)
|
||||
(let ([all-b* (map make-node lhs* (enumerate lhs*))])
|
||||
(let loop ([b* all-b*] [rhs* rhs*] [last-nonpure #f])
|
||||
(unless (null? b*)
|
||||
(let ([b (car b*)] [rhs (car rhs*)])
|
||||
(for-each (lambda (lhs) (set-prelex-seen! lhs #f)) lhs*)
|
||||
(let-values ([(rhs pure?) (Expr rhs)])
|
||||
(binding-rhs-set! b rhs)
|
||||
(binding-pure?-set! b pure?)
|
||||
(binding-recursive?-set! b (prelex-seen (binding-lhs b)))
|
||||
(let ([free* (filter (lambda (b) (prelex-seen (binding-lhs b))) all-b*)])
|
||||
(if (or pure? (not *?))
|
||||
(begin
|
||||
(node-link*-set! b free*)
|
||||
(loop (cdr b*) (cdr rhs*) last-nonpure))
|
||||
(begin
|
||||
(node-link*-set! b
|
||||
(if (and last-nonpure (not (memq last-nonpure free*)))
|
||||
(cons last-nonpure free*)
|
||||
free*))
|
||||
(loop (cdr b*) (cdr rhs*) b))))))))
|
||||
all-b*))
|
||||
(define (compute-sccs v*) ; Tarjan's algorithm
|
||||
(define scc* '())
|
||||
(define (compute-sccs v)
|
||||
(define index 0)
|
||||
(define stack '())
|
||||
(define (tarjan v)
|
||||
(let ([v-index index])
|
||||
(node-root-set! v v-index)
|
||||
(set! stack (cons v stack))
|
||||
(set! index (fx+ index 1))
|
||||
(for-each
|
||||
(lambda (v^)
|
||||
(unless (node-done v^)
|
||||
(unless (node-root v^) (tarjan v^))
|
||||
(node-root-set! v (fxmin (node-root v) (node-root v^)))))
|
||||
(node-link* v))
|
||||
(when (fx= (node-root v) v-index)
|
||||
(set! scc*
|
||||
(cons
|
||||
(let f ([ls stack])
|
||||
(let ([v^ (car ls)])
|
||||
(node-done-set! v^ #t)
|
||||
(cons v^ (if (eq? v^ v)
|
||||
(begin (set! stack (cdr ls)) '())
|
||||
(f (cdr ls))))))
|
||||
scc*)))))
|
||||
(tarjan v))
|
||||
(for-each (lambda (v) (unless (node-done v) (compute-sccs v))) v*)
|
||||
(reverse scc*))
|
||||
(define (grisly-letrec lb* cb* body)
|
||||
(let ([rclhs* (fold-right (lambda (b lhs*)
|
||||
(let ([lhs (binding-lhs b)])
|
||||
(if (prelex-referenced/assigned lhs)
|
||||
(cons lhs lhs*)
|
||||
lhs*)))
|
||||
'() cb*)])
|
||||
(build-let (make-preinfo) (make-preinfo-lambda) rclhs* (map (lambda (x) `(quote ,(void))) rclhs*)
|
||||
(build-letrec (map binding-lhs lb*) (map binding-rhs lb*)
|
||||
(fold-right (lambda (b body)
|
||||
(let ([lhs (binding-lhs b)] [rhs (binding-rhs b)])
|
||||
`(seq
|
||||
,(if (prelex-referenced lhs)
|
||||
(begin
|
||||
(set-prelex-assigned! lhs #t)
|
||||
`(set! #f ,lhs ,rhs))
|
||||
rhs)
|
||||
,body)))
|
||||
body cb*)))))
|
||||
(define build-letrec
|
||||
(lambda (lhs* rhs* body)
|
||||
(if (null? lhs*)
|
||||
; dropping source here; could attach to body or add source record
|
||||
body
|
||||
(nanopass-case (Lsrc Expr) body
|
||||
; assimilate nested letrecs
|
||||
[(letrec ([,x* ,e*] ...) ,body)
|
||||
`(letrec ([,(append lhs* x*) ,(append rhs* e*)] ...) ,body)]
|
||||
[else `(letrec ([,lhs* ,rhs*] ...) ,body)]))))
|
||||
(define (expand-letrec b* body)
|
||||
(if (null? (cdr b*))
|
||||
(let* ([b (car b*)] [lhs (binding-lhs b)] [rhs (binding-rhs b)])
|
||||
(cond
|
||||
[(and (not (prelex-referenced/assigned lhs)) (binding-pure? b)) body]
|
||||
[(and (not (prelex-assigned lhs)) (lambda? rhs))
|
||||
(build-letrec (list lhs) (list rhs) body)]
|
||||
[(not (memq b (node-link* b)))
|
||||
(build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body)]
|
||||
[else (grisly-letrec '() b* body)]))
|
||||
(let-values ([(lb* cb*) (partition
|
||||
(lambda (b)
|
||||
(and (not (prelex-assigned (binding-lhs b)))
|
||||
(lambda? (binding-rhs b))))
|
||||
b*)])
|
||||
(grisly-letrec lb* cb* body))))
|
||||
(define (cpletrec-letrec *? lhs* rhs* body)
|
||||
(let ([b* (cpletrec-bindings *? lhs* rhs*)])
|
||||
(let-values ([(body body-pure?) (Expr body)])
|
||||
(values
|
||||
(let f ([scc* (compute-sccs b*)])
|
||||
(if (null? scc*)
|
||||
body
|
||||
(expand-letrec
|
||||
(if *?
|
||||
(sort
|
||||
(lambda (b1 b2) (fx< (binding-pos b1) (binding-pos b2)))
|
||||
(car scc*))
|
||||
(car scc*))
|
||||
(f (cdr scc*)))))
|
||||
(and body-pure? (andmap binding-pure? b*)))))))))
|
||||
(Expr : Expr (ir) -> Expr (#t)
|
||||
[(ref ,maybe-src ,x)
|
||||
(let ([x (prelex-operand x)])
|
||||
(safe-assert (prelex? x))
|
||||
(safe-assert (prelex-was-referenced x))
|
||||
(when (prelex-referenced x)
|
||||
(safe-assert (prelex-was-multiply-referenced x))
|
||||
(set-prelex-multiply-referenced! x #t))
|
||||
(set-prelex-seen/referenced! x #t)
|
||||
(values `(ref ,maybe-src ,x) (not (prelex-was-assigned x))))]
|
||||
[(quote ,d) (values ir #t)]
|
||||
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
||||
(guard (fx= (length e*) interface))
|
||||
(with-initialized-ids x*
|
||||
(lambda (x*)
|
||||
(let-values ([(body body-pure?) (Expr body)])
|
||||
(let-values ([(pre* lhs* rhs* pure?)
|
||||
(let f ([x* x*] [e* e*])
|
||||
(if (null? x*)
|
||||
(values '() '() '() #t)
|
||||
(let ([x (car x*)])
|
||||
(let-values ([(e e-pure?) (Expr (car e*))]
|
||||
[(pre* lhs* rhs* pure?) (f (cdr x*) (cdr e*))])
|
||||
(if (prelex-referenced/assigned x)
|
||||
(values pre* (cons x lhs*) (cons e rhs*) (and e-pure? pure?))
|
||||
(values (if e-pure? pre* (cons e pre*))
|
||||
lhs* rhs* (and e-pure? pure?)))))))])
|
||||
(values
|
||||
(build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body))
|
||||
(and body-pure? pure?))))))]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(let ()
|
||||
(define (arity-okay? arity n)
|
||||
(or (not arity)
|
||||
(ormap (lambda (a)
|
||||
(or (fx= n a)
|
||||
(and (fx< a 0) (fx>= n (fx- -1 a)))))
|
||||
arity)))
|
||||
(let-values ([(e* pure?) (Expr* e*)])
|
||||
(values
|
||||
`(call ,preinfo ,pr ,e* ...)
|
||||
(and pure?
|
||||
(all-set? (prim-mask (or proc pure unrestricted discard)) (primref-flags pr))
|
||||
(arity-okay? (primref-arity pr) (length e*))))))]
|
||||
[(call ,preinfo ,[e pure?] ,[e* pure?*] ...)
|
||||
(values `(call ,preinfo ,e ,e* ...) #f)]
|
||||
[(if ,[e0 e0-pure?] ,[e1 e1-pure?] ,[e2 e2-pure?])
|
||||
(values `(if ,e0 ,e1 ,e2) (and e0-pure? e1-pure? e2-pure?))]
|
||||
[(case-lambda ,preinfo ,[cl*] ...)
|
||||
(values `(case-lambda ,preinfo ,cl* ...) #t)]
|
||||
[(seq ,[e1 e1-pure?] ,[e2 e2-pure?])
|
||||
(values `(seq ,e1 ,e2) (and e1-pure? e2-pure?))]
|
||||
[(set! ,maybe-src ,x ,[e pure?])
|
||||
(let ([x (prelex-operand x)])
|
||||
(safe-assert (prelex? x))
|
||||
(safe-assert (prelex-was-assigned x))
|
||||
; NB: cpletrec-letrec assumes assignments to unreferenced ids are dropped
|
||||
(if (prelex-was-referenced x)
|
||||
(begin
|
||||
(set-prelex-seen/assigned! x #t)
|
||||
(values `(set! ,maybe-src ,x ,e) #f))
|
||||
(if pure? (values `(quote ,(void)) #t) (values `(seq ,e (quote ,(void))) #f))))]
|
||||
[(letrec ([,x* ,e*] ...) ,body)
|
||||
(with-initialized-ids x*
|
||||
(lambda (x*)
|
||||
(cpletrec-letrec #f x* e* body)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body)
|
||||
(with-initialized-ids x*
|
||||
(lambda (x*)
|
||||
(cpletrec-letrec #t x* e* body)))]
|
||||
[(foreign (,conv* ...) ,name ,[e pure?] (,arg-type* ...) ,result-type)
|
||||
(values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
||||
(and (fx= (optimize-level) 3) pure?))]
|
||||
[(fcallable (,conv* ...) ,[e pure?] (,arg-type* ...) ,result-type)
|
||||
(values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
|
||||
(and (fx= (optimize-level) 3) pure?))]
|
||||
[(record-ref ,rtd ,type ,index ,[e pure?])
|
||||
(values `(record-ref ,rtd ,type ,index ,e) #f)]
|
||||
[(record-set! ,rtd ,type ,index ,[e1 pure1?] ,[e2 pure2?])
|
||||
(values `(record-set! ,rtd ,type ,index ,e1 ,e2) #f)]
|
||||
[(record ,rtd ,[rtd-expr rtd-pure?] ,e* ...)
|
||||
(let-values ([(e* pure?) (Expr* e*)])
|
||||
(values
|
||||
`(record ,rtd ,rtd-expr ,e* ...)
|
||||
(and (and rtd-pure? pure?)
|
||||
(andmap
|
||||
(lambda (fld)
|
||||
(and (not (fld-mutable? fld))
|
||||
(eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
|
||||
(rtd-flds rtd)))))]
|
||||
[(record-type ,rtd ,e) (Expr e)]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (Expr e)]
|
||||
[(immutable-list (,[e* pure?*] ...) ,[e pure?])
|
||||
(values `(immutable-list (,e* ...) ,e) pure?)]
|
||||
[,pr (values pr #t)]
|
||||
[(moi) (values ir #t)]
|
||||
[(pariah) (values ir #t)]
|
||||
[(cte-optimization-loc ,box ,[e pure?])
|
||||
(values `(cte-optimization-loc ,box ,e) pure?)]
|
||||
[(profile ,src) (values ir #f)]
|
||||
[else (sorry! who "unhandled record ~s" ir)])
|
||||
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(with-initialized-ids x*
|
||||
(lambda (x*)
|
||||
(let-values ([(body pure?) (Expr body)])
|
||||
`(clause (,x* ...) ,interface ,body))))])
|
||||
(let-values ([(ir pure?) (Expr ir)]) ir))
|
||||
|
||||
(lambda (x)
|
||||
(let ([x (if (eq? ($compile-profile) 'source) (lift-profile-forms x) x)])
|
||||
(cpletrec x)))
|
||||
))
|
||||
16127
s/cpnanopass.ss
Normal file
16127
s/cpnanopass.ss
Normal file
File diff suppressed because it is too large
Load diff
305
s/cprep.ss
Normal file
305
s/cprep.ss
Normal file
|
|
@ -0,0 +1,305 @@
|
|||
;;; cprep.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "types.ss")
|
||||
(include "base-lang.ss")
|
||||
(include "expand-lang.ss")
|
||||
|
||||
(define-who Lexpand-to-go
|
||||
(lambda (x go)
|
||||
(define-pass go-Inner : (Lexpand Inner) (ir) -> * (val)
|
||||
(Inner : Inner (ir) -> * (val)
|
||||
[,lsrc (go lsrc)]
|
||||
[(program ,uid ,body) (go ($build-invoke-program uid body))]
|
||||
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
||||
(go ($build-install-library/ct-code uid export-id* import-code visit-code))]
|
||||
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
||||
(go ($build-install-library/rt-code uid dl* db* dv* de* body))]
|
||||
[(library/ct-info ,linfo/ct)
|
||||
`(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct)
|
||||
,(library/ct-info-visit-visit-req* linfo/ct)
|
||||
,(library/ct-info-visit-req* linfo/ct))]
|
||||
[(library/rt-info ,linfo/rt) `(library/rt-info ,(library-info-uid linfo/rt) ,(library/rt-info-invoke-req* linfo/rt))]
|
||||
[(program-info ,pinfo) `(program-info ,(program-info-invoke-req* pinfo))])
|
||||
(Inner ir))
|
||||
(let ([x* (let f ([x x] [x* '()])
|
||||
(nanopass-case (Lexpand Outer) x
|
||||
[(group ,outer1 ,outer2) (f outer1 (f outer2 x*))]
|
||||
[(visit-only ,inner) (cons `(eval-when (visit) ,(go-Inner inner)) x*)]
|
||||
[(revisit-only ,inner) (cons `(eval-when (revisit) ,(go-Inner inner)) x*)]
|
||||
[,inner (cons (go-Inner inner) x*)]
|
||||
[(recompile-info ,rcinfo) (cons `(recompile-requirements ,(recompile-info-import-req* rcinfo) ,(recompile-info-include-req* rcinfo)) x*)]
|
||||
[else (sorry! who "unexpected language form ~s" x)]))])
|
||||
(safe-assert (not (null? x*)))
|
||||
(cond
|
||||
[(= (length x*) 1) (car x*)]
|
||||
[else `(begin ,@x*)]))))
|
||||
|
||||
(set-who! $uncprep
|
||||
(rec $uncprep
|
||||
(case-lambda
|
||||
[(x) ($uncprep x #f)]
|
||||
[(x sexpr?)
|
||||
(define cache-sexpr
|
||||
(lambda (preinfo thunk)
|
||||
(if sexpr?
|
||||
(or (preinfo-sexpr preinfo)
|
||||
(let ([sexpr (thunk)])
|
||||
(preinfo-sexpr-set! preinfo sexpr)
|
||||
sexpr))
|
||||
(thunk))))
|
||||
(define get-name
|
||||
(lambda (x)
|
||||
(if sexpr? (prelex-name x) (prelex-uname x))))
|
||||
(define uncprep-lambda-clause
|
||||
(lambda (cl)
|
||||
(nanopass-case (Lsrc CaseLambdaClause) cl
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
`(,(if (fx< interface 0)
|
||||
(let f ((x* x*))
|
||||
(if (pair? (cdr x*))
|
||||
(cons (get-name (car x*)) (f (cdr x*)))
|
||||
(get-name (car x*))))
|
||||
(map get-name x*))
|
||||
,@(uncprep-sequence body '()))])))
|
||||
(define uncprep-sequence
|
||||
(lambda (x ls)
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
[(profile ,src) (guard (not (null? ls))) ls]
|
||||
[(seq ,e1 ,e2)
|
||||
(uncprep-sequence e1
|
||||
(uncprep-sequence e2 ls))]
|
||||
[else (cons (uncprep x) ls)])))
|
||||
(define uncprep-fp-conv
|
||||
(lambda (x*)
|
||||
(map (lambda (x)
|
||||
(case x
|
||||
[(i3nt-stdcall) '__stdcall]
|
||||
[(i3nt-com) '__com]
|
||||
[(adjust-active) '__collect_safe]
|
||||
[else #f]))
|
||||
x*)))
|
||||
(define-who uncprep-fp-specifier
|
||||
(lambda (x)
|
||||
(nanopass-case (Ltype Type) x
|
||||
[(fp-void) 'void]
|
||||
[(fp-integer ,bits)
|
||||
(case bits
|
||||
[(8) 'integer-8]
|
||||
[(16) 'integer-16]
|
||||
[(32) 'integer-32]
|
||||
[(64) 'integer-64]
|
||||
[else ($oops who "invalid integer size ~s" bits)])]
|
||||
[(fp-unsigned ,bits)
|
||||
(case bits
|
||||
[(8) 'unsigned-8]
|
||||
[(16) 'unsigned-16]
|
||||
[(32) 'unsigned-32]
|
||||
[(64) 'unsigned-64]
|
||||
[else ($oops who "invalid unsigned size ~s" bits)])]
|
||||
[(fp-scheme-object) 'scheme-object]
|
||||
[(fp-u8*) 'u8*]
|
||||
[(fp-u16*) 'u16*]
|
||||
[(fp-u32*) 'u32*]
|
||||
[(fp-fixnum) 'fixnum]
|
||||
[(fp-double-float) 'double-float]
|
||||
[(fp-single-float) 'single-float]
|
||||
[(fp-ftd ,ftd) 'ftype]
|
||||
[(fp-ftd& ,ftd) 'ftype])))
|
||||
(define uncprep
|
||||
(lambda (x)
|
||||
(define keyword?
|
||||
(lambda (x)
|
||||
(memq x
|
||||
; UPDATE THIS if new keywords are added
|
||||
'(let $primitive quote begin case-lambda
|
||||
library-case-lambda lambda if set!
|
||||
letrec letrec* $foreign-procedure
|
||||
$foreign-callable eval-when))))
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
[(ref ,maybe-src ,x) (get-name x)]
|
||||
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
||||
(guard (fx= (length e*) interface))
|
||||
(cache-sexpr preinfo0
|
||||
(lambda ()
|
||||
(if (null? x*)
|
||||
(uncprep body)
|
||||
`(let ,(map (lambda (x e)
|
||||
`(,(get-name x) ,(uncprep e)))
|
||||
x* e*)
|
||||
,@(uncprep-sequence body '())))))]
|
||||
[(call ,preinfo ,pr (quote ,d))
|
||||
(guard (eq? (primref-name pr) '$top-level-value) (symbol? d)
|
||||
(not (or (eq? ($real-sym-name d (interaction-environment)) d) (keyword? d))))
|
||||
(cache-sexpr preinfo
|
||||
(lambda ()
|
||||
($real-sym-name d (interaction-environment))))]
|
||||
[(call ,preinfo ,pr (quote ,d) ,e)
|
||||
(guard (eq? (primref-name pr) '$set-top-level-value!) (symbol? d)
|
||||
(not (or (eq? ($real-sym-name d (interaction-environment)) d) (keyword? d))))
|
||||
(cache-sexpr preinfo
|
||||
(lambda ()
|
||||
`(set! ,($real-sym-name d (interaction-environment)) ,(uncprep e))))]
|
||||
[(call ,preinfo ,e ,e* ...)
|
||||
(cache-sexpr preinfo
|
||||
(lambda ()
|
||||
`(,(uncprep e) ,@(map uncprep e*))))]
|
||||
[,pr (let ([sym (primref-name pr)])
|
||||
(if sexpr?
|
||||
($sgetprop sym '*unprefixed* sym)
|
||||
`($primitive ,(primref-level pr) ,sym)))]
|
||||
[(quote ,d)
|
||||
(cond
|
||||
[(eq? d (void)) '(#2%void)]
|
||||
[(self-evaluating? d) d]
|
||||
[else `(quote ,d)])]
|
||||
[(seq ,e1 ,e2)
|
||||
(let ([ls (uncprep-sequence x '())])
|
||||
(if (null? (cdr ls))
|
||||
(car ls)
|
||||
`(begin ,@ls)))]
|
||||
[(case-lambda ,preinfo ,cl* ...)
|
||||
(cache-sexpr preinfo
|
||||
(lambda ()
|
||||
(let ((cl* (map uncprep-lambda-clause cl*)))
|
||||
(if (and (not (null? cl*)) (null? (cdr cl*)))
|
||||
`(lambda ,@(car cl*))
|
||||
`(case-lambda ,@cl*)))))]
|
||||
[(if ,[e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
|
||||
[(set! ,maybe-src ,x ,[e]) `(set! ,(get-name x) ,e)]
|
||||
[(letrec ([,x* ,[e*]] ...) ,body)
|
||||
`(letrec ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
|
||||
,@(uncprep-sequence body '()))]
|
||||
[(letrec* ([,x* ,[e*]] ...) ,body)
|
||||
`(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
|
||||
,@(uncprep-sequence body '()))]
|
||||
[(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
|
||||
`($foreign-procedure ,(uncprep-fp-conv conv*) ,name ,e
|
||||
,(map uncprep-fp-specifier arg-type*)
|
||||
,(uncprep-fp-specifier result-type))]
|
||||
[(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
|
||||
`($foreign-callable ,(uncprep-fp-conv conv*) ,e
|
||||
,(map uncprep-fp-specifier arg-type*)
|
||||
,(uncprep-fp-specifier result-type))]
|
||||
[(record-ref ,rtd ,type ,index ,[e]) `(record-ref ,rtd ',type ,e ,index)]
|
||||
[(record-set! ,rtd ,type ,index ,[e1] ,[e2]) `(record-set! ,rtd ',type ,e1 ,index ,e2)]
|
||||
[(record ,rtd ,[rtd-expr] ,[e*] ...) `(record ,rtd ,rtd-expr ,@e*)]
|
||||
[(record-type ,rtd ,[e]) `(record-type ,rtd ,e)]
|
||||
[(record-cd ,rcd ,rtd-expr ,[e]) `(record-cd ,rcd ,e)]
|
||||
[(immutable-list (,e* ...) ,[e]) e]
|
||||
[(moi) ''moi]
|
||||
[(pariah) `(pariah (void))]
|
||||
[(profile ,src) `(void)]
|
||||
[(cte-optimization-loc ,box ,[e]) e]
|
||||
; for debugging:
|
||||
[(cpvalid-defer ,[e]) `(cpvalid-defer ,e)]
|
||||
[else ($oops who "unexpected record ~s" x)])))
|
||||
(Lexpand-to-go x uncprep)])))
|
||||
|
||||
(let ()
|
||||
(define (default-env)
|
||||
(if (eq? (subset-mode) 'system)
|
||||
($system-environment)
|
||||
(interaction-environment)))
|
||||
(define e/o
|
||||
(lambda (who cte? x env)
|
||||
(define (go x)
|
||||
($uncprep
|
||||
($cpcommonize
|
||||
($cpcheck
|
||||
(let ([cpletrec-ran? #f])
|
||||
(let ([x ((run-cp0)
|
||||
(lambda (x)
|
||||
(set! cpletrec-ran? #t)
|
||||
($cpletrec ($cp0 x $compiler-is-loaded?)))
|
||||
($cpvalid x))])
|
||||
(if cpletrec-ran? x ($cpletrec x))))))))
|
||||
(unless (environment? env)
|
||||
($oops who "~s is not an environment" env))
|
||||
; claim compiling-a-file to get cte as well as run-time code
|
||||
(Lexpand-to-go (expand x env #t cte?) go)))
|
||||
(set-who! expand/optimize
|
||||
(case-lambda
|
||||
[(x) (e/o who #f x (default-env))]
|
||||
[(x env) (e/o who #f x env)]))
|
||||
(set-who! $expand/cte/optimize
|
||||
(case-lambda
|
||||
[(x) (e/o who #t x (default-env))]
|
||||
[(x env) (e/o who #t x env)]))
|
||||
(set-who! $expand/cte
|
||||
(rec expand/cte
|
||||
(case-lambda
|
||||
[(x) (expand/cte x (default-env))]
|
||||
[(x env)
|
||||
(unless (environment? env)
|
||||
($oops who "~s is not an environment" env))
|
||||
; claim compiling-a-file to get cte as well as run-time code
|
||||
($uncprep (expand x env #t #t))]))))
|
||||
|
||||
(set-who! $cpcheck-prelex-flags
|
||||
(lambda (x after-pass)
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
|
||||
(define-pass cpcheck-prelex-flags : Lsrc (ir) -> Lsrc ()
|
||||
(definitions
|
||||
#;(define sorry!
|
||||
(lambda (who str . arg*)
|
||||
(apply fprintf (console-output-port) str arg*)
|
||||
(newline (console-output-port))))
|
||||
(define initialize-id!
|
||||
(lambda (id)
|
||||
(prelex-flags-set! id
|
||||
(let ([flags (prelex-flags id)])
|
||||
(fxlogor
|
||||
(fxlogand flags (constant prelex-sticky-mask))
|
||||
(fxsll (fxlogand flags (constant prelex-is-mask))
|
||||
(constant prelex-was-flags-offset))))))))
|
||||
(Expr : Expr (ir) -> Expr ()
|
||||
[(ref ,maybe-src ,x)
|
||||
(when (prelex-operand x) (sorry! who "~s has an operand after ~s (src ~s)" x after-pass maybe-src))
|
||||
(unless (prelex-was-referenced x) (sorry! who "~s referenced but not so marked after ~s (src ~s)" x after-pass maybe-src))
|
||||
(when (prelex-referenced x)
|
||||
(unless (prelex-was-multiply-referenced x) (sorry! who "~s multiply referenced but not so marked after ~s (src ~s)" x after-pass maybe-src))
|
||||
(set-prelex-multiply-referenced! x #t))
|
||||
(set-prelex-referenced! x #t)
|
||||
`(ref ,maybe-src ,x)]
|
||||
[(set! ,maybe-src ,x ,[e])
|
||||
(unless (prelex-was-assigned x) (sorry! who "~s assigned but not so marked after ~s (src ~s)" x after-pass maybe-src))
|
||||
(set-prelex-assigned! x #t)
|
||||
`(set! ,maybe-src ,x ,e)]
|
||||
[(letrec ([,x* ,e*] ...) ,body)
|
||||
(for-each initialize-id! x*)
|
||||
`(letrec ([,x* ,(map Expr e*)] ...) ,(Expr body))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body)
|
||||
(for-each initialize-id! x*)
|
||||
`(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))])
|
||||
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(for-each initialize-id! x*)
|
||||
`(clause (,x* ...) ,interface ,(Expr body))]))
|
||||
(Lexpand-to-go x cpcheck-prelex-flags)))
|
||||
|
||||
(set-who! $insert-profile-src! ; called from compiler only
|
||||
(lambda (st x)
|
||||
; NB: the output should be *, but nanopass won't autogenerate the pass
|
||||
(define-pass record-coverage-info! : Lsrc (ir) -> Lsrc ()
|
||||
(Expr : Expr (ir) -> Expr ()
|
||||
[(profile ,src) (source-table-set! st src 0) `(profile ,src)]))
|
||||
(Lexpand-to-go x record-coverage-info!)))
|
||||
)
|
||||
564
s/cpvalid.ss
Normal file
564
s/cpvalid.ss
Normal file
|
|
@ -0,0 +1,564 @@
|
|||
;;; cpvalid.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; see comments relating to both cpvalid and cpletrec at front of
|
||||
;;; cpletrec.ss
|
||||
|
||||
(begin
|
||||
(define undefined-variable-warnings
|
||||
($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
|
||||
(define-pass cpvalid : Lsrc (x) -> Lsrc ()
|
||||
(definitions
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define build-let
|
||||
(lambda (ids vals body)
|
||||
(if (null? ids)
|
||||
body
|
||||
`(call ,(make-preinfo)
|
||||
(case-lambda ,(make-preinfo-lambda)
|
||||
(clause (,ids ...) ,(length ids) ,body))
|
||||
,vals ...))))
|
||||
(define build-letrec
|
||||
(lambda (ids vals body)
|
||||
(if (null? ids)
|
||||
; dropping source here; could attach to body or add source record
|
||||
body
|
||||
`(letrec ([,ids ,vals] ...) ,body))))
|
||||
(define build-letrec*
|
||||
(lambda (ids vals body)
|
||||
(if (null? ids)
|
||||
; dropping source here; could attach to body or add source record
|
||||
body
|
||||
`(letrec* ([,ids ,vals] ...) ,body)))))
|
||||
|
||||
(define-record-type proxy
|
||||
(fields (mutable state))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda ()
|
||||
(new 'protectable)))))
|
||||
|
||||
(define-syntax with-protected
|
||||
(syntax-rules ()
|
||||
[(_ p e)
|
||||
(identifier? #'p)
|
||||
(begin
|
||||
(when p (proxy-state-set! p 'protected))
|
||||
(let-values ([t (let ()
|
||||
(define-syntax p
|
||||
(lambda (x)
|
||||
(syntax-error x "can't reference proxy inside with-protected")))
|
||||
e)])
|
||||
(when p (proxy-state-set! p 'protectable))
|
||||
(apply values t)))]))
|
||||
|
||||
(define-syntax with-unprotected
|
||||
(syntax-rules ()
|
||||
[(_ p e)
|
||||
(identifier? #'p)
|
||||
(begin
|
||||
(when p (proxy-state-set! p 'unprotected))
|
||||
(let-values ([t (let ()
|
||||
(define-syntax p
|
||||
(lambda (x)
|
||||
(syntax-error x "can't reference proxy inside with-unprotected")))
|
||||
e)])
|
||||
(when p (proxy-state-set! p 'protectable))
|
||||
(apply values t)))]))
|
||||
|
||||
(module (with-info with-valid* with-valid** with-proxy with-proxy*
|
||||
prelex-info-proxy prelex-info-valid-flag
|
||||
set-prelex-info-unsafe! prelex-info-unsafe
|
||||
set-prelex-info-referenced! prelex-info-referenced)
|
||||
(define-record-type info
|
||||
(fields (mutable proxy) (mutable unsafe) (mutable valid-flag) (mutable referenced))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda ()
|
||||
(new #f #f #f #f)))))
|
||||
|
||||
(define-syntax with-info
|
||||
(syntax-rules ()
|
||||
[(_ ids-expr e)
|
||||
(let ([ids ids-expr])
|
||||
(for-each
|
||||
(lambda (id)
|
||||
(safe-assert (not (prelex-operand id)))
|
||||
(prelex-operand-set! id (make-info)))
|
||||
ids)
|
||||
(let-values ([t e])
|
||||
(for-each
|
||||
(lambda (id)
|
||||
(safe-assert (prelex-operand id))
|
||||
(prelex-operand-set! id #f))
|
||||
ids)
|
||||
(apply values t)))]))
|
||||
|
||||
(define set-prelex-info-valid-flag!
|
||||
(lambda (id val)
|
||||
(info-valid-flag-set! (prelex-operand id) val)))
|
||||
|
||||
(define prelex-info-valid-flag
|
||||
(lambda (id)
|
||||
(let ([info (prelex-operand id)])
|
||||
(and info (info-valid-flag info)))))
|
||||
|
||||
(define-syntax with-valid*
|
||||
(syntax-rules ()
|
||||
[(_ valid-flag-expr ids-expr e)
|
||||
(let ([valid-flag valid-flag-expr] [ids ids-expr])
|
||||
(for-each (lambda (id) (set-prelex-info-valid-flag! id valid-flag)) ids)
|
||||
(let-values ([t e])
|
||||
(for-each (lambda (id) (set-prelex-info-valid-flag! id #f)) ids)
|
||||
(apply values t)))]))
|
||||
|
||||
(define-syntax with-valid**
|
||||
(syntax-rules ()
|
||||
[(_ valid-flags-expr ids-expr e)
|
||||
(let ([valid-flags valid-flags-expr] [ids ids-expr])
|
||||
(for-each (lambda (id vf) (set-prelex-info-valid-flag! id vf)) ids valid-flags)
|
||||
(let-values ([t e])
|
||||
(for-each (lambda (id) (set-prelex-info-valid-flag! id #f)) ids)
|
||||
(apply values t)))]))
|
||||
|
||||
(define-who set-prelex-info-proxy!
|
||||
(lambda (id val)
|
||||
(let ([info (prelex-operand id)])
|
||||
(safe-assert info)
|
||||
(info-proxy-set! info val))))
|
||||
|
||||
(define prelex-info-proxy
|
||||
(lambda (id)
|
||||
(let ([info (prelex-operand id)])
|
||||
(and info (info-proxy info)))))
|
||||
|
||||
(define-syntax with-proxy
|
||||
(syntax-rules ()
|
||||
[(_ proxy-expr id-expr e)
|
||||
(let ([proxy proxy-expr] [id id-expr])
|
||||
(set-prelex-info-proxy! id proxy)
|
||||
(let ([t e])
|
||||
(set-prelex-info-proxy! id #f)
|
||||
t))]))
|
||||
|
||||
(define-syntax with-proxy*
|
||||
(syntax-rules ()
|
||||
[(_ proxy-expr ids-expr e)
|
||||
(let ([proxy proxy-expr] [ids ids-expr])
|
||||
(for-each (lambda (id) (set-prelex-info-proxy! id proxy)) ids)
|
||||
(let-values ([t e])
|
||||
(for-each (lambda (id) (set-prelex-info-proxy! id #f)) ids)
|
||||
(apply values t)))]))
|
||||
|
||||
(define set-prelex-info-unsafe!
|
||||
(lambda (id val)
|
||||
(info-unsafe-set! (prelex-operand id) val)))
|
||||
|
||||
(define prelex-info-unsafe
|
||||
(lambda (id)
|
||||
(info-unsafe (prelex-operand id))))
|
||||
|
||||
(define set-prelex-info-referenced!
|
||||
(lambda (id val)
|
||||
(let ([info (prelex-operand id)])
|
||||
(when info (info-referenced-set! info val)))))
|
||||
|
||||
(define prelex-info-referenced
|
||||
(lambda (id)
|
||||
(info-referenced (prelex-operand id)))))
|
||||
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define insert-valid-check
|
||||
(lambda (what maybe-src id p x)
|
||||
(if (and p (not (eq? (proxy-state p) 'protected)))
|
||||
(let ([valid-flag (prelex-info-valid-flag id)])
|
||||
(if valid-flag
|
||||
(let ([name (prelex-name id)])
|
||||
(let ([mesg (format "attempt to ~a undefined variable ~~s" what)])
|
||||
(when (undefined-variable-warnings)
|
||||
($source-warning #f maybe-src #t (format "possible ~a" mesg) name))
|
||||
(if (prelex-referenced valid-flag)
|
||||
(set-prelex-multiply-referenced! valid-flag #t)
|
||||
(set-prelex-referenced! valid-flag #t))
|
||||
`(seq
|
||||
(if (ref #f ,valid-flag)
|
||||
(quote ,(void))
|
||||
(call ,(make-preinfo) ,(lookup-primref 2 '$source-violation)
|
||||
(quote #f)
|
||||
(quote ,maybe-src)
|
||||
(quote #t)
|
||||
(quote ,mesg)
|
||||
(quote ,name)))
|
||||
,x)))
|
||||
x))
|
||||
x))))
|
||||
|
||||
; wl = worklist
|
||||
; dl = deferred list
|
||||
(define (process-letrec-bindings cpvalid proxy proxy-ids ids vals unsafe* dl?)
|
||||
(let f ([wl (map list ids vals unsafe*)] [dl '()] [oops #f])
|
||||
(if (null? wl)
|
||||
(if oops
|
||||
(f dl '() #f)
|
||||
(with-proxy* proxy proxy-ids
|
||||
(map/ormap
|
||||
(lambda (x)
|
||||
(apply (lambda (id val unsafe)
|
||||
(let-values ([(val dl?) (cpvalid val proxy dl?)])
|
||||
(values (cons id val) dl?)))
|
||||
x))
|
||||
dl)))
|
||||
(apply (lambda (id val unsafe)
|
||||
(define update
|
||||
(lambda (x)
|
||||
(apply (lambda (id val unsafe)
|
||||
(if (or unsafe (prelex-info-referenced id))
|
||||
(begin (set-prelex-info-referenced! id #f)
|
||||
(list id val #t))
|
||||
x))
|
||||
x)))
|
||||
(if unsafe
|
||||
(let ([val (with-unprotected proxy
|
||||
(let ([proxy (make-proxy)])
|
||||
(with-proxy* proxy proxy-ids
|
||||
(first-value (cpvalid val proxy #f)))))])
|
||||
(let-values ([(ls dl?) (f (map update (cdr wl)) (map update dl) #t)])
|
||||
(values (cons (cons id val) ls) dl?)))
|
||||
(f (cdr wl) (cons (car wl) dl) oops)))
|
||||
(car wl)))))
|
||||
|
||||
(define map/ormap
|
||||
(case-lambda
|
||||
[(p ls)
|
||||
(if (null? ls)
|
||||
(values '() #f)
|
||||
(let-values ([(x b1) (p (car ls))]
|
||||
[(ls b2) (map/ormap p (cdr ls))])
|
||||
(values (cons x ls) (or b1 b2))))]
|
||||
[(p ls1 ls2)
|
||||
(if (null? ls1)
|
||||
(values '() #f)
|
||||
(let-values ([(x b1) (p (car ls1) (car ls2))]
|
||||
[(ls b2) (map/ormap p (cdr ls1) (cdr ls2))])
|
||||
(values (cons x ls) (or b1 b2))))]))
|
||||
|
||||
(define deferred?
|
||||
(lambda (x)
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
[(cpvalid-defer ,e) #t]
|
||||
[else #f])))
|
||||
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define defer-or-not
|
||||
(lambda (dl? x)
|
||||
(values
|
||||
(if (and dl? (not (deferred? x)))
|
||||
`(cpvalid-defer ,x)
|
||||
x)
|
||||
dl?))))
|
||||
|
||||
(define-syntax first-value
|
||||
(syntax-rules ()
|
||||
[(_ e) (let-values ([(x . r) e]) x)]))
|
||||
|
||||
(define undefer*
|
||||
(lambda (ls proxy dl?)
|
||||
(map/ormap
|
||||
(lambda (x) (undefer x proxy dl?))
|
||||
ls))))
|
||||
|
||||
(undefer : Expr (x proxy dl?) -> Expr (dl?)
|
||||
[(cpvalid-defer ,[undefer-helper : e dl?]) (values e dl?)]
|
||||
[else (values x #f)])
|
||||
|
||||
(undefer-helper : Expr (x proxy dl?) -> Expr (dl?)
|
||||
[(ref ,maybe-src ,x) (values x #f)]
|
||||
[(quote ,d) (values x #f)]
|
||||
[,pr (values x #f)]
|
||||
; recognize canonical form of a let after expansion
|
||||
[(call ,preinfo0
|
||||
(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,[undefer : body body-dl?]))
|
||||
,e* ...)
|
||||
(guard (fx= (length e*) interface))
|
||||
(let-values ([(e* args-dl?) (undefer* e* proxy dl?)])
|
||||
(defer-or-not (or body-dl? args-dl?)
|
||||
`(call ,preinfo0
|
||||
(case-lambda ,preinfo1
|
||||
(clause (,x* ...) ,interface ,body))
|
||||
,e* ...)))]
|
||||
[(call ,preinfo ,[undefer : e fun-dl?] ,e* ...)
|
||||
(let-values ([(e* args-dl?) (undefer* e* proxy dl?)])
|
||||
(defer-or-not (or fun-dl? args-dl?)
|
||||
`(call ,preinfo ,e ,e* ...)))]
|
||||
[(if ,[undefer : e0 dl0?] ,[undefer : e1 dl1?] ,[undefer : e2 dl2?])
|
||||
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
|
||||
[(case-lambda ,preinfo ,cl* ...)
|
||||
(cpvalid `(case-lambda ,preinfo ,cl* ...) proxy dl?)]
|
||||
[(seq ,[undefer : e1 dl1?] ,[undefer : e2 dl2?])
|
||||
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
|
||||
[(set! ,maybe-src ,x ,[undefer : e dl?])
|
||||
(defer-or-not dl? `(set! ,maybe-src ,x ,e))]
|
||||
[(letrec ([,x* ,e*] ...) ,[undefer : body body-dl?])
|
||||
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
|
||||
(defer-or-not (or body-dl? vals-dl?)
|
||||
`(letrec ([,x* ,e*] ...) ,body)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,[undefer : body body-dl?])
|
||||
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
|
||||
(defer-or-not (or body-dl? vals-dl?)
|
||||
`(letrec* ([,x* ,e*] ...) ,body)))]
|
||||
[(foreign (,conv* ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
|
||||
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
|
||||
[(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
|
||||
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
|
||||
[(cte-optimization-loc ,box ,[undefer : e dl?])
|
||||
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
|
||||
[(pariah) (values x #f)]
|
||||
[(profile ,src) (values x #f)]
|
||||
[(moi) (values x #f)]
|
||||
[else (sorry! who "unexpected record ~s" x)])
|
||||
|
||||
(CaseLambdaClause : CaseLambdaClause (ir proxy) -> CaseLambdaClause ()
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(let-values ([(body dl?) (with-protected proxy (cpvalid body #f #f))])
|
||||
`(clause (,x* ...) ,interface ,body))])
|
||||
|
||||
(cpvalid : Expr (x proxy dl?) -> Expr (dl?)
|
||||
[(ref ,maybe-src ,x)
|
||||
(set-prelex-info-referenced! x #t)
|
||||
(values
|
||||
(let ([p (prelex-info-proxy x)])
|
||||
; unsafe => x might be called. this can only happen if x has
|
||||
; gotten into the unprotected state
|
||||
(when (and p (eq? (proxy-state p) 'unprotected))
|
||||
(set-prelex-info-unsafe! x #t))
|
||||
(insert-valid-check "reference" maybe-src x p `(ref ,maybe-src ,x)))
|
||||
#f)]
|
||||
[,pr (values x #f)]
|
||||
[(quote ,d) (values x #f)]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(guard (all-set? (prim-mask (or proc discard)) (primref-flags pr)))
|
||||
(let-values ([(e* dl?) (map/ormap (lambda (e) (cpvalid e proxy dl?)) e*)])
|
||||
(defer-or-not dl? `(call ,preinfo ,pr ,e* ...)))]
|
||||
; recognize canonical form of a let after expansion
|
||||
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
||||
(guard (fx= (length e*) interface))
|
||||
(let ([proxy (or proxy (make-proxy))])
|
||||
(with-info x*
|
||||
(with-proxy* proxy x*
|
||||
(let-values ([(body body-dl?) (cpvalid body proxy dl?)])
|
||||
(let-values ([(e* dl?)
|
||||
(map/ormap
|
||||
(lambda (arg id)
|
||||
(if (prelex-info-unsafe id)
|
||||
(with-unprotected proxy (cpvalid arg #f #f))
|
||||
(cpvalid arg proxy dl?)))
|
||||
e* x*)])
|
||||
(defer-or-not (or dl? body-dl?)
|
||||
`(call ,preinfo0
|
||||
(case-lambda ,preinfo1
|
||||
(clause (,x* ...) ,interface ,body))
|
||||
,e* ...)))))))]
|
||||
[(call ,preinfo ,e ,e* ...)
|
||||
(values
|
||||
(with-unprotected proxy
|
||||
`(call ,preinfo
|
||||
,(first-value (cpvalid e #f #f))
|
||||
,(map (lambda (x) (first-value (cpvalid x #f #f))) e*) ...))
|
||||
#f)]
|
||||
[(case-lambda ,preinfo ,cl* ...)
|
||||
(if dl?
|
||||
(values `(cpvalid-defer ,x) #t)
|
||||
(values
|
||||
`(case-lambda ,preinfo ,(map (lambda (cl) (CaseLambdaClause cl proxy)) cl*) ...)
|
||||
#f))]
|
||||
[(set! ,maybe-src ,x ,e)
|
||||
(let-values ([(e dl?)
|
||||
; rhs is unsafe only if x is referenced
|
||||
(if (prelex-referenced x)
|
||||
(with-unprotected proxy (cpvalid e #f #f))
|
||||
(cpvalid e proxy dl?))])
|
||||
(defer-or-not dl?
|
||||
(insert-valid-check "assign" maybe-src x (prelex-info-proxy x)
|
||||
(first-value
|
||||
(defer-or-not dl?
|
||||
`(set! ,maybe-src ,x ,e))))))]
|
||||
[(letrec ([,x* ,e*] ...) ,body)
|
||||
(with-info x*
|
||||
(let*-values ([(proxy) (or proxy (make-proxy))]
|
||||
[(valid-flag) (make-prelex* 'valid?)]
|
||||
[(body body-dl?) (with-proxy* proxy x* (cpvalid body proxy dl?))]
|
||||
[(unsafe*) (map prelex-info-unsafe x*)])
|
||||
(for-each
|
||||
(lambda (id)
|
||||
(set-prelex-info-unsafe! id #f)
|
||||
(set-prelex-info-referenced! id #f))
|
||||
x*)
|
||||
(let*-values ([(alist dl?) (with-valid* valid-flag x*
|
||||
(process-letrec-bindings cpvalid proxy x* x* e* unsafe* dl?))]
|
||||
[(e*) (map (lambda (id) (cdr (assq id alist))) x*)])
|
||||
(defer-or-not (or dl? body-dl?)
|
||||
(if (prelex-referenced valid-flag)
|
||||
(begin
|
||||
(set-prelex-assigned! valid-flag #t)
|
||||
(build-let (list valid-flag) (list `(quote #f))
|
||||
(first-value
|
||||
(let-values ([(body body-dl?) (defer-or-not body-dl?
|
||||
`(seq
|
||||
(set! #f ,valid-flag (quote #t))
|
||||
,body))])
|
||||
(defer-or-not (or dl? body-dl?)
|
||||
(build-letrec x* e* body))))))
|
||||
(build-letrec x* e* body))))))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body)
|
||||
; - we do unprotected parts of each rhs plus unsafe lambda pieces
|
||||
; first and leave remaining lambda expressions to do later.
|
||||
; - a full-blown flow analysis could be even nicer and even make it
|
||||
; possible to detect references and assignments that are surely
|
||||
; bad.
|
||||
(with-info x*
|
||||
(let*-values ([(proxy) (or proxy (make-proxy))]
|
||||
[(valid-flags) (map (lambda (id) (make-prelex* 'valid?)) x*)]
|
||||
[(body body-dl?) (with-proxy* proxy x* (cpvalid body proxy dl?))]
|
||||
[(unsafe*) (map prelex-info-unsafe x*)])
|
||||
(define-record-type welt (nongenerative) (sealed #t)
|
||||
(fields id (mutable val) unsafe (mutable forbidden-ids) (mutable valid-flags)))
|
||||
(define (make-welts x* e* unsafe* valid-flags)
|
||||
(let f ([x* x*] [e* e*] [unsafe* unsafe*] [valid-flags valid-flags])
|
||||
(if (null? x*)
|
||||
'()
|
||||
(cons (make-welt (car x*) (car e*) (car unsafe*) x* valid-flags)
|
||||
(f (cdr x*) (cdr e*) (cdr unsafe*) (cdr valid-flags))))))
|
||||
(define (process-ws w* d*)
|
||||
(if (null? w*)
|
||||
(process-letrec-bindings undefer proxy '()
|
||||
(map welt-id d*)
|
||||
(map welt-val d*)
|
||||
(map welt-unsafe d*)
|
||||
dl?)
|
||||
(let ([w (car w*)])
|
||||
(let ([id (welt-id w)]
|
||||
[val (welt-val w)]
|
||||
[unsafe (welt-unsafe w)]
|
||||
[forbidden-ids (welt-forbidden-ids w)]
|
||||
[valid-flags (welt-valid-flags w)])
|
||||
(if (prelex-info-referenced id)
|
||||
(let ([val (with-proxy* proxy forbidden-ids
|
||||
(with-unprotected proxy
|
||||
(with-valid** valid-flags forbidden-ids
|
||||
(first-value
|
||||
; could obviate this test with
|
||||
; cpvalid-defer case in cpvalid
|
||||
(if (deferred? val)
|
||||
(undefer val #f #f)
|
||||
(cpvalid val #f #f))))))])
|
||||
(let-values ([(ls dl?) (process-ds (cdr w*) d* id (car valid-flags))])
|
||||
(values (cons (cons id val) ls) dl?)))
|
||||
(let-values ([(val dl?) (with-proxy* proxy forbidden-ids
|
||||
(with-unprotected proxy
|
||||
(with-valid** valid-flags forbidden-ids
|
||||
(cpvalid val #f #t))))])
|
||||
(if dl?
|
||||
(begin
|
||||
; deferred parts of rhs can reference own lhs, so remove it from forbidden list
|
||||
(welt-val-set! w val)
|
||||
(welt-forbidden-ids-set! w (cdr forbidden-ids))
|
||||
(welt-valid-flags-set! w (cdr valid-flags))
|
||||
(process-ds (cdr w*) (cons w d*) id (car valid-flags)))
|
||||
(let-values ([(ls dl?) (process-ds (cdr w*) d* id (car valid-flags))])
|
||||
(values (cons (cons id val) ls) dl?)))))))))
|
||||
(define (process-ds w* d* okay-before-id okay-before-valid-flags)
|
||||
; it's okay to reference any rhs before okay-before-id
|
||||
; trim forbidden lists accordingly
|
||||
(for-each
|
||||
(lambda (w)
|
||||
(cond
|
||||
[(memq okay-before-id (welt-forbidden-ids w)) =>
|
||||
(lambda (x*)
|
||||
(welt-forbidden-ids-set! w x*)
|
||||
(welt-valid-flags-set! w
|
||||
(memq okay-before-valid-flags (welt-valid-flags w))))]))
|
||||
d*)
|
||||
(let f ([d* d*] [new-d* '()] [oops? #f])
|
||||
(if (null? d*)
|
||||
(if oops?
|
||||
(f new-d* '() #f)
|
||||
(process-ws w* new-d*))
|
||||
(let* ([w (car d*)] [id (welt-id w)])
|
||||
(if (prelex-info-referenced id)
|
||||
(let ([val (with-proxy* proxy (welt-forbidden-ids w)
|
||||
(with-unprotected proxy
|
||||
(with-valid** (welt-valid-flags w) (welt-forbidden-ids w)
|
||||
(first-value (undefer (welt-val w) #f #f)))))])
|
||||
(let-values ([(ls dl?) (f (cdr d*) new-d* #t)])
|
||||
(values (cons (cons id val) ls) dl?)))
|
||||
(f (cdr d*) (cons w new-d*) oops?))))))
|
||||
(for-each
|
||||
(lambda (id)
|
||||
(set-prelex-info-unsafe! id #f)
|
||||
(set-prelex-info-referenced! id #f))
|
||||
x*)
|
||||
(let*-values ([(alist dl?) (process-ws (make-welts x* e* unsafe* valid-flags) '())]
|
||||
[(e*) (map (lambda (id) (cdr (assq id alist))) x*)]
|
||||
[(x* e* valid-flags)
|
||||
(let f ([x* x*] [e* e*] [valid-flags valid-flags])
|
||||
(if (null? x*)
|
||||
(values '() '() '())
|
||||
(let ([id (car x*)] [val (car e*)] [vf (car valid-flags)])
|
||||
(let-values ([(x* e* valid-flags) (f (cdr x*) (cdr e*) (cdr valid-flags))])
|
||||
(if (prelex-referenced vf)
|
||||
(begin
|
||||
(set-prelex-assigned! vf #t)
|
||||
(values
|
||||
(list* id (make-prelex* 'dummy) x*)
|
||||
(list* val `(set! #f ,vf (quote #t)) e*)
|
||||
(cons vf valid-flags)))
|
||||
(values
|
||||
(cons id x*)
|
||||
(cons val e*)
|
||||
valid-flags))))))])
|
||||
(defer-or-not (or dl? body-dl?)
|
||||
(build-let valid-flags (make-list (length valid-flags) `(quote #f))
|
||||
(first-value
|
||||
(defer-or-not (or dl? body-dl?)
|
||||
(build-letrec* x* e* body))))))))]
|
||||
[(if ,[cpvalid : e0 dl0?] ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
|
||||
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
|
||||
[(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
|
||||
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
|
||||
[(foreign (,conv* ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
|
||||
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
|
||||
[(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
|
||||
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
|
||||
[(cte-optimization-loc ,box ,[cpvalid : e dl?])
|
||||
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
|
||||
[(pariah) (values x #f)]
|
||||
[(profile ,src) (values x #f)]
|
||||
[(moi) (values x #f)]
|
||||
[else (sorry! who "unexpected record ~s" x)])
|
||||
(first-value (cpvalid x #f #f)))
|
||||
|
||||
(set! $cpvalid
|
||||
(lambda (x)
|
||||
(if (= (optimize-level) 3) x (cpvalid x)))))
|
||||
)
|
||||
453
s/date.ss
Normal file
453
s/date.ss
Normal file
|
|
@ -0,0 +1,453 @@
|
|||
;;; date.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; disagreements with SRFI 19:
|
||||
;;; - nanoseconds are limited to 999,999,999 (SRFI 19: 9,999,999)
|
||||
;;; - seconds are limited to 61 (SRFI 19: 60)
|
||||
;;; - days range from 1 to 31, inclusive (SRFI 19: 0 to 31, inclusive)
|
||||
;;; - years range from 1901 to about 2038, inclusive (SRFI 19: not clear)
|
||||
;;; - years start at 1970 under Windows
|
||||
;;; - current-date tz-offset defaults to local offset (SRFI 19: not specified)
|
||||
|
||||
;;; questions about SRFI 19:
|
||||
;;; - must tai times be supported?
|
||||
|
||||
;;; can't read past copyright notice in srfi 19 reference implementation.
|
||||
;;; is it really as restrictive as it appears?
|
||||
|
||||
;;; suck in srfi 19 tests, which seem only to be covered by license in
|
||||
;;; srfi 19 description.
|
||||
|
||||
;;; won't be implemented from SRFI 19 except as add-on:
|
||||
;;; - constants time-duration, time-monotonic, time-process, time-tai,
|
||||
;;; time-thread, and time-utc (violates no non-procedure value policy)
|
||||
|
||||
;;; not yet implemented from SRFI 19:
|
||||
;;; - time procedures
|
||||
;;; time-resolution [ts-time]
|
||||
;;; time-monotonic->time-utc ; may be impossible unless we roll our own
|
||||
;;; time-monotonic->time-utc! ; monotonic (= tai) based on utc plus leap
|
||||
;;; time-utc->time-monotonic ; seconds. yuck.
|
||||
;;; time-utc->time-monotonic!
|
||||
;;; - date procedures
|
||||
;;; date-week-number
|
||||
;;; date->time-monotonic
|
||||
;;; time-monotonic->date
|
||||
;;; date->string
|
||||
;;; string->date
|
||||
;;; - julian dates
|
||||
;;; current-julian-day
|
||||
;;; current-modified-julian-day
|
||||
;;; date->julian-day
|
||||
;;; date->modified-julian-day
|
||||
;;; julian-day->date
|
||||
;;; julian-day->time-monotonic
|
||||
;;; julian-day->time-utc
|
||||
;;; modified-julian-day->date
|
||||
;;; modified-julian-day->time-monotonic
|
||||
;;; modified-julian-day->time-utc
|
||||
;;; time-monotonic->julian-day
|
||||
;;; time-monotonic->modified-julian-day
|
||||
;;; time-utc->julian-day
|
||||
;;; time-utc->modified-julian-day
|
||||
;;; - tai times
|
||||
;;; ts-type 'time-tai
|
||||
;;; date->time-tai
|
||||
;;; time-monotonic->time-tai
|
||||
;;; time-monotonic->time-tai!
|
||||
;;; time-tai->date
|
||||
;;; time-tai->time-monotonic
|
||||
;;; time-tai->time-monotonic!
|
||||
;;; time-tai->time-utc
|
||||
;;; time-tai->time-utc!
|
||||
;;; time-utc->time-tai
|
||||
;;; time-utc->time-tai!
|
||||
;;; julian-day->time-tai
|
||||
;;; modified-julian-day->time-tai
|
||||
;;; time-tai->julian-day
|
||||
;;; time-tai->modified-julian-day
|
||||
|
||||
(let ()
|
||||
(define $clock-gettime ; clock_id -> tspair
|
||||
(foreign-procedure "(cs)clock_gettime"
|
||||
(integer-32)
|
||||
scheme-object))
|
||||
|
||||
(define $gmtime ; #f|tzoff X #f|tspair -> dtvec (returns #f on error)
|
||||
(foreign-procedure "(cs)gmtime"
|
||||
(scheme-object scheme-object)
|
||||
scheme-object))
|
||||
|
||||
(define $asctime ; #f | dtvec -> string (returns #f on error)
|
||||
(foreign-procedure "(cs)asctime"
|
||||
(scheme-object)
|
||||
scheme-object))
|
||||
|
||||
(define $mktime ; dtvec -> tspair (returns #f on error)
|
||||
(foreign-procedure "(cs)mktime"
|
||||
(scheme-object)
|
||||
scheme-object))
|
||||
|
||||
(define-record-type ts ; keep in sync with S_condition_wait in c/thread.c
|
||||
(fields (mutable typeno) (immutable pair))
|
||||
(nongenerative #{ts a5dq4nztnmq6xlgp-a})
|
||||
(sealed #t))
|
||||
|
||||
(define ts-type->typeno
|
||||
(lambda (who type)
|
||||
(case type
|
||||
[(time-process) (constant time-process)]
|
||||
[(time-thread) (constant time-thread)]
|
||||
[(time-duration) (constant time-duration)]
|
||||
[(time-monotonic) (constant time-monotonic)]
|
||||
[(time-utc) (constant time-utc)]
|
||||
[(time-collector-cpu) (constant time-collector-cpu)]
|
||||
[(time-collector-real) (constant time-collector-real)]
|
||||
[else ($oops who "unrecognized time type ~s" type)])))
|
||||
|
||||
(define ts-typeno->type
|
||||
(lambda (typeno)
|
||||
(cond
|
||||
[(eq? typeno (constant time-process)) 'time-process]
|
||||
[(eq? typeno (constant time-thread)) 'time-thread]
|
||||
[(eq? typeno (constant time-duration)) 'time-duration]
|
||||
[(eq? typeno (constant time-monotonic)) 'time-monotonic]
|
||||
[(eq? typeno (constant time-utc)) 'time-utc]
|
||||
[(eq? typeno (constant time-collector-cpu)) 'time-collector-cpu]
|
||||
[(eq? typeno (constant time-collector-real)) 'time-collector-real]
|
||||
[else ($oops 'time-internal "unexpected typeno ~s" typeno)])))
|
||||
|
||||
(define ts-sec (lambda (ts) (car (ts-pair ts))))
|
||||
(define ts-nsec (lambda (ts) (cdr (ts-pair ts))))
|
||||
(define set-ts-sec! (lambda (ts n) (set-car! (ts-pair ts) n)))
|
||||
(define set-ts-nsec! (lambda (ts n) (set-cdr! (ts-pair ts) n)))
|
||||
|
||||
(define (check-ts who ts)
|
||||
(unless (ts? ts)
|
||||
($oops who "~s is not a time record" ts)))
|
||||
|
||||
(define (check-ts-sec who sec)
|
||||
(unless (or (fixnum? sec) (bignum? sec))
|
||||
($oops who "invalid number of seconds ~s" sec)))
|
||||
|
||||
(define (check-same-type who t1 t2)
|
||||
(unless (fx= (ts-typeno t1) (ts-typeno t2))
|
||||
($oops who "types of ~s and ~s differ" t1 t2)))
|
||||
|
||||
(define (check-type-duration who t)
|
||||
(unless (fx= (ts-typeno t) (constant time-duration))
|
||||
($oops who "~s does not have type time-duration" t)))
|
||||
|
||||
(define-record-type dt
|
||||
(fields (immutable vec))
|
||||
(nongenerative #{dt a5jhglnb7tr8ubed-a})
|
||||
(sealed #t))
|
||||
|
||||
(define (check-dt who dt)
|
||||
(unless (dt? dt)
|
||||
($oops who "~s is not a date record" dt)))
|
||||
|
||||
(define (check-nsec who nsec)
|
||||
(unless (and (or (fixnum? nsec) (bignum? nsec)) (<= 0 nsec 999999999))
|
||||
($oops who "invalid nanosecond ~s" nsec)))
|
||||
|
||||
(define (check-sec who sec)
|
||||
(unless (and (fixnum? sec) (fx<= 0 sec 61))
|
||||
($oops who "invalid second ~s" sec)))
|
||||
|
||||
(define (check-min who min)
|
||||
(unless (and (fixnum? min) (fx<= 0 min 59))
|
||||
($oops who "invalid minute ~s" min)))
|
||||
|
||||
(define (check-hour who hour)
|
||||
(unless (and (fixnum? hour) (fx<= 0 hour 23))
|
||||
($oops who "invalid hour ~s" hour)))
|
||||
|
||||
(define (check-day who day)
|
||||
(unless (and (fixnum? day) (fx<= 1 day 31))
|
||||
($oops who "invalid day ~s" day)))
|
||||
|
||||
(define (check-mon who mon)
|
||||
(unless (and (fixnum? mon) (fx<= 1 mon 12))
|
||||
($oops who "invalid month ~s" mon)))
|
||||
|
||||
(define (check-year who year)
|
||||
(unless (and (fixnum? year) (fx>= year 1901))
|
||||
($oops who "invalid year ~s" year)))
|
||||
|
||||
(define (check-tz who tz)
|
||||
(unless (and (fixnum? tz)
|
||||
; being generous here...
|
||||
(fx<= (* -24 60 60) tz (* 24 60 60)))
|
||||
($oops who "invalid time-zone offset ~s" tz)))
|
||||
|
||||
(define $copy-time
|
||||
(lambda (t)
|
||||
(let ([p (ts-pair t)])
|
||||
(make-ts (ts-typeno t) (cons (car p) (cdr p))))))
|
||||
|
||||
(record-writer (type-descriptor ts)
|
||||
(lambda (x p wr)
|
||||
(let ([type (ts-typeno->type (ts-typeno x))] [sec (ts-sec x)] [nsec (ts-nsec x)])
|
||||
(if (and (< sec 0) (> nsec 0))
|
||||
(fprintf p "#<~s -~d.~9,'0d>" type (- -1 sec) (- 1000000000 nsec))
|
||||
(fprintf p "#<~s ~d.~9,'0d>" type sec nsec)))))
|
||||
|
||||
(record-writer (type-descriptor dt)
|
||||
(lambda (x p wr)
|
||||
(fprintf p "#<date~@[ ~a~]>"
|
||||
($asctime (dt-vec x)))))
|
||||
|
||||
(set-who! make-time
|
||||
(lambda (type nsec sec)
|
||||
(let ([typeno (ts-type->typeno who type)])
|
||||
(check-nsec who nsec)
|
||||
(check-ts-sec who sec)
|
||||
(make-ts typeno (cons sec nsec)))))
|
||||
|
||||
(set! time? (lambda (x) (ts? x)))
|
||||
|
||||
(set-who! time-type
|
||||
(lambda (ts)
|
||||
(check-ts who ts)
|
||||
(ts-typeno->type (ts-typeno ts))))
|
||||
|
||||
(set-who! time-second
|
||||
(lambda (ts)
|
||||
(check-ts who ts)
|
||||
(ts-sec ts)))
|
||||
|
||||
(set-who! time-nanosecond
|
||||
(lambda (ts)
|
||||
(check-ts who ts)
|
||||
(ts-nsec ts)))
|
||||
|
||||
(set-who! set-time-type!
|
||||
(lambda (ts type)
|
||||
(check-ts who ts)
|
||||
(ts-typeno-set! ts (ts-type->typeno who type))))
|
||||
|
||||
(set-who! set-time-second!
|
||||
(lambda (ts sec)
|
||||
(check-ts who ts)
|
||||
(check-ts-sec who sec)
|
||||
(set-ts-sec! ts sec)))
|
||||
|
||||
(set-who! set-time-nanosecond!
|
||||
(lambda (ts nsec)
|
||||
(check-ts who ts)
|
||||
(check-nsec who nsec)
|
||||
(set-ts-nsec! ts nsec)))
|
||||
|
||||
(set-who! time=?
|
||||
(lambda (t1 t2)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-same-type who t1 t2)
|
||||
(and (= (ts-sec t1) (ts-sec t2))
|
||||
(= (ts-nsec t1) (ts-nsec t2)))))
|
||||
|
||||
(set-who! time<?
|
||||
(lambda (t1 t2)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-same-type who t1 t2)
|
||||
(or (< (ts-sec t1) (ts-sec t2))
|
||||
(and (= (ts-sec t1) (ts-sec t2))
|
||||
(< (ts-nsec t1) (ts-nsec t2))))))
|
||||
|
||||
(set-who! time<=?
|
||||
(lambda (t1 t2)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-same-type who t1 t2)
|
||||
(or (< (ts-sec t1) (ts-sec t2))
|
||||
(and (= (ts-sec t1) (ts-sec t2))
|
||||
(<= (ts-nsec t1) (ts-nsec t2))))))
|
||||
|
||||
(set-who! time>=?
|
||||
(lambda (t1 t2)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-same-type who t1 t2)
|
||||
(or (> (ts-sec t1) (ts-sec t2))
|
||||
(and (= (ts-sec t1) (ts-sec t2))
|
||||
(>= (ts-nsec t1) (ts-nsec t2))))))
|
||||
|
||||
(set-who! time>?
|
||||
(lambda (t1 t2)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-same-type who t1 t2)
|
||||
(or (> (ts-sec t1) (ts-sec t2))
|
||||
(and (= (ts-sec t1) (ts-sec t2))
|
||||
(> (ts-nsec t1) (ts-nsec t2))))))
|
||||
|
||||
(let ([f (lambda (t1 t2 who)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-same-type who t1 t2)
|
||||
(let-values ([(sec nsec)
|
||||
(let ([sec (- (ts-sec t1) (ts-sec t2))]
|
||||
[nsec (- (ts-nsec t1) (ts-nsec t2))])
|
||||
(if (< nsec 0) (values (- sec 1) (+ nsec 1000000000)) (values sec nsec)))])
|
||||
(make-ts (constant time-duration) (cons sec nsec))))])
|
||||
(set-who! time-difference (lambda (t1 t2) (f t1 t2 who)))
|
||||
(set-who! time-difference! (lambda (t1 t2) (f t1 t2 who))))
|
||||
|
||||
(let ([f (lambda (t1 t2 who)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-type-duration who t2)
|
||||
(let-values ([(sec nsec)
|
||||
(let ([sec (- (ts-sec t1) (ts-sec t2))]
|
||||
[nsec (- (ts-nsec t1) (ts-nsec t2))])
|
||||
(if (< nsec 0) (values (- sec 1) (+ nsec 1000000000)) (values sec nsec)))])
|
||||
(make-ts (ts-typeno t1) (cons sec nsec))))])
|
||||
(set-who! subtract-duration (lambda (t1 t2) (f t1 t2 who)))
|
||||
(set-who! subtract-duration! (lambda (t1 t2) (f t1 t2 who))))
|
||||
|
||||
(let ([f (lambda (t1 t2 who)
|
||||
(check-ts who t1)
|
||||
(check-ts who t2)
|
||||
(check-type-duration who t2)
|
||||
(let-values ([(sec nsec)
|
||||
(let ([sec (+ (time-second t1) (time-second t2))]
|
||||
[nsec (+ (time-nanosecond t1) (time-nanosecond t2))])
|
||||
(if (>= nsec 1000000000) (values (+ sec 1) (- nsec 1000000000)) (values sec nsec)))])
|
||||
(make-ts (ts-typeno t1) (cons sec nsec))))])
|
||||
(set-who! add-duration (lambda (t1 t2) (f t1 t2 who)))
|
||||
(set-who! add-duration! (lambda (t1 t2) (f t1 t2 who))))
|
||||
|
||||
(set-who! copy-time
|
||||
(lambda (t)
|
||||
(check-ts who t)
|
||||
($copy-time t)))
|
||||
|
||||
(set-who! current-time
|
||||
(case-lambda
|
||||
[() (let ([typeno (constant time-utc)])
|
||||
(make-ts typeno ($clock-gettime typeno)))]
|
||||
[(type)
|
||||
(case type
|
||||
[(time-collector-cpu) ($copy-time ($gc-cpu-time))]
|
||||
[(time-collector-real) ($copy-time ($gc-real-time))]
|
||||
[else (let ([typeno (ts-type->typeno who type)])
|
||||
(make-ts typeno ($clock-gettime typeno)))])]))
|
||||
|
||||
(set-who! current-date
|
||||
(case-lambda
|
||||
[()
|
||||
(let ([dtvec ($gmtime #f #f)])
|
||||
(unless dtvec ($oops who "failed"))
|
||||
(make-dt dtvec))]
|
||||
[(tz)
|
||||
(check-tz who tz)
|
||||
(let ([dtvec ($gmtime tz #f)])
|
||||
(unless dtvec ($oops who "failed"))
|
||||
(make-dt dtvec))]))
|
||||
|
||||
(set-who! date-and-time ; ptime|#f -> string
|
||||
(case-lambda
|
||||
[() (or ($asctime #f) ($oops who "failed"))]
|
||||
[(dt)
|
||||
(check-dt who dt)
|
||||
(or ($asctime (dt-vec dt))
|
||||
($oops who "failed for date record ~s" dt))]))
|
||||
|
||||
(set-who! make-date
|
||||
(let ([do-make-date
|
||||
(lambda (nsec sec min hour day mon year tz tz-provided?)
|
||||
(check-nsec who nsec)
|
||||
(check-sec who sec)
|
||||
(check-min who min)
|
||||
(check-hour who hour)
|
||||
; need more accurate check for day based on year and month
|
||||
(check-day who day)
|
||||
(check-mon who mon)
|
||||
(check-year who year)
|
||||
(when tz-provided?
|
||||
(check-tz who tz))
|
||||
; keep in sync with cmacros.ss declarations of dtvec-nsec, etc.
|
||||
(let ([dtvec (vector nsec sec min hour day mon (- year 1900) 0 #f 0 tz #f)])
|
||||
(unless ($mktime dtvec) ; for effect on dtvec
|
||||
($oops who "invalid combination of arguments"))
|
||||
(unless (fx= (vector-ref dtvec (constant dtvec-mday)) day)
|
||||
($oops who "invalid day ~s for month ~s and year ~s" day mon year))
|
||||
(make-dt dtvec)))])
|
||||
(case-lambda
|
||||
[(nsec sec min hour day mon year tz)
|
||||
(do-make-date nsec sec min hour day mon year tz #t)]
|
||||
[(nsec sec min hour day mon year)
|
||||
(do-make-date nsec sec min hour day mon year #f #f)])))
|
||||
|
||||
(set! date? (lambda (x) (dt? x)))
|
||||
|
||||
(let ()
|
||||
(define-syntax date-getter
|
||||
(syntax-rules ()
|
||||
[(_ name index)
|
||||
(set! name
|
||||
(lambda (dt)
|
||||
(check-dt 'name dt)
|
||||
(vector-ref (dt-vec dt) index)))]))
|
||||
|
||||
(date-getter date-nanosecond (constant dtvec-nsec))
|
||||
(date-getter date-second (constant dtvec-sec))
|
||||
(date-getter date-minute (constant dtvec-min))
|
||||
(date-getter date-hour (constant dtvec-hour))
|
||||
(date-getter date-day (constant dtvec-mday))
|
||||
(date-getter date-month (constant dtvec-mon))
|
||||
; date-year is below
|
||||
(date-getter date-week-day (constant dtvec-wday))
|
||||
(date-getter date-year-day (constant dtvec-yday))
|
||||
(date-getter date-dst? (constant dtvec-isdst))
|
||||
(date-getter date-zone-offset (constant dtvec-tzoff))
|
||||
(date-getter date-zone-name (constant dtvec-tzname)))
|
||||
|
||||
(set-who! date-year
|
||||
(lambda (dt)
|
||||
(check-dt who dt)
|
||||
(+ (vector-ref (dt-vec dt) (constant dtvec-year)) 1900)))
|
||||
|
||||
#;(set-who! date-week-number
|
||||
(lambda (dt dowsw)
|
||||
(unless (or (eq? dossw 0) (eq? dossw 1))
|
||||
($oops who "invalid week starting day" dossw))
|
||||
???))
|
||||
|
||||
(set-who! time-utc->date
|
||||
(case-lambda
|
||||
[(t)
|
||||
(unless (and (ts? t) (eq? (ts-typeno t) (constant time-utc)))
|
||||
($oops who "~s is not a utc time record" t))
|
||||
(let ([dtvec ($gmtime #f (ts-pair t))])
|
||||
(unless dtvec ($oops who "failed"))
|
||||
(make-dt dtvec))]
|
||||
[(t tz)
|
||||
(unless (and (ts? t) (eq? (ts-typeno t) (constant time-utc)))
|
||||
($oops who "~s is not a utc time record" t))
|
||||
(check-tz who tz)
|
||||
(let ([dtvec ($gmtime tz (ts-pair t))])
|
||||
(unless dtvec ($oops who "failed"))
|
||||
(make-dt dtvec))]))
|
||||
|
||||
(set-who! date->time-utc
|
||||
(lambda (dt)
|
||||
(check-dt who dt)
|
||||
(let ([p ($mktime (vector-copy (dt-vec dt)))])
|
||||
(unless p ($oops who "conversion failed for ~s" dt))
|
||||
(make-ts (constant time-utc) p))))
|
||||
)
|
||||
271
s/debug.ss
Normal file
271
s/debug.ss
Normal file
|
|
@ -0,0 +1,271 @@
|
|||
;;; debug.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(current-eval interpret)
|
||||
|
||||
(subset-mode 'system)
|
||||
|
||||
(generate-inspector-information #f)
|
||||
|
||||
(eval-syntax-expanders-when '(load eval))
|
||||
|
||||
(disable-unbound-warning compile-with-asm compile-with-setup-closure-counts compile-with-closure-counts)
|
||||
|
||||
(require-nongenerative-clause #t)
|
||||
|
||||
(define compile-with-asm
|
||||
(lambda (ss so mach)
|
||||
(let ([file (format "~a.asm" (path-root so))])
|
||||
(parameterize ([#%$assembly-output (open-output-file file '(buffered replace))])
|
||||
(compile-file ss so mach)
|
||||
(close-output-port (#%$assembly-output))))))
|
||||
|
||||
#;(define compile-with-closure-counts
|
||||
(lambda (ss* so* mach)
|
||||
(time (for-each (lambda (x y)
|
||||
(collect 2)
|
||||
(compile-file (symbol->string x) (symbol->string y) mach))
|
||||
ss* so*))))
|
||||
|
||||
#;(module (compile-with-setup-closure-counts compile-with-closure-counts)
|
||||
(module (csv-cell csv-row csv-row* csv-rowv)
|
||||
(define ->string
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(string? x) x]
|
||||
[(symbol? x) (symbol->string x)]
|
||||
[(char? x) (list->string (list x))]
|
||||
[(number? x) (number->string x)]
|
||||
[(identifier? x) (symbol->string (syntax->datum x))]
|
||||
[else (format "~s" x)])))
|
||||
|
||||
(define needs-double-quote?
|
||||
(lambda (str)
|
||||
(let ([len (string-length str)])
|
||||
(let f ([i 0])
|
||||
(and (< i len)
|
||||
(let ([c (string-ref str i)])
|
||||
(or (char=? c #\,) (char=? c #\") (f (fx+ i 1)))))))))
|
||||
|
||||
(define double-double-quote
|
||||
(lambda (str)
|
||||
(let ([len (string-length str)])
|
||||
(let f ([i 0] [new-len 0])
|
||||
(if (fx= i len)
|
||||
(make-string new-len)
|
||||
(let ([c (string-ref str i)])
|
||||
(if (char=? c #\")
|
||||
(let ([new-str (f (fx+ i 1) (fx+ new-len 2))])
|
||||
(string-set! new-str new-len #\")
|
||||
(string-set! new-str (fx+ new-len 1) #\")
|
||||
new-str)
|
||||
(let ([new-str (f (fx+ i 1) (fx+ new-len 1))])
|
||||
(string-set! new-str new-len c)
|
||||
new-str))))))))
|
||||
|
||||
(define csv-cell
|
||||
(lambda (op x)
|
||||
(let ([str (->string x)])
|
||||
(if (needs-double-quote? str)
|
||||
(fprintf op "\"~a\"" (double-double-quote str))
|
||||
(display str op)))))
|
||||
|
||||
(define csv-row
|
||||
(lambda (op xs)
|
||||
(let f ([xs xs])
|
||||
(if (null? xs)
|
||||
(begin (newline op) (newline))
|
||||
(let ([x (car xs)] [xs (cdr xs)])
|
||||
(csv-cell (current-output-port) x)
|
||||
(csv-cell op x)
|
||||
(unless (null? xs) (display ","))
|
||||
(unless (null? xs) (display "," op))
|
||||
(f xs))))))
|
||||
|
||||
(define csv-rowv
|
||||
(lambda (op . xs)
|
||||
(let f ([xs xs])
|
||||
(if (null? xs)
|
||||
(newline op)
|
||||
(let ([x (car xs)] [xs (cdr xs)])
|
||||
(cond
|
||||
[(vector? x)
|
||||
(let ([len (vector-length x)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((= i len))
|
||||
(csv-cell op (vector-ref x i))
|
||||
(unless (= (fx+ i 1) len) (display "," op)))
|
||||
(newline op))]
|
||||
[else
|
||||
(csv-cell op x)
|
||||
(unless (null? xs) (display "," op))
|
||||
(f xs)]))))))
|
||||
|
||||
(define csv-row*
|
||||
(lambda (op . xs)
|
||||
(csv-row op xs))))
|
||||
|
||||
(define compile-with-setup-closure-counts
|
||||
(lambda (opts ss* so* mach with-header?)
|
||||
(include "types.ss")
|
||||
(assert (or (eq? opts 'all) (equal? opts '(all))))
|
||||
(let ([ci (make-static-closure-info)])
|
||||
(time (for-each (lambda (x y)
|
||||
(collect 2)
|
||||
(parameterize ([#%$track-static-closure-counts ci]
|
||||
[#%$track-dynamic-closure-counts #t])
|
||||
(compile-file (symbol->string x) (symbol->string y) mach)))
|
||||
ss* so*))
|
||||
(let ([v (#%$dynamic-closure-counts)])
|
||||
(call-with-output-file "static-compiler.csv"
|
||||
(lambda (op)
|
||||
(let* ([final-cl-count (+ (static-closure-info-wk-pair-count ci)
|
||||
(static-closure-info-wk-vector-count ci)
|
||||
(static-closure-info-nwk-closure-count ci))]
|
||||
[final-fv-count (+ (* (static-closure-info-wk-pair-count ci) 2)
|
||||
(static-closure-info-wk-vector-free-var-count ci)
|
||||
(static-closure-info-nwk-closure-free-var-count ci))]
|
||||
[orig-var/closure (if (zero? (static-closure-info-raw-closure-count ci))
|
||||
(quote n/a)
|
||||
(inexact (/ (static-closure-info-raw-free-var-count ci)
|
||||
(static-closure-info-raw-closure-count ci))))]
|
||||
[final-var/closure (if (zero? final-cl-count)
|
||||
(quote n/a)
|
||||
(inexact (/ final-fv-count final-cl-count)))]
|
||||
[wk-var/vector (if (zero? (static-closure-info-wk-vector-count ci))
|
||||
(quote n/a)
|
||||
(inexact (/ (static-closure-info-wk-vector-free-var-count ci)
|
||||
(static-closure-info-wk-vector-count ci))))]
|
||||
[nwk-var/closure (if (zero? (static-closure-info-nwk-closure-count ci))
|
||||
(quote n/a)
|
||||
(inexact (/ (static-closure-info-nwk-closure-free-var-count ci)
|
||||
(static-closure-info-nwk-closure-count ci))))])
|
||||
(when with-header?
|
||||
(csv-row* op "Opts" "Orig. Closure Count" "Orig. Total Free Vars" "Orig. Avg. Free Var/Closure"
|
||||
"Final Closure Count" "Final Total Free Vars" "Final Avg. Free Var/Closure"
|
||||
"WK Borrowed" "WK Empty" "WK Single" "WK Pair" "WK Vector" "WK Vector Total Vars" "WK Vector Vars/Vector"
|
||||
"NWK Empty" "NWK Closure" "NWK Closure Total Vars" "NWK Closure Vars/Closure"
|
||||
"% Closures Eliminated" "% Size Reduction"))
|
||||
#|
|
||||
(printf "compiler closure elimination\n")
|
||||
(printf " original closures: ~d\n" (static-closure-info-raw-closure-count ci))
|
||||
(printf " original free var total: ~d\n" (static-closure-info-raw-free-var-count ci))
|
||||
(printf " fv/closure: ~s\n" orig-var/closure)
|
||||
(printf " final closure count: ~d\n" final-cl-count)
|
||||
(printf " final free var total: ~d\n" final-fv-count)
|
||||
(printf " fv/closure: ~s\n" final-var/closure)
|
||||
(printf " wk empty: ~d\n" (static-closure-info-wk-empty-count ci))
|
||||
(printf " wk borrowed: ~d\n" (static-closure-info-wk-borrowed-count ci))
|
||||
(printf " wk single: ~d\n" (static-closure-info-wk-single-count ci))
|
||||
(printf " wk pair: ~d\n" (static-closure-info-wk-pair-count ci))
|
||||
(printf " wk vector: ~d\n" (static-closure-info-wk-vector-count ci))
|
||||
(printf " wk vector free var: ~d\n" (static-closure-info-wk-vector-free-var-count ci))
|
||||
(printf " fv/vector: ~s\n" wk-var/vector)
|
||||
(printf " nwk empty: ~s\n" (static-closure-info-nwk-empty-count ci))
|
||||
(printf " nwk closure: ~s\n" (static-closure-info-nwk-closure-count ci))
|
||||
(printf " nwk closure free var: ~s\n" (static-closure-info-nwk-closure-free-var-count ci))
|
||||
(printf " fv/closure: ~s\n" nwk-var/closure)
|
||||
(printf " % closures eliminated: ~s\n"
|
||||
(inexact (/ (* (- (static-closure-info-raw-closure-count ci) final-cl-count) 100)
|
||||
(static-closure-info-raw-closure-count ci))))
|
||||
(printf " % free-vars eliminated: ~s\n"
|
||||
(inexact (/ (* (- (static-closure-info-raw-free-var-count ci) final-fv-count) 100)
|
||||
(static-closure-info-raw-free-var-count ci))))
|
||||
|#
|
||||
(printf "printing static row!!!\n")
|
||||
(csv-row* op opts (static-closure-info-raw-closure-count ci)
|
||||
(static-closure-info-raw-free-var-count ci) orig-var/closure
|
||||
final-cl-count final-fv-count final-var/closure
|
||||
(static-closure-info-wk-borrowed-count ci)
|
||||
(static-closure-info-wk-empty-count ci)
|
||||
(static-closure-info-wk-single-count ci)
|
||||
(static-closure-info-wk-pair-count ci)
|
||||
(static-closure-info-wk-vector-count ci)
|
||||
(static-closure-info-wk-vector-free-var-count ci)
|
||||
wk-var/vector
|
||||
(static-closure-info-nwk-empty-count ci)
|
||||
(static-closure-info-nwk-closure-count ci)
|
||||
(static-closure-info-nwk-closure-free-var-count ci)
|
||||
nwk-var/closure
|
||||
(inexact (/ (* (- (static-closure-info-raw-closure-count ci) final-cl-count) 100)
|
||||
(static-closure-info-raw-closure-count ci)))
|
||||
(inexact (/ (* (- (static-closure-info-raw-free-var-count ci) final-fv-count) 100)
|
||||
(static-closure-info-raw-free-var-count ci))))))
|
||||
(if with-header? 'replace 'append))))))
|
||||
|
||||
(define compile-with-closure-counts
|
||||
(lambda (opts ss* so* mach with-header?)
|
||||
(assert (or (eq? opts 'all) (equal? opts '(all))))
|
||||
(#%$clear-dynamic-closure-counts)
|
||||
(time (for-each (lambda (x y)
|
||||
(collect 2)
|
||||
(parameterize ([#%$track-dynamic-closure-counts #t]) ; true, but could be false
|
||||
(compile-file (symbol->string x) (symbol->string y) mach)))
|
||||
ss* so*))
|
||||
(let ([v (#%$dynamic-closure-counts)])
|
||||
(call-with-output-file "dynamic-compiler.csv"
|
||||
(lambda (op)
|
||||
|
||||
(when with-header?
|
||||
(csv-row* op "Name"
|
||||
"Raw ref count" "Ref count" "% Ref Elim"
|
||||
"Raw create count" "Pair create count" "Vector create count" "Closure create count"
|
||||
"Total create count" "% Create Elim"
|
||||
"Raw alloc" "Vector alloc" "Closure alloc" "Total alloc" "% Alloc Elim"
|
||||
"Padded closure alloc count" "Padded vector alloc count"))
|
||||
(let* ([%ref-elim (if (zero? (vector-ref v 0))
|
||||
'n/a
|
||||
(* (/ (- (vector-ref v 0) (vector-ref v 3))
|
||||
(vector-ref v 0))
|
||||
100.0))]
|
||||
[total-create (+ (vector-ref v 4) (vector-ref v 5) (vector-ref v 8))]
|
||||
[%create-elim (if (zero? (vector-ref v 1))
|
||||
'n/a
|
||||
(* (/ (- (vector-ref v 1) total-create) (vector-ref v 1))
|
||||
100.0))]
|
||||
[total-alloc (+ (* 2 (vector-ref v 4)) (vector-ref v 6) (vector-ref v 9))]
|
||||
[%alloc-elim (if (zero? (vector-ref v 2))
|
||||
'n/a
|
||||
(* (/ (- (vector-ref v 2) total-alloc)
|
||||
(vector-ref v 2))
|
||||
100.0))])
|
||||
#|
|
||||
(printf "compiler dynamic closure counts:\n")
|
||||
(printf " original references: ~d\n" (vector-ref v 0))
|
||||
(printf " original closure creations: ~d\n" (vector-ref v 1))
|
||||
(printf " original closure allocation: ~d\n" (vector-ref v 2))
|
||||
(printf " final references: ~d\n" (vector-ref v 3))
|
||||
(printf " % eliminated: ~s\n" %ref-elim)
|
||||
(printf " pairs created: ~d\n" (vector-ref v 4))
|
||||
(printf " vectors created: ~d\n" (vector-ref v 5))
|
||||
(printf " closures created: ~d\n" (vector-ref v 8))
|
||||
(printf " total creation: ~d\n" total-create)
|
||||
(printf " % eliminated: ~s\n" %create-elim)
|
||||
(printf " vector allocation: ~d\n" (vector-ref v 6))
|
||||
(printf " closure allocation: ~d\n" (vector-ref v 9))
|
||||
(printf " total allocation: ~d\n" total-alloc)
|
||||
(printf " % eliminated: ~s\n" %alloc-elim)
|
||||
(printf " padded vector allocation: ~d\n" (vector-ref v 7))
|
||||
(printf " padded closure allocation: ~d\n" (vector-ref v 10))
|
||||
|#
|
||||
(printf "printing dynamic row!!!\n")
|
||||
(csv-row* op opts
|
||||
(vector-ref v 0) (vector-ref v 3) %ref-elim
|
||||
(vector-ref v 1) (vector-ref v 4) (vector-ref v 5) (vector-ref v 8)
|
||||
total-create %create-elim
|
||||
(vector-ref v 2) (vector-ref v 6) (vector-ref v 9) total-alloc %alloc-elim
|
||||
(vector-ref v 7) (vector-ref v 10))))
|
||||
(if with-header? 'replace 'append))))))
|
||||
|
||||
134
s/engine.ss
Normal file
134
s/engine.ss
Normal file
|
|
@ -0,0 +1,134 @@
|
|||
;;; engine.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; Notes:
|
||||
;;; The engine code defines three functions: make-engine,
|
||||
;;; engine-block, and engine-return.
|
||||
|
||||
;;; Keyboard interrupts are caught while an engine is running
|
||||
;;; and the engine disabled while the handler is running.
|
||||
|
||||
;;; All of the engine code is defined within local state
|
||||
;;; containing the following variables:
|
||||
;;; *active* true iff an engine is running
|
||||
;;; *exit* the continuation to the engine invoker
|
||||
;;; *keybd* the saved keyboard interrupt handler
|
||||
;;; *timer* the saved timer interrupt handler
|
||||
|
||||
|
||||
(let ()
|
||||
|
||||
(define-threaded *exit*)
|
||||
(define-threaded *keybd*)
|
||||
(define-threaded *timer*)
|
||||
(define-threaded *active* #f)
|
||||
|
||||
(define cleanup
|
||||
(lambda (who)
|
||||
(unless *active* ($oops who "no engine active"))
|
||||
(set! *active* #f)
|
||||
(keyboard-interrupt-handler *keybd*)
|
||||
(timer-interrupt-handler *timer*)
|
||||
(set! *keybd* (void))
|
||||
(set! *exit* (void))
|
||||
(set! *timer* (void))))
|
||||
|
||||
(define setup
|
||||
(lambda (exit)
|
||||
(set! *active* #t)
|
||||
(set! *keybd* (keyboard-interrupt-handler))
|
||||
(keyboard-interrupt-handler (exception *keybd*))
|
||||
(set! *timer* (timer-interrupt-handler))
|
||||
(timer-interrupt-handler block)
|
||||
(set! *exit* exit)))
|
||||
|
||||
(define block
|
||||
; disable engine and return the continuation
|
||||
(lambda ()
|
||||
(let ([exit *exit*])
|
||||
(cleanup 'engine-block)
|
||||
(set-timer (call/cc (lambda (k) (exit (lambda () k))))))))
|
||||
|
||||
(define return
|
||||
; disable engine and return list (ticks value ...)
|
||||
(lambda (args)
|
||||
(let ([n (set-timer 0)])
|
||||
(let ([exit *exit*])
|
||||
(cleanup 'engine-return)
|
||||
(exit (lambda () (cons n args)))))))
|
||||
|
||||
(define exception
|
||||
; disable engine while calling the handler
|
||||
(lambda (handler)
|
||||
(lambda args
|
||||
(let ([ticks (set-timer 0)])
|
||||
(let ([exit *exit*])
|
||||
(cleanup 'engine-exception)
|
||||
(apply handler args)
|
||||
(setup exit)
|
||||
(if (= ticks 0) (block) (set-timer ticks)))))))
|
||||
|
||||
(define run-engine
|
||||
; run a continuation as an engine
|
||||
(lambda (k ticks)
|
||||
((call/cc
|
||||
(lambda (exit)
|
||||
(set-timer 0)
|
||||
(when *active* ($oops 'engine "cannot nest engines"))
|
||||
(setup exit)
|
||||
(k ticks))))))
|
||||
|
||||
(define eng
|
||||
; create an engine from a procedure or continuation
|
||||
(lambda (k)
|
||||
(lambda (ticks complete expire)
|
||||
(unless (and (fixnum? ticks) (not (negative? ticks)))
|
||||
($oops 'engine "invalid ticks ~s" ticks))
|
||||
(unless (procedure? complete)
|
||||
($oops 'engine "~s is not a procedure" complete))
|
||||
(unless (procedure? expire)
|
||||
($oops 'engine "~s is not a procedure" expire))
|
||||
(if (= ticks 0)
|
||||
(expire (eng k))
|
||||
(let ([x (run-engine k ticks)])
|
||||
(if (procedure? x)
|
||||
(expire (eng x))
|
||||
(apply complete x)))))))
|
||||
|
||||
(set! engine-return (lambda args (return args)))
|
||||
|
||||
(set! engine-block (lambda () (set-timer 0) (block)))
|
||||
|
||||
(set! make-engine
|
||||
(lambda (x)
|
||||
(unless (procedure? x) ($oops 'make-engine "~s is not a procedure" x))
|
||||
(eng (lambda (ticks)
|
||||
(with-exception-handler
|
||||
(lambda (c)
|
||||
(let ([ticks (set-timer 0)])
|
||||
(let ([exit *exit*])
|
||||
(cleanup 'raise)
|
||||
(call/cc
|
||||
(lambda (k)
|
||||
(exit
|
||||
(lambda ()
|
||||
(let-values ([vals (raise-continuable c)])
|
||||
(setup exit)
|
||||
(if (= ticks 0) (block) (set-timer ticks))
|
||||
(apply k vals)))))))))
|
||||
(lambda ()
|
||||
(set-timer ticks)
|
||||
(call-with-values x (lambda args (return args)))))))))
|
||||
)
|
||||
298
s/enum.ss
Normal file
298
s/enum.ss
Normal file
|
|
@ -0,0 +1,298 @@
|
|||
;;; enum.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;; NOTES:
|
||||
;; This implementation assume the universe is small
|
||||
;; and the algorithms used by this implementation may be
|
||||
;; up to linear in the universe
|
||||
;;
|
||||
;; This code is a good candidate for partial-static-structure optimization
|
||||
;; Right now the define-enumeration macro is doing optimizations
|
||||
;; that could be automatically performed by PSS if PSS worked on enums
|
||||
;;
|
||||
;; The R6RS standard is unclear whether the function returned by enum-set-indexer
|
||||
;; should throw an error if its argument is not a symbol. We have chosen to
|
||||
;; not include that check, but if the standard is updated, this may need to be changed.
|
||||
|
||||
(let ()
|
||||
|
||||
;;;;;;;;
|
||||
#| Low-level enum-set definition and operations
|
||||
The structure is as follows:
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
The following records are created once:
|
||||
|
||||
enum-base-rtd:
|
||||
+-----------------+--------------------+--------------------------------+-----+
|
||||
| rtd:#!base-rtd | parent:#!base-rtd | fields:(index->sym sym->index) | ... |
|
||||
+-----------------+--------------------+--------------------------------+-----+
|
||||
|
||||
enum-parent-rtd:
|
||||
+-----------------+--------------------+--------------------------------+-----+
|
||||
| rtd:#!base-rtd | parent: #f | fields:(members) | ... |
|
||||
+-----------------+--------------------+--------------------------------+-----+
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
The following record is created per enum-type and it stored the mappings
|
||||
between symbols and their corresponding bits in the bit mask:
|
||||
|
||||
this-enum-rtd:
|
||||
+-------------------+------------------------+-----------+-----
|
||||
| rtd:enum-base-rtd | parent:enum-parent-rtd | fields:() | ...
|
||||
+-------------------+------------------------+-----------+-----
|
||||
----+------------+------------+
|
||||
...| index->sym | sym->index |
|
||||
----+------------+------------+
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
The following record is created per enum-set:
|
||||
|
||||
an-enum-set:
|
||||
+-------------------+--------------------------------+
|
||||
| rtd:this-enum-rtd | members: 17 (integer bit mask) |
|
||||
+-------------------+--------------------------------+
|
||||
|
||||
|#
|
||||
|
||||
(define enum-base-rtd
|
||||
(make-record-type ; not sealed, not opaque
|
||||
#!base-rtd ; undocumented #!base-rtd
|
||||
'#{enum b9s78zmm79qs7j22-a} ; make enum-base-rtd type nongenerative
|
||||
'((immutable sym->index) ; static (per enumeration type) fields
|
||||
(immutable index->sym))))
|
||||
(define enum-parent-rtd ; not sealed, not opaque, nongenerative
|
||||
(make-record-type
|
||||
'#{enum-parent dwwi4y1kribh7mif58yoxe-0}
|
||||
'((immutable members))))
|
||||
|
||||
(define get-sym->index (csv7:record-field-accessor enum-base-rtd 'sym->index))
|
||||
(define get-index->sym (csv7:record-field-accessor enum-base-rtd 'index->sym))
|
||||
(define get-members (csv7:record-field-accessor enum-parent-rtd 'members))
|
||||
(define members-universe -1) ;; All bits set
|
||||
|
||||
;;;;;;;;
|
||||
|
||||
;; Make a new enum-set using the rtd and the new set of members
|
||||
(define (make-enum-set enum-set-rtd members)
|
||||
#;((record-constructor enum-set-rtd) members)
|
||||
; breaking the abstraction to avoid significant efficiency hit
|
||||
($record enum-set-rtd members))
|
||||
|
||||
;; Perform type check for enum-set and return its RTD
|
||||
(define (enum-set-rtd who enum-set)
|
||||
(or (and (record? enum-set)
|
||||
(let ([rtd (record-rtd enum-set)])
|
||||
(and (eq? (record-rtd rtd) enum-base-rtd)
|
||||
rtd)))
|
||||
($oops who "~s is not an enumeration" enum-set)))
|
||||
|
||||
(define (assert-symbol-list who symbol-list)
|
||||
(unless (and (list? symbol-list)
|
||||
(for-all symbol? symbol-list))
|
||||
($oops who "~s is not a list of symbols" symbol-list)))
|
||||
(define (assert-symbol who symbol)
|
||||
(unless (symbol? symbol)
|
||||
($oops who "~s is not a symbol" symbol)))
|
||||
|
||||
(define rtd&list->enum-set
|
||||
(lambda (who rtd symbol-list)
|
||||
(let ([sym->index (get-sym->index rtd)])
|
||||
(let loop ([members 0]
|
||||
[symbol-list symbol-list])
|
||||
(if (null? symbol-list)
|
||||
(make-enum-set rtd members)
|
||||
(let ([index (symbol-hashtable-ref sym->index (car symbol-list) #f)])
|
||||
(if (not index)
|
||||
(if who
|
||||
($oops who "universe does not include specified symbol ~s"
|
||||
(car symbol-list))
|
||||
(loop members (cdr symbol-list)))
|
||||
(loop (logbit1 index members) (cdr symbol-list)))))))))
|
||||
|
||||
(define $enum-set->list
|
||||
(lambda (who enum-set)
|
||||
(let ([rtd (enum-set-rtd who enum-set)])
|
||||
(let ([index->sym (get-index->sym rtd)]
|
||||
[members (get-members enum-set)])
|
||||
(let loop ([i (fx1- (vector-length index->sym))]
|
||||
[lst '()])
|
||||
(if (fx< i 0)
|
||||
lst
|
||||
(loop (fx1- i)
|
||||
(if (logbit? i members)
|
||||
(cons (vector-ref index->sym i) lst)
|
||||
lst))))))))
|
||||
|
||||
(record-writer enum-parent-rtd (lambda (x p wr) (display "#<enum-set>" p)))
|
||||
|
||||
;;;;;;;;
|
||||
;; Constructor
|
||||
|
||||
(let ()
|
||||
;; Takes lst and assigns indexes to each element of lst
|
||||
;; lst :: symbol-list
|
||||
;; index :: fixnum
|
||||
;; symbol->index :: hashtable from symbols to fixnum
|
||||
;; rev-lst :: symbol-list (stored in reverse order)
|
||||
;;
|
||||
;; Result :: (values fixnum (vector of symbols))
|
||||
(define (make-symbol->index lst index symbol->index rev-lst)
|
||||
(cond
|
||||
[(null? lst)
|
||||
(let ([index->symbol (make-vector index)])
|
||||
(let loop ([i (fx1- index)]
|
||||
[rev-lst rev-lst])
|
||||
(unless (null? rev-lst) ;; or (< i 0)
|
||||
(vector-set! index->symbol i (car rev-lst))
|
||||
(loop (fx1- i) (cdr rev-lst))))
|
||||
(values index index->symbol))]
|
||||
[(symbol-hashtable-contains? symbol->index (car lst))
|
||||
(make-symbol->index (cdr lst) index symbol->index rev-lst)]
|
||||
[else
|
||||
(symbol-hashtable-set! symbol->index (car lst) index)
|
||||
(make-symbol->index (cdr lst) (fx1+ index) symbol->index (cons (car lst) rev-lst))]))
|
||||
|
||||
(set! make-enumeration
|
||||
(lambda (symbol-list)
|
||||
(assert-symbol-list 'make-enumeration symbol-list)
|
||||
(let ([sym->index (make-hashtable symbol-hash eq?)])
|
||||
(let-values ([(index index->sym) (make-symbol->index symbol-list 0 sym->index '())])
|
||||
(let ([this-enum-rtd
|
||||
($make-record-type
|
||||
enum-base-rtd enum-parent-rtd "enum-type"
|
||||
'() ; no fields to add
|
||||
#t ; sealed
|
||||
#f ; not opaque
|
||||
sym->index
|
||||
index->sym)])
|
||||
(make-enum-set this-enum-rtd members-universe)))))))
|
||||
|
||||
;;;;;;;;;
|
||||
;; Misc functions
|
||||
|
||||
(set! $enum-set-members get-members)
|
||||
|
||||
(set! enum-set-universe
|
||||
(lambda (enum-set)
|
||||
(make-enum-set (enum-set-rtd 'enum-set-universe enum-set) -1)))
|
||||
(set! enum-set-indexer
|
||||
(lambda (enum-set)
|
||||
(let ([sym->index (get-sym->index (enum-set-rtd 'enum-set-indexer enum-set))])
|
||||
(lambda (x)
|
||||
(assert-symbol 'enum-set-indexer x)
|
||||
(symbol-hashtable-ref sym->index x #f)))))
|
||||
|
||||
(set! enum-set-constructor
|
||||
(lambda (enum-set)
|
||||
(let ([rtd (enum-set-rtd 'enum-set-constructor enum-set)])
|
||||
(lambda (symbol-list)
|
||||
(assert-symbol-list 'enum-set-constructor symbol-list)
|
||||
(rtd&list->enum-set 'enum-set-constructor rtd symbol-list)))))
|
||||
|
||||
(set! enum-set->list
|
||||
(lambda (enum-set)
|
||||
($enum-set->list 'enum-set->list enum-set)))
|
||||
|
||||
;;;;;;;;;
|
||||
;; Predicates
|
||||
|
||||
(set! enum-set?
|
||||
(lambda (enum-set)
|
||||
(and (record? enum-set)
|
||||
(let ([rtd (record-rtd enum-set)])
|
||||
(eq? (record-rtd rtd) enum-base-rtd)))))
|
||||
|
||||
(let ()
|
||||
(define (enum-set-subset-aux? enum-set1 enum-set2 rtd1 rtd2)
|
||||
(let ([index->sym1 (get-index->sym rtd1)]
|
||||
[members1 (get-members enum-set1)]
|
||||
[sym->index2 (get-sym->index rtd2)]
|
||||
[members2 (get-members enum-set2)])
|
||||
(let loop ([index1 0])
|
||||
(or (fx= index1 (vector-length index->sym1))
|
||||
(let ([index2 (symbol-hashtable-ref
|
||||
sym->index2
|
||||
(vector-ref index->sym1 index1) #f)])
|
||||
(and index2
|
||||
(or (not (logbit? index1 members1))
|
||||
(logbit? index2 members2))
|
||||
(loop (fx1+ index1))))))))
|
||||
|
||||
(set! enum-set-member?
|
||||
(lambda (symbol enum-set)
|
||||
(assert-symbol 'enum-set-member? symbol)
|
||||
(let ([sym->index (get-sym->index
|
||||
(enum-set-rtd 'enum-set-member? enum-set))])
|
||||
(let ([index (symbol-hashtable-ref sym->index symbol #f)])
|
||||
(and index
|
||||
(logbit? index (get-members enum-set)))))))
|
||||
|
||||
(set! enum-set-subset?
|
||||
(lambda (enum-set1 enum-set2)
|
||||
(let ([rtd1 (enum-set-rtd 'enum-set-subset? enum-set1)]
|
||||
[rtd2 (enum-set-rtd 'enum-set-subset? enum-set2)])
|
||||
(if (eq? rtd1 rtd2)
|
||||
(let ([members2 (get-members enum-set2)])
|
||||
(= members2 (logor (get-members enum-set1) members2)))
|
||||
(enum-set-subset-aux? enum-set1 enum-set2 rtd1 rtd2)))))
|
||||
|
||||
(set! enum-set=?
|
||||
(lambda (enum-set1 enum-set2)
|
||||
(let ([rtd1 (enum-set-rtd 'enum-set=? enum-set1)]
|
||||
[rtd2 (enum-set-rtd 'enum-set=? enum-set2)])
|
||||
(if (eq? rtd1 rtd2)
|
||||
(= (get-members enum-set1) (get-members enum-set2))
|
||||
(and (enum-set-subset-aux? enum-set1 enum-set2 rtd1 rtd2)
|
||||
(enum-set-subset-aux? enum-set2 enum-set1 rtd2 rtd1))))))
|
||||
)
|
||||
|
||||
;;;;;;;;
|
||||
;; Set-like functions
|
||||
|
||||
(let ()
|
||||
(define-syntax enum-bin-op
|
||||
(syntax-rules ()
|
||||
[(_ name (members1 members2) members-expr)
|
||||
(set! name
|
||||
(lambda (enum-set1 enum-set2)
|
||||
(let ([rtd1 (enum-set-rtd 'name enum-set1)]
|
||||
[rtd2 (enum-set-rtd 'name enum-set2)])
|
||||
(unless (eq? rtd1 rtd2)
|
||||
($oops 'name "~s and ~s have different enumeration types"
|
||||
enum-set1 enum-set2))
|
||||
(make-enum-set rtd1 (let ([members1 (get-members enum-set1)]
|
||||
[members2 (get-members enum-set2)])
|
||||
members-expr)))))]))
|
||||
|
||||
(enum-bin-op enum-set-union (members1 members2) (logor members1 members2))
|
||||
(enum-bin-op enum-set-intersection (members1 members2) (logand members1 members2))
|
||||
(enum-bin-op enum-set-difference (members1 members2) (logand members1 (lognot members2)))
|
||||
)
|
||||
|
||||
;;;;;;;;
|
||||
;; Other functions
|
||||
|
||||
(set! enum-set-complement
|
||||
(lambda (enum-set)
|
||||
(let ([rtd (enum-set-rtd 'enum-set-complement enum-set)])
|
||||
(make-enum-set rtd (lognot (get-members enum-set))))))
|
||||
|
||||
(set! enum-set-projection
|
||||
(lambda (enum-set1 enum-set2)
|
||||
(rtd&list->enum-set #f
|
||||
(enum-set-rtd 'enum-set-projection enum-set2)
|
||||
($enum-set->list 'enum-set-projection enum-set1))))
|
||||
)
|
||||
19
s/env.ss
Normal file
19
s/env.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
;;; env.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
($make-base-modules)
|
||||
($make-rnrs-libraries)
|
||||
)
|
||||
68
s/event.ss
Normal file
68
s/event.ss
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
;;; event.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(let ()
|
||||
(define stop-event-timer
|
||||
(lambda ()
|
||||
($set-timer (most-positive-fixnum))))
|
||||
|
||||
(define start-event-timer
|
||||
(lambda ()
|
||||
; set timer by way of $event, so recurrent calls to "set-timer" or
|
||||
; "{dis,en}able-interrupts" can't prevent interrupts
|
||||
($event)))
|
||||
|
||||
(set! set-timer
|
||||
(lambda (ticks)
|
||||
(unless (and (fixnum? ticks) (fx>= ticks 0))
|
||||
($oops 'set-timer "~s is not a nonnegative fixnum" ticks))
|
||||
(let ([ticks-left (stop-event-timer)])
|
||||
(let ([t ($tc-field 'timer-ticks ($tc))])
|
||||
(if (fx> ticks 0)
|
||||
(begin
|
||||
($tc-field 'something-pending ($tc) #t)
|
||||
($tc-field 'timer-ticks ($tc) ticks))
|
||||
($tc-field 'timer-ticks ($tc) #f))
|
||||
(if (fx= ($tc-field 'disable-count ($tc)) 0)
|
||||
(let ([old (if t (fx+ t ticks-left) 0)])
|
||||
(start-event-timer)
|
||||
old)
|
||||
(or t 0))))))
|
||||
|
||||
(set! disable-interrupts
|
||||
(lambda ()
|
||||
(let ([ticks (stop-event-timer)])
|
||||
(let ([disable-count ($tc-field 'disable-count ($tc))])
|
||||
(when (and (fx= disable-count 0) ($tc-field 'timer-ticks ($tc)))
|
||||
($tc-field 'timer-ticks ($tc) (fx+ ($tc-field 'timer-ticks ($tc)) ticks)))
|
||||
(when (fx= disable-count (most-positive-fixnum))
|
||||
($oops 'disable-interrupts
|
||||
"too many consecutive calls to disable-interrupts"))
|
||||
(let ([disable-count (fx+ disable-count 1)])
|
||||
($tc-field 'disable-count ($tc) disable-count)
|
||||
disable-count)))))
|
||||
|
||||
(set! enable-interrupts
|
||||
(lambda ()
|
||||
(let ([ticks (stop-event-timer)])
|
||||
(let ([disable-count (fx- ($tc-field 'disable-count ($tc)) 1)])
|
||||
(case disable-count
|
||||
[(-1) ($set-timer ticks) 0]
|
||||
[(0) ($tc-field 'disable-count ($tc) 0)
|
||||
(start-event-timer)
|
||||
0]
|
||||
[else ($tc-field 'disable-count ($tc) disable-count)
|
||||
disable-count])))))
|
||||
)
|
||||
737
s/exceptions.ss
Normal file
737
s/exceptions.ss
Normal file
|
|
@ -0,0 +1,737 @@
|
|||
;;; exceptions.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
#|
|
||||
TODO:
|
||||
- teach default handler to:
|
||||
- squirrel away continuation for debug as &continuation simple condition
|
||||
- say something about calling debug (if &continuation is included)
|
||||
- teach reset to handle closing of ports, etc., in system error chain
|
||||
- wire into existing error-handling mechanisms, or visa versa
|
||||
- replace error calls as appropriate with violation calls,
|
||||
syntax-violation calls, etc.
|
||||
- fix: unbound variables show up as #{b *top*:b}
|
||||
(~:s in message is supposed to take care of this but format isn't being called)
|
||||
- mats for system violations and errors
|
||||
- deal with error? and warning? mats
|
||||
|#
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
(define (warning-only? c)
|
||||
(and (warning? c) (not (serious-condition? c))))
|
||||
|
||||
(let ()
|
||||
(define $display-condition
|
||||
(lambda (c op prefix? use-cache?)
|
||||
(module (print-source)
|
||||
(include "types.ss")
|
||||
(define (print-position op prefix src start?)
|
||||
(call-with-values
|
||||
(lambda () ((current-locate-source-object-source) src start? use-cache?))
|
||||
(case-lambda
|
||||
[()
|
||||
(let ([sfd (source-sfd src)]
|
||||
[fp (if start? (source-bfp src) (source-efp src))])
|
||||
(fprintf op "~a~a char ~a of ~a" prefix
|
||||
(if (eq? start? 'near) "near" "at")
|
||||
fp (source-file-descriptor-name sfd)))]
|
||||
[(path line char)
|
||||
(fprintf op "~a~a line ~a, char ~a of ~a" prefix
|
||||
(if (eq? start? 'near) "near" "at")
|
||||
line char path)])))
|
||||
(define (print-source op prefix c)
|
||||
(cond
|
||||
[($src-condition? c)
|
||||
(let ([src ($src-condition-src c)])
|
||||
(when (source? src)
|
||||
(print-position op prefix src ($src-condition-start c))))]
|
||||
[(source-condition? c)
|
||||
(let ([form (source-condition-form c)])
|
||||
(parameterize ([print-level 3] [print-length 6])
|
||||
(fprintf op "~a~s" prefix (syntax->datum form)))
|
||||
(let-values ([(src start?) ($syntax->src form)])
|
||||
(when src (print-position op " " src start?))))]
|
||||
[(syntax-violation? c)
|
||||
(let ([form (syntax-violation-form c)]
|
||||
[subform (syntax-violation-subform c)])
|
||||
(parameterize ([print-level 3] [print-length 6])
|
||||
(if subform
|
||||
(fprintf op "~a~s in ~s" prefix (syntax->datum subform) (syntax->datum form))
|
||||
(fprintf op "~a~s" prefix (syntax->datum form))))
|
||||
(let-values ([(src start?) ($syntax->src subform)])
|
||||
(if src
|
||||
(print-position op " " src start?)
|
||||
(let-values ([(src start?) ($syntax->src form)])
|
||||
(when src (print-position op " " src start?))))))])))
|
||||
(cond
|
||||
[(and (format-condition? c)
|
||||
(guard (ignore [#t #f])
|
||||
($report-string #f
|
||||
(and prefix? (if (warning-only? c) "warning" "exception"))
|
||||
(and (who-condition? c) (condition-who c))
|
||||
(condition-message c)
|
||||
(condition-irritants c)))) =>
|
||||
(lambda (s)
|
||||
(display s op)
|
||||
(print-source op " " c))]
|
||||
[(message-condition? c)
|
||||
(let ([irritants (if (irritants-condition? c) (condition-irritants c) '())])
|
||||
(case (and (list? irritants) (length irritants))
|
||||
[(0)
|
||||
($report-string op
|
||||
(and prefix? (if (warning-only? c) "warning" "exception"))
|
||||
(and (who-condition? c) (condition-who c))
|
||||
"~a"
|
||||
(list (condition-message c)))]
|
||||
[(1)
|
||||
($report-string op
|
||||
(and prefix? (if (warning-only? c) "warning" "exception"))
|
||||
(and (who-condition? c) (condition-who c))
|
||||
"~a with irritant ~s"
|
||||
(list (condition-message c) (car irritants)))]
|
||||
[else
|
||||
($report-string op
|
||||
(and prefix? (if (warning-only? c) "warning" "exception"))
|
||||
(and (who-condition? c) (condition-who c))
|
||||
"~a with irritants ~s"
|
||||
(list (condition-message c) irritants))]))
|
||||
(print-source op " " c)]
|
||||
[else
|
||||
(fprintf op "Exception occurred")
|
||||
(cond
|
||||
[(condition? c)
|
||||
(print-source op " " c)
|
||||
(let ([x* (simple-conditions c)])
|
||||
(cond
|
||||
[(null? x*)
|
||||
(fprintf op " with empty condition\n")]
|
||||
[else
|
||||
(fprintf op " with condition components:")
|
||||
(for-each
|
||||
(lambda (x i)
|
||||
(let ([rtd (#3%record-rtd x)])
|
||||
(define (print-field i)
|
||||
(if (csv7:record-field-accessible? rtd i)
|
||||
(parameterize ([print-level 3] [print-length 6])
|
||||
(fprintf op ": ~s" ((csv7:record-field-accessor rtd i) x)))
|
||||
(fprintf op ": (inaccessible)")))
|
||||
(fprintf op "\n~3d. ~a" i (csv7:record-type-name (#3%record-rtd x)))
|
||||
(if (record-type-opaque? rtd)
|
||||
(fprintf op " (opaque)")
|
||||
(let ([name* (csv7:record-type-field-names rtd)])
|
||||
(if (fx= (length name*) 1)
|
||||
(print-field 0)
|
||||
(for-each
|
||||
(lambda (name i)
|
||||
(fprintf op "\n ~s" name)
|
||||
(print-field i))
|
||||
name* (iota (length name*))))))))
|
||||
x* (iota (length x*)))]))]
|
||||
[else (parameterize ([print-level 3] [print-length 6])
|
||||
(fprintf op " with non-condition value ~s" c))])])))
|
||||
|
||||
(set-who! display-condition
|
||||
(case-lambda
|
||||
[(c) ($display-condition c (current-output-port) #t #f)]
|
||||
[(c op)
|
||||
(unless (and (output-port? op) (textual-port? op))
|
||||
($oops who "~s is not a textual output port" op))
|
||||
($display-condition c op #t #f)]))
|
||||
|
||||
(set! $make-source-oops
|
||||
(lambda (who msg expr)
|
||||
#`(assertion-violation '#,who
|
||||
#,(call-with-string-output-port
|
||||
(lambda (p)
|
||||
($display-condition (condition
|
||||
(make-syntax-violation expr #f)
|
||||
(make-message-condition msg))
|
||||
p #f #t)))))))
|
||||
|
||||
(set! default-exception-handler
|
||||
(lambda (c)
|
||||
(let ([cep (console-error-port)])
|
||||
(with-exception-handler
|
||||
(lambda (c)
|
||||
(if (i/o-error? c)
|
||||
(begin
|
||||
(debug-condition c)
|
||||
(if (debug-on-exception) (debug))
|
||||
(reset))
|
||||
(raise-continuable c)))
|
||||
(lambda ()
|
||||
; only I/O to cep in handler-protected code---not (debug), not (reset).
|
||||
(fresh-line cep)
|
||||
(display-condition c cep)
|
||||
(newline cep)
|
||||
(unless (or (warning-only? c) (debug-on-exception) (= ($cafe) 0) (not (interactive?)))
|
||||
(display-string "Type (debug) to enter the debugger.\n" cep))
|
||||
(flush-output-port cep))))
|
||||
(unless (warning-only? c)
|
||||
(debug-condition c)
|
||||
(if (debug-on-exception) (debug))
|
||||
(reset)))))
|
||||
|
||||
(define debug-on-exception
|
||||
(make-parameter #f
|
||||
(lambda (x) (and x #t))))
|
||||
|
||||
(define base-exception-handler
|
||||
($make-thread-parameter
|
||||
default-exception-handler
|
||||
(lambda (p)
|
||||
(unless (procedure? p) ($oops 'default-exception-handler "~s is not a procedure" p))
|
||||
p)))
|
||||
|
||||
(let ()
|
||||
(define create-exception-stack
|
||||
(lambda (p)
|
||||
(let ([ls (list p)])
|
||||
(set-cdr! ls ls)
|
||||
ls)))
|
||||
|
||||
(define default-handler
|
||||
(lambda (x)
|
||||
((base-exception-handler) x)))
|
||||
|
||||
(define-threaded handler-stack (create-exception-stack default-handler))
|
||||
|
||||
(let ()
|
||||
(define-record-type exception-state
|
||||
(nongenerative)
|
||||
(opaque #t)
|
||||
(sealed #t)
|
||||
(fields (immutable stack)))
|
||||
|
||||
(set-who! create-exception-state
|
||||
(case-lambda
|
||||
[() (make-exception-state (create-exception-stack default-handler))]
|
||||
[(p)
|
||||
(unless (procedure? p) ($oops who "~s is not a procedure" p))
|
||||
(make-exception-state (create-exception-stack p))]))
|
||||
|
||||
(set-who! current-exception-state
|
||||
(case-lambda
|
||||
[() (make-exception-state handler-stack)]
|
||||
[(x)
|
||||
(unless (exception-state? x)
|
||||
($oops who "~s is not an exception state" x))
|
||||
(set! handler-stack (exception-state-stack x))])))
|
||||
|
||||
(set-who! with-exception-handler
|
||||
(lambda (handler thunk)
|
||||
(unless (procedure? handler) ($oops who "~s is not a procedure" handler))
|
||||
(unless (procedure? thunk) ($oops who "~s is not a procedure" thunk))
|
||||
(fluid-let ([handler-stack (cons handler handler-stack)])
|
||||
(thunk))))
|
||||
|
||||
(set-who! raise
|
||||
(lambda (obj)
|
||||
(let ([handler (car handler-stack)])
|
||||
(fluid-let ([handler-stack (cdr handler-stack)])
|
||||
(handler obj)
|
||||
(raise (make-non-continuable-violation))))))
|
||||
|
||||
(set-who! raise-continuable
|
||||
(lambda (obj)
|
||||
(let ([handler (car handler-stack)])
|
||||
(fluid-let ([handler-stack (cdr handler-stack)])
|
||||
(handler obj)))))
|
||||
|
||||
(set-who! $guard
|
||||
(lambda (supply-else? guards body)
|
||||
(if supply-else?
|
||||
((call/cc
|
||||
(lambda (kouter)
|
||||
(let ([original-handler-stack handler-stack])
|
||||
(with-exception-handler
|
||||
(lambda (arg)
|
||||
((call/cc
|
||||
(lambda (kinner)
|
||||
(kouter
|
||||
(lambda ()
|
||||
(guards arg
|
||||
(lambda ()
|
||||
(kinner
|
||||
(lambda ()
|
||||
(fluid-let ([handler-stack original-handler-stack])
|
||||
(raise-continuable arg))))))))))))
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
[(x) (lambda () x)]
|
||||
[vals (lambda () (apply values vals))]))))))))
|
||||
((call/cc
|
||||
(lambda (k)
|
||||
(with-exception-handler
|
||||
(lambda (arg) (k (lambda () (guards arg))))
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
[(x) (lambda () x)]
|
||||
[vals (lambda () (apply values vals))]))))))))))
|
||||
)
|
||||
|
||||
(define-syntax guard
|
||||
(syntax-rules (else)
|
||||
[(_ (var clause ... [else e1 e2 ...]) b1 b2 ...)
|
||||
(identifier? #'var)
|
||||
($guard #f (lambda (var) (cond clause ... [else e1 e2 ...]))
|
||||
(lambda () b1 b2 ...))]
|
||||
[(_ (var clause1 clause2 ...) b1 b2 ...)
|
||||
(identifier? #'var)
|
||||
($guard #t (lambda (var p) (cond clause1 clause2 ... [else (p)]))
|
||||
(lambda () b1 b2 ...))]))
|
||||
|
||||
(let ()
|
||||
; redefine here to get local predicate
|
||||
(define-record-type (&condition $make-simple-condition $simple-condition?)
|
||||
(nongenerative #{&condition oyb459ue1fphfx4-a}))
|
||||
|
||||
(define-record-type (compound-condition make-compound-condition compound-condition?)
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(fields (immutable components)))
|
||||
|
||||
(define (check-&condition-subtype! who rtd)
|
||||
(unless (record-type-descriptor? rtd)
|
||||
($oops who "~s is not a record type descriptor" rtd))
|
||||
(unless (let f ([rtd rtd])
|
||||
(or (eq? rtd (type-descriptor &condition))
|
||||
(let ([rtd (record-type-parent rtd)])
|
||||
(and rtd (f rtd)))))
|
||||
($oops who "~s does not describe a subtype of &condition" rtd)))
|
||||
|
||||
(record-writer (type-descriptor &condition)
|
||||
(lambda (x p wr)
|
||||
(fprintf p "#<condition ~a>" (csv7:record-type-name (#3%record-rtd x)))))
|
||||
|
||||
(record-writer (type-descriptor compound-condition)
|
||||
(lambda (x p wr)
|
||||
(fprintf p "#<compound condition>")))
|
||||
|
||||
(set-who! $compound-condition? compound-condition?)
|
||||
(set-who! $compound-condition-components compound-condition-components)
|
||||
|
||||
(set-who! condition
|
||||
(case-lambda
|
||||
[(x)
|
||||
(unless (or ($simple-condition? x) (compound-condition? x))
|
||||
($oops who "~s is not a condition" x))
|
||||
x]
|
||||
[x*
|
||||
(let ([ls (fold-right
|
||||
(lambda (x ls)
|
||||
(cond
|
||||
[($simple-condition? x) (cons x ls)]
|
||||
[(compound-condition? x) (append (compound-condition-components x) ls)]
|
||||
[else ($oops who "~s is not a condition" x)]))
|
||||
'()
|
||||
x*)])
|
||||
(if (fx= (length ls) 1)
|
||||
(car ls)
|
||||
(make-compound-condition ls)))]))
|
||||
|
||||
(set-who! simple-conditions
|
||||
(lambda (x)
|
||||
(cond
|
||||
[($simple-condition? x) (list x)]
|
||||
[(compound-condition? x) (compound-condition-components x)]
|
||||
[else ($oops who "~s is not a condition" x)])))
|
||||
|
||||
(set! condition?
|
||||
(lambda (x)
|
||||
(or ($simple-condition? x) (compound-condition? x))))
|
||||
|
||||
(set-who! condition-predicate
|
||||
(lambda (rtd)
|
||||
(check-&condition-subtype! who rtd)
|
||||
(let ([p? (lambda (x) (record? x rtd))])
|
||||
(lambda (x)
|
||||
(or (p? x)
|
||||
(and (compound-condition? x)
|
||||
(ormap p? (compound-condition-components x))))))))
|
||||
|
||||
(set-who! condition-accessor
|
||||
(lambda (rtd proc)
|
||||
(define accessor-error
|
||||
(lambda (x rtd)
|
||||
($oops 'generated-condition-accessor
|
||||
"~s is not a condition of the type represented by ~s"
|
||||
x rtd)))
|
||||
(check-&condition-subtype! who rtd)
|
||||
(rec generated-condition-accessor
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(record? x rtd) (proc x)]
|
||||
[(compound-condition? x)
|
||||
(let f ([ls (compound-condition-components x)])
|
||||
(if (null? ls)
|
||||
(accessor-error x rtd)
|
||||
(let ([x (car ls)])
|
||||
(if (record? x rtd)
|
||||
(proc x)
|
||||
(f (cdr ls))))))]
|
||||
[else (accessor-error x rtd)]))))))
|
||||
|
||||
(define-syntax define-condition-type
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ type-name super-type constructor predicate? (field-name accessor) ...)
|
||||
(with-syntax ([($accessor ...) (generate-temporaries #'(accessor ...))]
|
||||
[msg (format "~~s is not a condition of type ~a" (datum type-name))])
|
||||
#'(begin
|
||||
(define-record-type (type-name constructor $predicate?)
|
||||
(nongenerative)
|
||||
(parent super-type)
|
||||
(fields (immutable field-name $accessor) ...))
|
||||
(define predicate?
|
||||
(lambda (x)
|
||||
(or ($predicate? x)
|
||||
(and ($compound-condition? x)
|
||||
(ormap $predicate? ($compound-condition-components x))))))
|
||||
(define accessor
|
||||
(lambda (x)
|
||||
(define accessor-error (lambda (x) ($oops 'accessor msg x)))
|
||||
(cond
|
||||
[($predicate? x) ($accessor x)]
|
||||
[($compound-condition? x)
|
||||
(let f ([ls ($compound-condition-components x)])
|
||||
(if (null? ls)
|
||||
(accessor-error x)
|
||||
(let ([x (car ls)])
|
||||
(if ($predicate? x)
|
||||
($accessor x)
|
||||
(f (cdr ls))))))]
|
||||
[else (accessor-error x)])))
|
||||
...))])))
|
||||
|
||||
(eval-when (compile)
|
||||
(define-syntax define-system-condition-type
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ type-name super-type uid constructor predicate? (field-name accessor) ...)
|
||||
(with-syntax ([($accessor ...) (generate-temporaries #'(accessor ...))]
|
||||
[msg (format "~~s is not a condition of type ~a" (datum type-name))])
|
||||
#'(begin
|
||||
(define-record-type (type-name constructor $predicate?)
|
||||
(nongenerative uid)
|
||||
(parent super-type)
|
||||
(fields (immutable field-name $accessor) ...))
|
||||
(define predicate?
|
||||
(lambda (x)
|
||||
(or ($predicate? x)
|
||||
(and ($compound-condition? x)
|
||||
(ormap $predicate? ($compound-condition-components x))))))
|
||||
(define accessor
|
||||
(lambda (x)
|
||||
(define accessor-error (lambda (x) ($oops 'accessor msg x)))
|
||||
(cond
|
||||
[($predicate? x) ($accessor x)]
|
||||
[($compound-condition? x)
|
||||
(let f ([ls ($compound-condition-components x)])
|
||||
(if (null? ls)
|
||||
(accessor-error x)
|
||||
(let ([x (car ls)])
|
||||
(if ($predicate? x)
|
||||
($accessor x)
|
||||
(f (cdr ls))))))]
|
||||
[else (accessor-error x)])))
|
||||
...))])))
|
||||
)
|
||||
|
||||
;;; standard condition types
|
||||
|
||||
;;; taking advantage of body-like semantics of begin to arrange for each
|
||||
;;; condition type's compile-time information to be available for use in
|
||||
;;; defining its child types, even though the system is compiled with
|
||||
;;; (eval-syntax-expanders-when) not including compile.
|
||||
(begin
|
||||
(let-syntax ([a (syntax-rules ()
|
||||
[(_ &condition) ; leave only &condition visible
|
||||
(define-record-type (&condition make-simple-condition simple-condition?)
|
||||
(nongenerative #{&condition oyb459ue1fphfx4-a}))])])
|
||||
(a &condition))
|
||||
|
||||
(define-system-condition-type &message &condition #{&message bwptyckgidgnsihx-a}
|
||||
make-message-condition message-condition?
|
||||
(message condition-message))
|
||||
|
||||
(define-system-condition-type &warning &condition #{&warning bwtai41dgaww3fus-a}
|
||||
make-warning warning?)
|
||||
|
||||
(define-system-condition-type &serious &condition #{&serious bwvzuvr26s58u3l9-a}
|
||||
make-serious-condition serious-condition?)
|
||||
|
||||
(define-system-condition-type &error &serious #{&error bwyo6misxbfkmrdg-a}
|
||||
make-error error?)
|
||||
|
||||
(define-system-condition-type &violation &serious #{&violation bw1eic9intowee4m-a}
|
||||
make-violation violation?)
|
||||
|
||||
(define-system-condition-type &assertion &violation #{&assertion bw33t3z8ebx752vs-a}
|
||||
make-assertion-violation assertion-violation?)
|
||||
|
||||
(define-system-condition-type &irritants &condition #{&irritants bw6s5uqx4t7jxqmy-a}
|
||||
make-irritants-condition irritants-condition?
|
||||
(irritants condition-irritants))
|
||||
|
||||
(define-system-condition-type &who &condition #{&who bw9ihlhnvcgvped6-a}
|
||||
make-who-condition who-condition?
|
||||
(who condition-who))
|
||||
|
||||
(define-system-condition-type &non-continuable &violation #{&non-continuable bxb7tb8dlup7g15e-a}
|
||||
make-non-continuable-violation
|
||||
non-continuable-violation?)
|
||||
|
||||
(define-system-condition-type &implementation-restriction &violation #{&implementation-restriction bxew42y3cczi8pwl-a}
|
||||
make-implementation-restriction-violation
|
||||
implementation-restriction-violation?)
|
||||
|
||||
(define-system-condition-type &lexical &violation #{&lexical bxhmgtps2u8u0dns-a}
|
||||
make-lexical-violation lexical-violation?)
|
||||
|
||||
(define-system-condition-type &syntax &violation #{&syntax bxkbskgitdh6r1ey-a}
|
||||
make-syntax-violation syntax-violation?
|
||||
(form syntax-violation-form)
|
||||
(subform syntax-violation-subform))
|
||||
|
||||
(define-system-condition-type &undefined &violation #{&undefined bxm04a68jvrijo54-a}
|
||||
make-undefined-violation undefined-violation?)
|
||||
|
||||
;;; io conditions
|
||||
|
||||
(define-system-condition-type &i/o &error #{&i/o bxpqf1xyad0ubcxc-a}
|
||||
make-i/o-error i/o-error?)
|
||||
|
||||
(define-system-condition-type &i/o-read &i/o #{&i/o-read bxsfrson0v9520oj-a}
|
||||
make-i/o-read-error i/o-read-error?)
|
||||
|
||||
(define-system-condition-type &i/o-write &i/o #{&i/o-write bxu43jfdrejhuofp-a}
|
||||
make-i/o-write-error i/o-write-error?)
|
||||
|
||||
(define-system-condition-type &i/o-invalid-position &i/o #{&i/o-invalid-position bxxue953hwstmb6v-a}
|
||||
make-i/o-invalid-position-error
|
||||
i/o-invalid-position-error?
|
||||
(position i/o-error-position))
|
||||
|
||||
(define-system-condition-type &i/o-filename &i/o #{&i/o-filename bx0jq0ws8e15dzx4-a}
|
||||
make-i/o-filename-error i/o-filename-error?
|
||||
(filename i/o-error-filename))
|
||||
|
||||
(define-system-condition-type &i/o-file-protection &i/o-filename #{&i/o-file-protection bx282rniyxbg5npc-a}
|
||||
make-i/o-file-protection-error
|
||||
i/o-file-protection-error?)
|
||||
|
||||
(define-system-condition-type &i/o-file-is-read-only &i/o-file-protection #{&i/o-file-is-read-only bx5yeid8pfksxbgj-a}
|
||||
make-i/o-file-is-read-only-error
|
||||
i/o-file-is-read-only-error?)
|
||||
|
||||
(define-system-condition-type &i/o-file-already-exists &i/o-filename #{&i/o-file-already-exists bx8np84yfxt4oy7q-a}
|
||||
make-i/o-file-already-exists-error
|
||||
i/o-file-already-exists-error?)
|
||||
|
||||
(define-system-condition-type &i/o-file-does-not-exist &i/o-filename #{&i/o-file-does-not-exist bybc1zvn6f3ggmyw-a}
|
||||
make-i/o-file-does-not-exist-error
|
||||
i/o-file-does-not-exist-error?)
|
||||
|
||||
(define-system-condition-type &i/o-port &i/o #{&i/o-port byd2dqmdwycr8ap5-a}
|
||||
make-i/o-port-error i/o-port-error?
|
||||
(pobj i/o-error-port))
|
||||
|
||||
(define-system-condition-type &i/o-decoding &i/o-port #{&i/o-decoding bygrphc3ngl3zyhc-a}
|
||||
make-i/o-decoding-error i/o-decoding-error?)
|
||||
|
||||
(define-system-condition-type &i/o-encoding &i/o-port #{&i/o-encoding byjg073tdyvfrl8i-a}
|
||||
make-i/o-encoding-error i/o-encoding-error?
|
||||
(cobj i/o-encoding-error-char))
|
||||
|
||||
;;; arithmetic conditions
|
||||
|
||||
(define-system-condition-type &no-infinities &implementation-restriction #{&no-infinities byl6cyui4g4ri9zq-a}
|
||||
make-no-infinities-violation
|
||||
no-infinities-violation?)
|
||||
|
||||
(define-system-condition-type &no-nans &implementation-restriction #{&no-nans byovopk8uzd3axqx-a}
|
||||
make-no-nans-violation no-nans-violation?)
|
||||
|
||||
;;; Chez Scheme conditions
|
||||
|
||||
(define-system-condition-type &source &condition #{&source byrk0gbylhne2lh4-a}
|
||||
make-source-condition source-condition?
|
||||
(form source-condition-form))
|
||||
|
||||
(define-system-condition-type $&src &condition #{$&src byul0m8re6e47nnb-a}
|
||||
$make-src-condition $src-condition?
|
||||
(src $src-condition-src)
|
||||
(start $src-condition-start))
|
||||
|
||||
(define-system-condition-type &format &condition #{&format byxbcdzg5oogzbei-a}
|
||||
make-format-condition format-condition?)
|
||||
|
||||
(define-system-condition-type &continuation &condition #{&continuation dxr8vukkubd1tr8-a}
|
||||
make-continuation-condition continuation-condition?
|
||||
(k condition-continuation))
|
||||
|
||||
(define-system-condition-type $&recompile &error #{&recompile eb5ipy47b8hscnlzoga59k-0}
|
||||
$make-recompile-condition $recompile-condition?
|
||||
(importer-path $recompile-importer-path))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define avcond (make-assertion-violation))
|
||||
(define econd (make-error))
|
||||
(define wcond (make-warning))
|
||||
(define fcond (make-format-condition))
|
||||
(define favcond (condition avcond fcond))
|
||||
(define fecond (condition econd fcond))
|
||||
(define fwcond (condition wcond fcond))
|
||||
(define ircond (make-implementation-restriction-violation))
|
||||
(define fimpcond (condition ircond fcond))
|
||||
(define flexcond (condition (make-lexical-violation) (make-i/o-read-error) fcond))
|
||||
(define flexcond/ir (condition ircond (make-lexical-violation) (make-i/o-read-error) fcond))
|
||||
|
||||
(define (error-help warning? who whoarg message irritants basecond)
|
||||
(unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg))
|
||||
($oops who "invalid who argument ~s (message = ~s, irritants = ~s)" whoarg message irritants))
|
||||
(unless (string? message)
|
||||
($oops who "invalid message argument ~s (who = ~s, irritants = ~s)" message whoarg irritants))
|
||||
(let ([c (if whoarg
|
||||
(if irritants
|
||||
(condition basecond
|
||||
(make-who-condition whoarg)
|
||||
(make-message-condition message)
|
||||
(make-irritants-condition irritants))
|
||||
(condition basecond
|
||||
(make-who-condition whoarg)
|
||||
(make-message-condition message)))
|
||||
(if irritants
|
||||
(condition basecond
|
||||
(make-message-condition message)
|
||||
(make-irritants-condition irritants))
|
||||
(condition basecond
|
||||
(make-message-condition message))))])
|
||||
(if warning?
|
||||
(raise-continuable c)
|
||||
(call/cc
|
||||
(lambda (k)
|
||||
(raise (condition c (make-continuation-condition k))))))))
|
||||
|
||||
(set-who! assertion-violation
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #f who whoarg message irritants avcond)))
|
||||
|
||||
(set-who! assertion-violationf
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #f who whoarg message irritants favcond)))
|
||||
|
||||
(set-who! $oops
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #f who whoarg message irritants favcond)))
|
||||
|
||||
(set-who! $oops/c
|
||||
(lambda (whoarg basecond message . irritants)
|
||||
(error-help #f who whoarg message irritants
|
||||
(condition basecond fcond))))
|
||||
|
||||
(set-who! $impoops
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #f who whoarg message irritants fimpcond)))
|
||||
|
||||
(set-who! $record-oops
|
||||
(lambda (whoarg nonrec rtd)
|
||||
(unless (record-type-descriptor? rtd)
|
||||
($oops who "~s is not a record-type descriptor" rtd))
|
||||
(when (record? nonrec rtd)
|
||||
($oops who "~s actually is of type ~s" nonrec rtd))
|
||||
(error-help #f who whoarg "~s is not of type ~s" (list nonrec rtd) favcond)))
|
||||
|
||||
(set-who! error
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #f who whoarg message irritants econd)))
|
||||
|
||||
(set-who! errorf
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #f who whoarg message irritants fecond)))
|
||||
|
||||
(set-who! warning
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #t who whoarg message irritants wcond)))
|
||||
|
||||
(set-who! warningf
|
||||
(lambda (whoarg message . irritants)
|
||||
(error-help #t who whoarg message irritants fwcond)))
|
||||
|
||||
(let ()
|
||||
(define (infer-who form)
|
||||
(syntax-case form ()
|
||||
[id (identifier? #'id) (datum id)]
|
||||
[(id . stuff) (identifier? #'id) (datum id)]
|
||||
[_ #f]))
|
||||
(set-who! syntax-violation
|
||||
(case-lambda
|
||||
[(whoarg message form)
|
||||
(error-help #f who (or whoarg (infer-who form)) message #f
|
||||
(condition avcond (make-syntax-violation form #f)))]
|
||||
[(whoarg message form subform)
|
||||
(error-help #f who (or whoarg (infer-who form)) message #f
|
||||
(make-syntax-violation form subform))])))
|
||||
|
||||
(set-who! syntax-error
|
||||
(lambda (form . messages)
|
||||
(for-each
|
||||
(lambda (m) (unless (string? m) ($oops who "~s is not a string" m)))
|
||||
messages)
|
||||
(error-help #f who #f
|
||||
(if (null? messages) "invalid syntax" (apply string-append messages))
|
||||
#f (make-syntax-violation form #f))))
|
||||
|
||||
(set-who! $undefined-violation
|
||||
(lambda (id message)
|
||||
(error-help #f who #f message #f
|
||||
(condition (make-undefined-violation) (make-syntax-violation id #f)))))
|
||||
|
||||
(set-who! $lexical-error
|
||||
(case-lambda
|
||||
[(whoarg msg args port ir?)
|
||||
(error-help #f who whoarg msg args
|
||||
(condition
|
||||
(make-i/o-port-error port)
|
||||
(if ir? flexcond/ir flexcond)))]
|
||||
[(whoarg msg args port src start? ir?)
|
||||
(error-help #f who whoarg msg args
|
||||
(condition
|
||||
(make-i/o-port-error port)
|
||||
(if ir? flexcond/ir flexcond)
|
||||
($make-src-condition src start?)))]))
|
||||
|
||||
(set-who! $source-violation
|
||||
(lambda (whoarg src start? msg . args)
|
||||
(error-help #f who whoarg msg args
|
||||
(if src
|
||||
(condition favcond ($make-src-condition src start?))
|
||||
favcond))))
|
||||
|
||||
(set-who! $source-warning
|
||||
(lambda (whoarg src start? msg . args)
|
||||
(error-help #t who whoarg msg args
|
||||
(if src
|
||||
(condition fwcond ($make-src-condition src start?))
|
||||
fwcond))))
|
||||
)
|
||||
)
|
||||
114
s/expand-lang.ss
Normal file
114
s/expand-lang.ss
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
;;; expand-lang.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-record-type libreq
|
||||
(fields
|
||||
(immutable path)
|
||||
(immutable version)
|
||||
(immutable uid))
|
||||
(nongenerative #{libreq fnuxvkuvs8x0xbc68h3hm6-0})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type recompile-info
|
||||
(fields
|
||||
(immutable import-req*)
|
||||
(immutable include-req*))
|
||||
(nongenerative #{recompile-info fnuxvkuvs8x0xbc68h3hm6-1})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type library-info
|
||||
(nongenerative #{library-info e10vy7tci6bqz6pmnxgvlq-3})
|
||||
(fields
|
||||
(immutable path)
|
||||
(immutable version)
|
||||
(immutable uid)
|
||||
(immutable visible?)))
|
||||
|
||||
(define-record-type library/ct-info
|
||||
(parent library-info)
|
||||
(fields
|
||||
(immutable import-req*)
|
||||
(immutable visit-visit-req*)
|
||||
(immutable visit-req*))
|
||||
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-4})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type library/rt-info
|
||||
(parent library-info)
|
||||
(fields
|
||||
(immutable invoke-req*))
|
||||
(nongenerative #{library/rt-info ff86rtm7efmvxcvrmh7t0b-3})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type program-info
|
||||
(fields (immutable uid) (immutable invoke-req*))
|
||||
(nongenerative #{program-info fgc8ptwnu9i5gfqz3s85mr-0})
|
||||
(sealed #t))
|
||||
|
||||
(module (Lexpand Lexpand?)
|
||||
(define library-path?
|
||||
(lambda (x)
|
||||
(and (list? x) (andmap symbol? x))))
|
||||
|
||||
(define library-version?
|
||||
(lambda (x)
|
||||
(and (list? x)
|
||||
(andmap (lambda (x) (and (integer? x) (exact? x) (>= x 0))) x))))
|
||||
|
||||
(define maybe-optimization-loc? (lambda (x) (or (not x) (box? x)))) ; should be a record
|
||||
|
||||
(define maybe-label? (lambda (x) (or (not x) (gensym? x))))
|
||||
|
||||
(define-language Lexpand
|
||||
(nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-3})
|
||||
(terminals
|
||||
(maybe-label (dl))
|
||||
(gensym (uid export-id))
|
||||
(library-path (path))
|
||||
(library-version (version))
|
||||
(maybe-optimization-loc (db))
|
||||
(prelex (dv))
|
||||
(libreq (import-req visit-req visit-visit-req invoke-req))
|
||||
(string (include-req))
|
||||
(Lsrc (lsrc body init visit-code import-code de)) => unparse-Lsrc
|
||||
(recompile-info (rcinfo))
|
||||
(library/ct-info (linfo/ct))
|
||||
(library/rt-info (linfo/rt))
|
||||
(program-info (pinfo)))
|
||||
(Outer (outer)
|
||||
(recompile-info rcinfo)
|
||||
(group outer1 outer2)
|
||||
(visit-only inner)
|
||||
(revisit-only inner)
|
||||
inner)
|
||||
(Inner (inner)
|
||||
(library/ct-info linfo/ct)
|
||||
ctlib
|
||||
(library/rt-info linfo/rt)
|
||||
rtlib
|
||||
(program-info pinfo)
|
||||
prog
|
||||
lsrc)
|
||||
(ctLibrary (ctlib)
|
||||
(library/ct uid (export-id* ...) import-code visit-code))
|
||||
(rtLibrary (rtlib)
|
||||
(library/rt uid
|
||||
(dl* ...)
|
||||
(db* ...)
|
||||
(dv* ...)
|
||||
(de* ...)
|
||||
body))
|
||||
(Program (prog)
|
||||
(program uid body))))
|
||||
3054
s/expeditor.ss
Normal file
3054
s/expeditor.ss
Normal file
File diff suppressed because it is too large
Load diff
157
s/fasl-helpers.ss
Normal file
157
s/fasl-helpers.ss
Normal file
|
|
@ -0,0 +1,157 @@
|
|||
;;; fasl-helpers.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(module (put8 put16 put32 put64 put-iptr put-uptr)
|
||||
(define (bit-mask k) (- (ash 1 k) 1))
|
||||
(define put8
|
||||
(lambda (p n)
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))))
|
||||
(define put16-le
|
||||
(cond
|
||||
[(>= (most-positive-fixnum) (bit-mask 16))
|
||||
(lambda (p n)
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 8) (bit-mask 8))))]
|
||||
[else ($oops 'put16-le "unsupported fixnum size")]))
|
||||
(define put16-be
|
||||
(cond
|
||||
[(>= (most-positive-fixnum) (bit-mask 16))
|
||||
(lambda (p n)
|
||||
(put-u8 p (fxlogand (fxsrl n 8) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand n (bit-mask 8))))]
|
||||
[else ($oops 'put16-be "unsupported fixnum size")]))
|
||||
(define put16
|
||||
(lambda (p n)
|
||||
(constant-case native-endianness
|
||||
[(little) (put16-le p n)]
|
||||
[(big) (put16-be p n)])))
|
||||
(define put32-le
|
||||
(cond
|
||||
[(>= (most-positive-fixnum) (bit-mask 32))
|
||||
(lambda (p n)
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 8) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 16) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 24) (bit-mask 8))))]
|
||||
[(>= (most-positive-fixnum) (bit-mask 24))
|
||||
(lambda (p n)
|
||||
(cond
|
||||
[(fixnum? n)
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 8) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 16) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsra n 24) (bit-mask 8)))]
|
||||
[else
|
||||
(let ([n (logand n (bit-mask 16))])
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))
|
||||
(put-u8 p (fxsrl n 8)))
|
||||
(let ([n (ash n -16)])
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsra n 8) (bit-mask 8))))]))]
|
||||
[else ($oops 'put32-le "unsupported fixnum size")]))
|
||||
(define put32-be
|
||||
(cond
|
||||
[(>= (most-positive-fixnum) (bit-mask 32))
|
||||
(lambda (p n)
|
||||
(put-u8 p (fxlogand (fxsrl n 24) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 16) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 8) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand n (bit-mask 8))))]
|
||||
[(>= (most-positive-fixnum) (bit-mask 24))
|
||||
(lambda (p n)
|
||||
(cond
|
||||
[(fixnum? n)
|
||||
(put-u8 p (fxlogand (fxsra n 24) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 16) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand (fxsrl n 8) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand n (bit-mask 8)))]
|
||||
[else
|
||||
(let ([n (ash n -16)])
|
||||
(put-u8 p (fxlogand (fxsra n 8) (bit-mask 8)))
|
||||
(put-u8 p (fxlogand n (bit-mask 8))))
|
||||
(let ([n (logand n (bit-mask 16))])
|
||||
(put-u8 p (fxsrl n 8))
|
||||
(put-u8 p (fxlogand n (bit-mask 8))))]))]
|
||||
[else ($oops 'put32-be "unsupported fixnum size")]))
|
||||
(define put32
|
||||
(lambda (p n)
|
||||
(constant-case native-endianness
|
||||
[(little) (put32-le p n)]
|
||||
[(big) (put32-be p n)])))
|
||||
(define put64-le
|
||||
(lambda (p n)
|
||||
(cond
|
||||
[(and (>= (most-positive-fixnum) (bit-mask 32)) (fixnum? n))
|
||||
(put32-le p (fxlogand n (bit-mask 32)))
|
||||
(put32-le p (ash n -32))]
|
||||
[else
|
||||
(put32-le p (logand n (bit-mask 32)))
|
||||
(put32-le p (ash n -32))])))
|
||||
(define put64-be
|
||||
(lambda (p n)
|
||||
(cond
|
||||
[(and (>= (most-positive-fixnum) (bit-mask 32)) (fixnum? n))
|
||||
(put32-be p (ash n -32))
|
||||
(put32-be p (fxlogand n (bit-mask 32)))]
|
||||
[else
|
||||
(put32-be p (ash n -32))
|
||||
(put32-be p (logand n (bit-mask 32)))])))
|
||||
(define put64
|
||||
(lambda (p n)
|
||||
(constant-case native-endianness
|
||||
[(little) (put64-le p n)]
|
||||
[(big) (put64-be p n)])))
|
||||
(define put-iptr
|
||||
(lambda (p n0)
|
||||
(let f ([n (if (< n0 0) (- n0) n0)] [cbit 0])
|
||||
(if (and (fixnum? n) (fx<= n 63))
|
||||
(put8 p (fxlogor (if (< n0 0) #x80 0) (fxsll n 1) cbit))
|
||||
(begin
|
||||
(f (ash n -7) 1)
|
||||
(put-u8 p (fxlogor (fxsll (logand n #x7f) 1) cbit)))))))
|
||||
(define put-uptr
|
||||
(lambda (p n)
|
||||
(unless (>= n 0)
|
||||
($oops 'compiler-internal "put-uptr received negative input ~s" n))
|
||||
(let f ([n n] [cbit 0])
|
||||
(if (and (fixnum? n) (fx<= n 127))
|
||||
(put-u8 p (fxlogor (fxsll n 1) cbit))
|
||||
(begin
|
||||
(f (ash n -7) 1)
|
||||
(put-u8 p (fxlogor (fxsll (logand n #x7f) 1) cbit)))))))
|
||||
)
|
||||
|
||||
(define emit-header
|
||||
(case-lambda
|
||||
[(p version mtype) (emit-header p version mtype '())]
|
||||
[(p version mtype bootfiles)
|
||||
(define (put-str p s)
|
||||
(let ([n (string-length s)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n))
|
||||
(let* ([c (string-ref s i)] [k (char->integer c)])
|
||||
(unless (fx<= k 255)
|
||||
($oops #f "cannot handle bootfile name character ~s whose integer code exceeds 255" c))
|
||||
(put-u8 p k)))))
|
||||
(put-bytevector p (constant fasl-header))
|
||||
(put-uptr p version)
|
||||
(put-uptr p mtype)
|
||||
(put-u8 p (char->integer #\()) ; )
|
||||
(let f ([bootfiles bootfiles] [sep? #f])
|
||||
(unless (null? bootfiles)
|
||||
(when sep? (put-u8 p (char->integer #\space)))
|
||||
(put-str p (car bootfiles))
|
||||
(f (cdr bootfiles) #t))) ; (
|
||||
(put-u8 p (char->integer #\)))]))
|
||||
712
s/fasl.ss
Normal file
712
s/fasl.ss
Normal file
|
|
@ -0,0 +1,712 @@
|
|||
;;; fasl.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(let ()
|
||||
(define-record-type target
|
||||
(nongenerative #{target dchg2hp5v3cck8ge283luo-1})
|
||||
(sealed #t)
|
||||
(fields
|
||||
fasl-bld-graph
|
||||
fasl-enter
|
||||
fasl-out
|
||||
fasl-start
|
||||
fasl-table
|
||||
fasl-wrf-graph
|
||||
fasl-base-rtd
|
||||
fasl-write
|
||||
fasl-file))
|
||||
|
||||
(let ()
|
||||
(include "types.ss")
|
||||
|
||||
; don't use rtd-* as defined in record.ss in case we're building a patch
|
||||
; file for cross compilation, because the offsets may be incorrect
|
||||
(define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
|
||||
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
|
||||
(define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent))
|
||||
(define rtd-name (csv7:record-field-accessor #!base-rtd 'name))
|
||||
(define rtd-uid (csv7:record-field-accessor #!base-rtd 'uid))
|
||||
(define rtd-flags (csv7:record-field-accessor #!base-rtd 'flags))
|
||||
|
||||
(define-record-type table
|
||||
(fields (mutable count) (immutable hash))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda ()
|
||||
(new 0 (make-eq-hashtable))))))
|
||||
|
||||
(include "fasl-helpers.ss")
|
||||
|
||||
(define bld-pair
|
||||
(lambda (x t a?)
|
||||
(bld (car x) t a?)
|
||||
(bld (cdr x) t a?)))
|
||||
|
||||
(define bld-vector
|
||||
(lambda (x t a?)
|
||||
(let ([len (vector-length x)])
|
||||
(let bldvec ([i 0])
|
||||
(unless (fx= i len)
|
||||
(bld (vector-ref x i) t a?)
|
||||
(bldvec (fx+ i 1)))))))
|
||||
|
||||
(define bld-record
|
||||
(lambda (x t a?)
|
||||
(unless (eq? x #!base-rtd)
|
||||
(when (record-type-descriptor? x)
|
||||
; fasl representation for record-type-descriptor includes uid separately and as part of the record
|
||||
(bld (record-type-uid x) t a?))
|
||||
(really-bld-record x t a?))))
|
||||
|
||||
(define really-bld-record
|
||||
(lambda (x t a?)
|
||||
(let ([rtd ($record-type-descriptor x)])
|
||||
(bld rtd t a?)
|
||||
(do ([flds (rtd-flds rtd) (cdr flds)] [i 0 (+ i 1)])
|
||||
((null? flds))
|
||||
(when (memq (fld-type (car flds)) '(scheme-object ptr))
|
||||
(bld ((csv7:record-field-accessor rtd i) x) t a?))))))
|
||||
|
||||
(define bld-ht
|
||||
(lambda (x t a?)
|
||||
(let-values ([(keyvec valvec) (hashtable-entries x)])
|
||||
(vector-for-each
|
||||
(lambda (key val)
|
||||
(bld key t a?)
|
||||
(bld val t a?))
|
||||
keyvec valvec))))
|
||||
|
||||
(define bld-box
|
||||
(lambda (x t a?)
|
||||
(bld (unbox x) t a?)))
|
||||
|
||||
(define bld-simple
|
||||
(lambda (x t a?)
|
||||
(void)))
|
||||
|
||||
(module (bld-graph dump-graph reset-dump-graph)
|
||||
(define enable-dump-graph? #f)
|
||||
(define vcat (if enable-dump-graph?
|
||||
`#((code . ,(lambda (x) (and (pair? x) (eq? (car x) 'code))))
|
||||
(pair . ,pair?)
|
||||
(string . ,string?)
|
||||
(symbol . ,symbol?)
|
||||
(vector . ,vector?)
|
||||
(record . ,record?)
|
||||
(other . ,(lambda (x) #t)))))
|
||||
(define ventry)
|
||||
(define vdup)
|
||||
(define record!
|
||||
(lambda (v x)
|
||||
(when enable-dump-graph?
|
||||
(let f ([i 0])
|
||||
(let ([cat (vector-ref vcat i)])
|
||||
(if ((cdr cat) x)
|
||||
(vector-set! v i (fx+ (vector-ref v i) 1))
|
||||
(f (fx+ i 1))))))))
|
||||
(define reset-dump-graph
|
||||
(lambda ()
|
||||
(when enable-dump-graph?
|
||||
(set! ventry (make-vector (vector-length vcat) 0))
|
||||
(set! vdup (make-vector (vector-length vcat) 0)))))
|
||||
(define dump-graph
|
||||
(lambda ()
|
||||
(when enable-dump-graph?
|
||||
(vector-for-each
|
||||
(lambda (cat entry dup)
|
||||
(printf "~10s ~10s ~s\n" entry dup (car cat)))
|
||||
vcat ventry vdup))))
|
||||
(define bld-graph
|
||||
(lambda (x t a? handler)
|
||||
(let ([a (eq-hashtable-cell (table-hash t) x 'first)])
|
||||
(let ([p (cdr a)])
|
||||
(cond
|
||||
[(eq? p 'first)
|
||||
#;(let ([n (hashtable-size (table-hash t))])
|
||||
(when (fx= (modulo n 10000) 0)
|
||||
(printf "entries = ~s, ba = ~s, count = ~s\n" n (bytes-allocated) (table-count t))))
|
||||
(record! ventry x)
|
||||
(set-cdr! a #f)
|
||||
(handler x t a?)]
|
||||
[(not p)
|
||||
(record! vdup x)
|
||||
(let ([n (table-count t)])
|
||||
(set-cdr! a (cons n #t))
|
||||
(table-count-set! t (fx+ n 1)))])))))
|
||||
(reset-dump-graph))
|
||||
|
||||
(define bld
|
||||
(lambda (x t a?)
|
||||
(cond
|
||||
[(pair? x) (bld-graph x t a? bld-pair)]
|
||||
[(vector? x) (bld-graph x t a? bld-vector)]
|
||||
[(or (symbol? x) (string? x)) (bld-graph x t a? bld-simple)]
|
||||
; this check must go before $record? check
|
||||
[(and (annotation? x) (not a?))
|
||||
(bld (annotation-stripped x) t a?)]
|
||||
; this check must go before $record? check
|
||||
[(eq-hashtable? x) (bld-graph x t a? bld-ht)]
|
||||
; this check must go before $record? check
|
||||
[(symbol-hashtable? x) (bld-graph x t a? bld-ht)]
|
||||
[($record? x) (bld-graph x t a? bld-record)]
|
||||
[(box? x) (bld-graph x t a? bld-box)]
|
||||
[(or (large-integer? x) (ratnum? x) ($inexactnum? x) ($exactnum? x)
|
||||
(fxvector? x) (bytevector? x))
|
||||
(bld-graph x t a? bld-simple)])))
|
||||
|
||||
(module (small-integer? large-integer?)
|
||||
(define least-small-integer (- (expt 2 31)))
|
||||
(define greatest-small-integer (- (expt 2 31) 1))
|
||||
(define small-integer?
|
||||
(lambda (x)
|
||||
(if (fixnum? greatest-small-integer)
|
||||
(and (fixnum? x) (fx<= least-small-integer x greatest-small-integer))
|
||||
(or (fixnum? x) (and (bignum? x) (<= least-small-integer x greatest-small-integer))))))
|
||||
(define large-integer?
|
||||
(lambda (x)
|
||||
(if (fixnum? greatest-small-integer)
|
||||
(if (fixnum? x) (not (fx<= least-small-integer x greatest-small-integer)) (bignum? x))
|
||||
(and (bignum? x) (not (<= least-small-integer x greatest-small-integer)))))))
|
||||
|
||||
(define wrf-small-integer
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-small-integer))
|
||||
(put-iptr p x)))
|
||||
|
||||
(define wrf-large-integer
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-large-integer))
|
||||
(put-u8 p (if (positive? x) 0 1))
|
||||
(let* ([x (abs x)] [il (integer-length x)])
|
||||
(let* ([n (bitwise-arithmetic-shift-right il
|
||||
(log2 (constant bigit-bits)))]
|
||||
[m (bitwise-arithmetic-shift-left n
|
||||
(log2 (constant bigit-bits)))])
|
||||
(if (fx= m il)
|
||||
(put-uptr p n)
|
||||
(begin
|
||||
(put-uptr p (+ n 1))
|
||||
(put-uptr p (bitwise-arithmetic-shift-right x m))))
|
||||
(let f ([end m])
|
||||
(unless (= end 0)
|
||||
(let ([start (- end (constant bigit-bits))])
|
||||
(put-uptr p (bitwise-bit-field x start end))
|
||||
(f start))))))))
|
||||
|
||||
(define wrf-pair
|
||||
(lambda (x p t a?)
|
||||
(cond
|
||||
[(weak-pair? x)
|
||||
(put-u8 p (constant fasl-type-weak-pair))
|
||||
(wrf (car x) p t a?)
|
||||
(wrf (cdr x) p t a?)]
|
||||
[(ephemeron-pair? x)
|
||||
(put-u8 p (constant fasl-type-ephemeron))
|
||||
(wrf (car x) p t a?)
|
||||
(wrf (cdr x) p t a?)]
|
||||
[else
|
||||
; more like list*
|
||||
(put-u8 p (constant fasl-type-pair))
|
||||
(let ([n (let wrf-pair-loop0 ([n 1] [x (cdr x)])
|
||||
; cut off at end or at shared structure
|
||||
(if (and (pair? x)
|
||||
(not (weak-pair? x))
|
||||
(not (ephemeron-pair? x))
|
||||
(not (eq-hashtable-ref (table-hash t) x #f)))
|
||||
(wrf-pair-loop0 (fx+ n 1) (cdr x))
|
||||
n))])
|
||||
(put-uptr p n)
|
||||
(let wrf-pair-loop1 ([x x] [n n])
|
||||
(wrf (car x) p t a?)
|
||||
(if (fx= n 1)
|
||||
(wrf (cdr x) p t a?)
|
||||
(wrf-pair-loop1 (cdr x) (fx- n 1)))))])))
|
||||
|
||||
(define wrf-symbol
|
||||
(lambda (x p t a?)
|
||||
(cond
|
||||
[(gensym? x)
|
||||
(let ((uname (gensym->unique-string x)))
|
||||
(put-u8 p (constant fasl-type-gensym))
|
||||
(wrf-string-help (symbol->string x) p)
|
||||
(wrf-string-help uname p))]
|
||||
[else
|
||||
(put-u8 p (constant fasl-type-symbol))
|
||||
(wrf-string-help (symbol->string x) p)])))
|
||||
|
||||
(define wrf-string-help
|
||||
(lambda (x p)
|
||||
(put-uptr p (string-length x))
|
||||
(let ([n (string-length x)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n))
|
||||
(put-uptr p (char->integer (string-ref x i)))))))
|
||||
|
||||
(define wrf-string
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (if (immutable-string? x)
|
||||
(constant fasl-type-immutable-string)
|
||||
(constant fasl-type-string)))
|
||||
(wrf-string-help x p)))
|
||||
|
||||
(define wrf-vector
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (if (immutable-vector? x)
|
||||
(constant fasl-type-immutable-vector)
|
||||
(constant fasl-type-vector)))
|
||||
(let ([n (vector-length x)])
|
||||
(put-uptr p n)
|
||||
(let wrf-vector-loop ([i 0])
|
||||
(unless (fx= i n)
|
||||
(wrf (vector-ref x i) p t a?)
|
||||
(wrf-vector-loop (fx+ i 1)))))))
|
||||
|
||||
(define wrf-fxvector
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (if (immutable-fxvector? x)
|
||||
(constant fasl-type-immutable-fxvector)
|
||||
(constant fasl-type-fxvector)))
|
||||
(let ([n (fxvector-length x)])
|
||||
(put-uptr p n)
|
||||
(let wrf-fxvector-loop ([i 0])
|
||||
(unless (fx= i n)
|
||||
(put-iptr p (fxvector-ref x i))
|
||||
(wrf-fxvector-loop (fx+ i 1)))))))
|
||||
|
||||
(define wrf-bytevector
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (if (immutable-bytevector? x)
|
||||
(constant fasl-type-immutable-bytevector)
|
||||
(constant fasl-type-bytevector)))
|
||||
(let ([n (bytevector-length x)])
|
||||
(put-uptr p n)
|
||||
(let wrf-bytevector-loop ([i 0])
|
||||
(unless (fx= i n)
|
||||
(let ([x (bytevector-u8-ref x i)])
|
||||
(put-u8 p x)
|
||||
(wrf-bytevector-loop (fx+ i 1))))))))
|
||||
|
||||
; Written as: fasl-tag rtd field ...
|
||||
(module (wrf-record really-wrf-record wrf-annotation)
|
||||
(define maybe-remake-rtd
|
||||
(lambda (rtd)
|
||||
(if (eq? (machine-type) ($target-machine))
|
||||
rtd
|
||||
($remake-rtd rtd (let () (include "layout.ss") compute-field-offsets)))))
|
||||
|
||||
(define wrf-fields
|
||||
(lambda (x p t a?)
|
||||
; extract field values using host field information (byte offset and filtered
|
||||
; type); write using target field information. to save i/o & space, using iptr
|
||||
; as common rep'n for multibyte integer fields since any small unsigned quantity
|
||||
; is a small signed but a small negative signed quantity is a large unsigned
|
||||
; quantity. we check 16- and 32-bit integer values and fixnums before writing
|
||||
; them in case the host field is larger than the target field.
|
||||
(define get-field
|
||||
(lambda (host-fld)
|
||||
(let ([type (fld-type host-fld)] [addr (fld-byte host-fld)])
|
||||
; using $filter-foreign-type to get host filtering
|
||||
(case ($filter-foreign-type type)
|
||||
[(scheme-object) ($object-ref 'ptr x addr)]
|
||||
[(integer-8 unsigned-8 char) ($object-ref 'unsigned-8 x addr)]
|
||||
[(integer-16 unsigned-16) ($object-ref 'integer-16 x addr)]
|
||||
[(integer-24 unsigned-24) ($object-ref 'integer-24 x addr)]
|
||||
[(integer-32 unsigned-32) ($object-ref 'integer-32 x addr)]
|
||||
[(integer-40 unsigned-40) ($object-ref 'integer-40 x addr)]
|
||||
[(integer-48 unsigned-48) ($object-ref 'integer-48 x addr)]
|
||||
[(integer-56 unsigned-56) ($object-ref 'integer-56 x addr)]
|
||||
[(integer-64 unsigned-64) ($object-ref 'integer-64 x addr)]
|
||||
[(single-float) ($object-ref 'unsigned-32 x addr)]
|
||||
[(double-float) ($object-ref 'unsigned-64 x addr)]
|
||||
[(wchar)
|
||||
(constant-case wchar-bits
|
||||
[(16) ($object-ref 'integer-16 x addr)]
|
||||
[(32) ($object-ref 'integer-32 x addr)])]
|
||||
[(fixnum) ($object-ref 'fixnum x addr)]
|
||||
[else ($oops 'fasl-write "cannot fasl record field of type ~s" type)]))))
|
||||
(define check-field
|
||||
(lambda (target-fld val)
|
||||
(unless (eq? (constant machine-type-name) (machine-type))
|
||||
(let* ([type (fld-type target-fld)] [filtered-type (filter-foreign-type type)])
|
||||
(unless (case filtered-type
|
||||
[(scheme-object) #t]
|
||||
[(integer-16 unsigned-16) ($integer-16? val)]
|
||||
[(integer-32 unsigned-32) ($integer-32? val)]
|
||||
[(wchar)
|
||||
(constant-case wchar-bits
|
||||
[(16) ($integer-16? val)]
|
||||
[(32) ($integer-32? val)])]
|
||||
[(fixnum) (<= (- (ash 1 (- (constant fixnum-bits) 1))) val (- (ash 1 (- (constant fixnum-bits) 1)) 1))]
|
||||
[(char single-float double-float) #t]
|
||||
[(integer-8 integer-64 integer-24 integer-40 integer-48 integer-56) #t]
|
||||
[(unsigned-8 unsigned-64 unsigned-24 unsigned-40 unsigned-48 unsigned-56) #t]
|
||||
[else ($oops 'fasl-write "unexpected difference in filtered foreign type ~s for unfiltered type ~s" filtered-type type)])
|
||||
($oops 'fasl-write "host value ~s for type ~s is too big for target" val type))))))
|
||||
(define put-field
|
||||
(lambda (target-fld pad val)
|
||||
(define put-i64
|
||||
(lambda (p val)
|
||||
(constant-case ptr-bits
|
||||
[(32) (put-iptr p (bitwise-arithmetic-shift-right val 32)) (put-uptr p (logand val #xffffffff))]
|
||||
[(64) (put-iptr p val)])))
|
||||
(define-syntax put-padty
|
||||
(syntax-rules ()
|
||||
[(_ fasl-fld-type)
|
||||
(put-u8 p (fxlogor (fxsll pad 4) (constant fasl-fld-type)))]))
|
||||
(let ([type (fld-type target-fld)] [addr (fld-byte target-fld)])
|
||||
; using filter-foreign-type to get target filtering
|
||||
(case (filter-foreign-type type)
|
||||
[(scheme-object) (put-padty fasl-fld-ptr) (wrf val p t a?) (constant ptr-bytes)]
|
||||
[(integer-8 unsigned-8 char) (put-padty fasl-fld-u8) (put-u8 p val) 1]
|
||||
[(integer-16 unsigned-16) (put-padty fasl-fld-i16) (put-iptr p val) 2]
|
||||
[(integer-24 unsigned-24) (put-padty fasl-fld-i24) (put-iptr p val) 3]
|
||||
[(integer-32 unsigned-32) (put-padty fasl-fld-i32) (put-iptr p val) 4]
|
||||
[(integer-40 unsigned-40) (put-padty fasl-fld-i40) (put-i64 p val) 5]
|
||||
[(integer-48 unsigned-48) (put-padty fasl-fld-i48) (put-i64 p val) 6]
|
||||
[(integer-56 unsigned-56) (put-padty fasl-fld-i56) (put-i64 p val) 7]
|
||||
[(integer-64 unsigned-64) (put-padty fasl-fld-i64) (put-i64 p val) 8]
|
||||
[(single-float)
|
||||
(put-padty fasl-fld-single)
|
||||
(put-uptr p val)
|
||||
4]
|
||||
[(double-float)
|
||||
(put-padty fasl-fld-double)
|
||||
(let ([n val])
|
||||
(put-uptr p (ash n -32))
|
||||
(put-uptr p (logand n #xFFFFFFFF)))
|
||||
8]
|
||||
[(wchar)
|
||||
(constant-case wchar-bits
|
||||
[(16) (put-padty fasl-fld-i16) (put-iptr p val)]
|
||||
[(32) (put-padty fasl-fld-i32) (put-iptr p val)])
|
||||
(/ (constant wchar-bits) 8)]
|
||||
[(fixnum)
|
||||
(constant-case ptr-bits
|
||||
[(32) (put-padty fasl-fld-i32)]
|
||||
[(64) (put-padty fasl-fld-i64)])
|
||||
(put-iptr p val)
|
||||
(constant ptr-bytes)]
|
||||
[else ($oops 'fasl-write "cannot fasl record field of type ~s" type)]))))
|
||||
(let* ([host-rtd ($record-type-descriptor x)]
|
||||
[target-rtd (maybe-remake-rtd host-rtd)]
|
||||
[target-fld* (rtd-flds target-rtd)])
|
||||
(put-uptr p (rtd-size target-rtd))
|
||||
(put-uptr p (length target-fld*))
|
||||
(wrf host-rtd p t a?)
|
||||
(fold-left
|
||||
(lambda (last-target-addr host-fld target-fld)
|
||||
(let ([val (get-field host-fld)])
|
||||
(check-field target-fld val)
|
||||
(let ([target-addr (fld-byte target-fld)])
|
||||
(fx+ target-addr (put-field host-fld (fx- target-addr last-target-addr) val)))))
|
||||
(constant record-data-disp)
|
||||
(rtd-flds host-rtd)
|
||||
target-fld*))))
|
||||
|
||||
(define wrf-record
|
||||
(lambda (x p t a?)
|
||||
(if (eq? x #!base-rtd)
|
||||
(put-u8 p (constant fasl-type-base-rtd))
|
||||
(really-wrf-record x p t a?))))
|
||||
|
||||
(define really-wrf-record
|
||||
(lambda (x p t a?)
|
||||
(cond
|
||||
[(record-type-descriptor? x)
|
||||
(put-u8 p (constant fasl-type-rtd))
|
||||
(wrf (record-type-uid x) p t a?)
|
||||
(wrf-fields (maybe-remake-rtd x) p t a?)]
|
||||
[else
|
||||
(put-u8 p (constant fasl-type-record))
|
||||
(wrf-fields x p t a?)])))
|
||||
|
||||
(define wrf-annotation
|
||||
(lambda (x p t a?)
|
||||
(define maybe-remake-annotation
|
||||
(lambda (x a?)
|
||||
(if (fx= (annotation-flags x) a?)
|
||||
x
|
||||
(make-annotation (annotation-expression x) (annotation-source x) (annotation-stripped x) a?))))
|
||||
(put-u8 p (constant fasl-type-record))
|
||||
(wrf-fields (maybe-remake-annotation x a?) p t a?)))
|
||||
)
|
||||
|
||||
(define wrf-eqht
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-eq-hashtable))
|
||||
(put-u8 p (if (hashtable-mutable? x) 1 0))
|
||||
(put-u8 p (cond
|
||||
[(eq-hashtable-weak? x) (constant eq-hashtable-subtype-weak)]
|
||||
[(eq-hashtable-ephemeron? x) (constant eq-hashtable-subtype-ephemeron)]
|
||||
[else (constant eq-hashtable-subtype-normal)]))
|
||||
(put-uptr p ($ht-minlen x))
|
||||
(put-uptr p ($ht-veclen x))
|
||||
(let-values ([(keyvec valvec) (hashtable-entries x)])
|
||||
(put-uptr p (vector-length keyvec))
|
||||
(vector-for-each
|
||||
(lambda (key val)
|
||||
(wrf key p t a?)
|
||||
(unless (<= (constant most-positive-fixnum) (most-positive-fixnum))
|
||||
(when (fixnum? key)
|
||||
(unless (fx<= (constant most-negative-fixnum) key (constant most-positive-fixnum))
|
||||
($oops 'fasl-write "eq-hashtable fixnum key ~s is out-of-range for target machine" key))))
|
||||
(wrf val p t a?))
|
||||
keyvec valvec))))
|
||||
|
||||
(define wrf-symht
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-symbol-hashtable))
|
||||
(put-u8 p (if (hashtable-mutable? x) 1 0))
|
||||
(put-uptr p ($ht-minlen x))
|
||||
(put-u8 p
|
||||
(let ([equiv? (hashtable-equivalence-function x)])
|
||||
(cond
|
||||
[(eq? equiv? eq?) 0]
|
||||
[(eq? equiv? eqv?) 1]
|
||||
[(eq? equiv? equal?) 2]
|
||||
[(eq? equiv? symbol=?) 3]
|
||||
[else ($oops 'fasl-write "unexpected equivalence function ~s for symbol hashtable ~s" equiv? x)])))
|
||||
(put-uptr p ($ht-veclen x))
|
||||
(let-values ([(keyvec valvec) (hashtable-entries x)])
|
||||
(put-uptr p (vector-length keyvec))
|
||||
(vector-for-each
|
||||
(lambda (key val)
|
||||
(wrf key p t a?)
|
||||
(wrf val p t a?))
|
||||
keyvec valvec))))
|
||||
|
||||
(define wrf-box
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (if (immutable-box? x)
|
||||
(constant fasl-type-immutable-box)
|
||||
(constant fasl-type-box)))
|
||||
(wrf (unbox x) p t a?)))
|
||||
|
||||
(define wrf-ratnum
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-ratnum))
|
||||
(wrf ($ratio-numerator x) p t a?)
|
||||
(wrf ($ratio-denominator x) p t a?)))
|
||||
|
||||
(define wrf-inexactnum
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-inexactnum))
|
||||
(wrf ($inexactnum-real-part x) p t a?)
|
||||
(wrf ($inexactnum-imag-part x) p t a?)))
|
||||
|
||||
(define wrf-exactnum
|
||||
(lambda (x p t a?)
|
||||
(put-u8 p (constant fasl-type-exactnum))
|
||||
(wrf ($exactnum-real-part x) p t a?)
|
||||
(wrf ($exactnum-imag-part x) p t a?)))
|
||||
|
||||
(define wrf-char
|
||||
(lambda (x p)
|
||||
(wrf-immediate
|
||||
(fxlogor (fxsll (char->integer x) (constant char-data-offset))
|
||||
(constant type-char))
|
||||
p)))
|
||||
|
||||
(define wrf-immediate
|
||||
(lambda (x p)
|
||||
(put-u8 p (constant fasl-type-immediate))
|
||||
(put-uptr p x)))
|
||||
|
||||
(define wrf-flonum
|
||||
(lambda (x p)
|
||||
(put-u8 p (constant fasl-type-flonum))
|
||||
(let ([n ($object-ref 'unsigned-64 x (constant flonum-data-disp))])
|
||||
(put-uptr p (ash n -32))
|
||||
(put-uptr p (logand n #xFFFFFFFF)))))
|
||||
|
||||
(define wrf-graph
|
||||
(lambda (x p t a? handler)
|
||||
(let ([a (eq-hashtable-ref (table-hash t) x #f)])
|
||||
(cond
|
||||
[(not a)
|
||||
(handler x p t a?)]
|
||||
[(cdr a)
|
||||
(put-u8 p (constant fasl-type-graph-def))
|
||||
(put-uptr p (car a))
|
||||
(set-cdr! a #f)
|
||||
(handler x p t a?)]
|
||||
[else
|
||||
(put-u8 p (constant fasl-type-graph-ref))
|
||||
(put-uptr p (car a))]))))
|
||||
|
||||
(define wrf
|
||||
(lambda (x p t a?)
|
||||
(cond
|
||||
[(symbol? x) (wrf-graph x p t a? wrf-symbol)]
|
||||
[(pair? x) (wrf-graph x p t a? wrf-pair)]
|
||||
[(small-integer? x) (wrf-small-integer x p t a?)]
|
||||
[(null? x) (wrf-immediate (constant snil) p)]
|
||||
[(not x) (wrf-immediate (constant sfalse) p)]
|
||||
[(eq? x #t) (wrf-immediate (constant strue) p)]
|
||||
[(string? x) (wrf-graph x p t a? wrf-string)]
|
||||
[(fxvector? x) (wrf-graph x p t a? wrf-fxvector)]
|
||||
[(bytevector? x) (wrf-graph x p t a? wrf-bytevector)]
|
||||
; this check must go before $record? check
|
||||
[(annotation? x)
|
||||
(if a?
|
||||
(wrf-graph x p t a? wrf-annotation)
|
||||
(wrf (annotation-stripped x) p t a?))]
|
||||
; this check must go before $record? check
|
||||
[(eq-hashtable? x) (wrf-graph x p t a? wrf-eqht)]
|
||||
; this check must go before $record? check
|
||||
[(symbol-hashtable? x) (wrf-graph x p t a? wrf-symht)]
|
||||
; this check must go before $record? check
|
||||
[(hashtable? x) ($oops 'fasl-write "invalid fasl object ~s" x)]
|
||||
[($record? x) (wrf-graph x p t a? wrf-record)]
|
||||
[(vector? x) (wrf-graph x p t a? wrf-vector)]
|
||||
[(char? x) (wrf-char x p)]
|
||||
[(box? x) (wrf-graph x p t a? wrf-box)]
|
||||
[(large-integer? x) (wrf-graph x p t a? wrf-large-integer)]
|
||||
[(ratnum? x) (wrf-graph x p t a? wrf-ratnum)]
|
||||
[(flonum? x) (wrf-flonum x p)]
|
||||
[($inexactnum? x) (wrf-graph x p t a? wrf-inexactnum)]
|
||||
[($exactnum? x) (wrf-graph x p t a? wrf-exactnum)]
|
||||
[(eof-object? x) (wrf-immediate (constant seof) p)]
|
||||
[(bwp-object? x) (wrf-immediate (constant sbwp) p)]
|
||||
[($unbound-object? x) (wrf-immediate (constant sunbound) p)]
|
||||
[(eq? x (void)) (wrf-immediate (constant svoid) p)]
|
||||
[(eq? x '#0=#0#) (wrf-immediate (constant black-hole) p)]
|
||||
[($rtd-counts? x) (wrf-immediate (constant sfalse) p)]
|
||||
[else ($oops 'fasl-write "invalid fasl object ~s" x)])))
|
||||
|
||||
(define start
|
||||
(lambda (p t situation proc)
|
||||
(define (append-bvs bv*)
|
||||
(let f ([bv* bv*] [n 0])
|
||||
(if (null? bv*)
|
||||
(if (fixnum? n)
|
||||
(make-bytevector n)
|
||||
($oops 'fasl-write "fasl output is too large to compress"))
|
||||
(let ([bv1 (car bv*)])
|
||||
(let ([m (bytevector-length bv1)])
|
||||
(let ([bv2 (f (cdr bv*) (+ n m))])
|
||||
(bytevector-copy! bv1 0 bv2 n m)
|
||||
bv2))))))
|
||||
(dump-graph)
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(put-u8 p (constant fasl-type-graph))
|
||||
(put-uptr p n)))
|
||||
(proc p)
|
||||
(extractor))])
|
||||
(put-u8 p situation)
|
||||
(if (and (>= size 100) (fasl-compressed))
|
||||
(let* ([fmt ($tc-field 'compress-format ($tc))]
|
||||
[bv (append-bvs bv*)]
|
||||
[uncompressed-size-bv (call-with-bytevector-output-port (lambda (bvp) (put-uptr bvp (bytevector-length bv))))]
|
||||
[bv ($bytevector-compress bv fmt)])
|
||||
(put-uptr p (+ 1 (bytevector-length uncompressed-size-bv) (bytevector-length bv)))
|
||||
(put-u8 p
|
||||
(cond
|
||||
[(eqv? fmt (constant COMPRESS-GZIP)) (constant fasl-type-gzip)]
|
||||
[(eqv? fmt (constant COMPRESS-LZ4)) (constant fasl-type-lz4)]
|
||||
[else ($oops 'fasl-write "unexpected $compress-format value ~s" fmt)]))
|
||||
(put-bytevector p uncompressed-size-bv)
|
||||
(put-bytevector p bv))
|
||||
(begin
|
||||
(put-uptr p (+ size 1))
|
||||
(put-u8 p (constant fasl-type-uncompressed))
|
||||
(for-each (lambda (bv) (put-bytevector p bv)) bv*))))))
|
||||
|
||||
(module (fasl-write fasl-file)
|
||||
; when called from fasl-write or fasl-file, always preserve annotations;
|
||||
; otherwise use value passed in by the compiler
|
||||
(define fasl-one
|
||||
(lambda (x p)
|
||||
(let ([t (make-table)])
|
||||
(bld x t (constant annotation-all))
|
||||
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all)))))))
|
||||
|
||||
(define-who fasl-write
|
||||
(lambda (x p)
|
||||
(unless (and (output-port? p) (binary-port? p))
|
||||
($oops who "~s is not a binary output port" p))
|
||||
(when ($port-flags-set? p (constant port-flag-compressed)) ($compressed-warning who p))
|
||||
(emit-header p (constant scheme-version) (constant machine-type-any))
|
||||
(fasl-one x p)))
|
||||
|
||||
(define-who fasl-file
|
||||
(lambda (in out)
|
||||
(unless (string? in) ($oops who "~s is not a string" in))
|
||||
(unless (string? out) ($oops who "~s is not a string" out))
|
||||
(let ([ip ($open-file-input-port who in (file-options)
|
||||
(buffer-mode block) (current-transcoder))]
|
||||
[op ($open-file-output-port who out (file-options replace))])
|
||||
(on-reset
|
||||
(begin
|
||||
(close-input-port ip)
|
||||
(delete-file out #f))
|
||||
(on-reset
|
||||
(close-port op)
|
||||
(emit-header op (constant scheme-version) (constant machine-type-any))
|
||||
(let fasl-loop ()
|
||||
(let ([x (read ip)])
|
||||
(unless (eof-object? x)
|
||||
(fasl-one x op)
|
||||
(fasl-loop)))))
|
||||
(close-port op))
|
||||
(close-port ip)))))
|
||||
|
||||
(define fasl-base-rtd
|
||||
(lambda (x p)
|
||||
(emit-header p (constant scheme-version) (constant machine-type-any))
|
||||
(let ([t (make-table)])
|
||||
(bld-graph x t #f really-bld-record)
|
||||
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf-graph x p t #f really-wrf-record))))))
|
||||
|
||||
($fasl-target (make-target bld-graph bld wrf start make-table wrf-graph fasl-base-rtd fasl-write fasl-file))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define fasl-target
|
||||
(lambda ()
|
||||
(let ([target ($fasl-target)])
|
||||
(assert target)
|
||||
target)))
|
||||
(set! $fasl-bld-graph (lambda (x t a? handler) ((target-fasl-bld-graph (fasl-target)) x t a? handler)))
|
||||
(set! $fasl-enter (lambda (x t a?) ((target-fasl-enter (fasl-target)) x t a?)))
|
||||
(set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
|
||||
(set! $fasl-start (lambda (p t situation proc) ((target-fasl-start (fasl-target)) p t situation proc)))
|
||||
(set! $fasl-table (lambda () ((target-fasl-table (fasl-target)))))
|
||||
(set! $fasl-wrf-graph (lambda (x p t a? handler) ((target-fasl-wrf-graph (fasl-target)) x p t a? handler)))
|
||||
(set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))
|
||||
(set! fasl-write (lambda (x p) ((target-fasl-write (fasl-target)) x p)))
|
||||
(set! fasl-file (lambda (in out) ((target-fasl-file (fasl-target)) in out))))
|
||||
|
||||
(when ($unbound-object? (#%$top-level-value '$capture-fasl-target))
|
||||
(let ([ht (make-hashtable values =)])
|
||||
(set! $capture-fasl-target
|
||||
(lambda (mt)
|
||||
(hashtable-set! ht mt ($fasl-target))))
|
||||
(set-who! $with-fasl-target
|
||||
(lambda (mt th)
|
||||
(cond
|
||||
[(hashtable-ref ht mt #f) =>
|
||||
(lambda (target)
|
||||
(parameterize ([$fasl-target target])
|
||||
(th)))]
|
||||
[else ($oops who "unrecognized machine type ~s" mt)])))))
|
||||
|
||||
($capture-fasl-target (constant machine-type))
|
||||
)
|
||||
73
s/foreign.ss
Normal file
73
s/foreign.ss
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
;;; foreign.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(let ()
|
||||
(define $foreign-address-name
|
||||
(foreign-procedure "(cs)foreign_address_name" (void*)
|
||||
string))
|
||||
|
||||
(define $remove-foreign-entry
|
||||
(foreign-procedure "(cs)remove_foreign_entry"
|
||||
(string) scheme-object))
|
||||
|
||||
(set! $foreign-entries
|
||||
(foreign-procedure "(cs)foreign_entries" ()
|
||||
scheme-object))
|
||||
|
||||
(set! remove-foreign-entry
|
||||
(lambda (entry)
|
||||
(unless (string? entry)
|
||||
($oops 'remove-foreign-entry "~s is not a string" entry))
|
||||
(unless ($remove-foreign-entry entry)
|
||||
($oops 'remove-foreign-entry "no entry for ~s" entry))))
|
||||
|
||||
(let ()
|
||||
(define lookup
|
||||
(foreign-procedure "(cs)lookup_foreign_entry" (string)
|
||||
void*))
|
||||
(set-who! foreign-entry?
|
||||
(lambda (str)
|
||||
(unless (string? str) ($oops who "~s is not a string" str))
|
||||
(if (eqv? (lookup str) 0) #f #t)))
|
||||
(set-who! foreign-entry
|
||||
(lambda (str)
|
||||
(unless (string? str) ($oops who "~s is not a string" str))
|
||||
(let ([x (lookup str)])
|
||||
(when (eqv? x 0) ($oops who "no entry for ~s" str))
|
||||
x))))
|
||||
|
||||
(set-who! foreign-address-name
|
||||
(lambda (n)
|
||||
(define void*?
|
||||
(constant-case ptr-bits
|
||||
[(32) $integer-32?]
|
||||
[(64) $integer-64?]))
|
||||
(unless (void*? n) ($oops who "~s is not a valid address" n))
|
||||
($foreign-address-name n)))
|
||||
|
||||
(set! load-shared-object
|
||||
(if (foreign-entry? "(cs)load_shared_object")
|
||||
(let ()
|
||||
(define lso
|
||||
(foreign-procedure "(cs)load_shared_object"
|
||||
(string)
|
||||
void))
|
||||
(lambda (x)
|
||||
(unless (or (string? x) (eq? x #f))
|
||||
($oops 'load-shared-object "invalid path ~s" x))
|
||||
(lso x)))
|
||||
(lambda args
|
||||
($oops 'load-shared-object "not supported"))))
|
||||
) ;let
|
||||
1784
s/format.ss
Normal file
1784
s/format.ss
Normal file
File diff suppressed because it is too large
Load diff
252
s/front.ss
Normal file
252
s/front.ss
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
;;; front.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who make-parameter
|
||||
(case-lambda
|
||||
[(init guard) (#2%make-parameter init guard)]
|
||||
[(v) (#2%make-parameter v)]))
|
||||
|
||||
(when-feature pthreads
|
||||
(let ()
|
||||
(define allocate-thread-parameter
|
||||
(let ()
|
||||
(define free-list '()) ; list of pairs w/ index as car
|
||||
(define index-guardian (make-guardian))
|
||||
(lambda (initval)
|
||||
(with-tc-mutex
|
||||
(let ([index
|
||||
(or (index-guardian)
|
||||
(and (not (null? free-list))
|
||||
(let ([index (car free-list)])
|
||||
(set! free-list (cdr free-list))
|
||||
index))
|
||||
(let* ([n (vector-length ($tc-field 'parameters ($tc)))]
|
||||
[m (fx* (fx+ n 1) 2)])
|
||||
(for-each
|
||||
(lambda (thread)
|
||||
(let ([tc ($thread-tc thread)])
|
||||
(let ([old ($tc-field 'parameters tc)]
|
||||
[new (make-vector m)])
|
||||
(do ([i (fx- n 1) (fx- i 1)])
|
||||
((fx< i 0))
|
||||
(vector-set! new i (vector-ref old i)))
|
||||
($tc-field 'parameters tc new))))
|
||||
($thread-list))
|
||||
(set! free-list
|
||||
(do ([i (fx- m 1) (fx- i 1)]
|
||||
[ls free-list (cons (list i) ls)])
|
||||
((fx= i n) ls)))
|
||||
(list n)))])
|
||||
(let loop ()
|
||||
(let ([index (index-guardian)])
|
||||
(when index
|
||||
(for-each
|
||||
(lambda (thread)
|
||||
(vector-set!
|
||||
($tc-field 'parameters ($thread-tc thread))
|
||||
(car index)
|
||||
0))
|
||||
($thread-list))
|
||||
(set! free-list (cons index free-list))
|
||||
(loop))))
|
||||
(for-each
|
||||
(lambda (thread)
|
||||
(vector-set!
|
||||
($tc-field 'parameters ($thread-tc thread))
|
||||
(car index)
|
||||
initval))
|
||||
($thread-list))
|
||||
(index-guardian index)
|
||||
index)))))
|
||||
(define set-thread-parameter!
|
||||
(lambda (index value)
|
||||
(with-tc-mutex
|
||||
(vector-set! ($tc-field 'parameters ($tc)) (car index) value))))
|
||||
(set-who! make-thread-parameter
|
||||
(case-lambda
|
||||
[(init guard)
|
||||
(unless (procedure? guard) ($oops who "~s is not a procedure" guard))
|
||||
(let ([index (allocate-thread-parameter (guard init))])
|
||||
(case-lambda
|
||||
[() (vector-ref ($tc-field 'parameters ($tc)) (car index))]
|
||||
[(u) (set-thread-parameter! index (guard u))]))]
|
||||
[(init)
|
||||
(let ([index (allocate-thread-parameter init)])
|
||||
(case-lambda
|
||||
[() (vector-ref ($tc-field 'parameters ($tc)) (car index))]
|
||||
[(u) (set-thread-parameter! index u)]))]))
|
||||
(set! $allocate-thread-parameter allocate-thread-parameter)
|
||||
(set! $set-thread-parameter! set-thread-parameter!))
|
||||
)
|
||||
|
||||
(define case-sensitive ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define compile-interpret-simple ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define generate-interrupt-trap ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define generate-allocation-counts ($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define generate-instruction-counts ($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define machine-type
|
||||
(lambda ()
|
||||
(constant machine-type-name)))
|
||||
|
||||
(define-who $fasl-target ($make-thread-parameter #f))
|
||||
|
||||
;;; package stubs are defined here in case we exclude certain packages
|
||||
(eval-when (compile)
|
||||
(define-syntax package-stub
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ name msg)
|
||||
(identifier? #'name)
|
||||
#'(package-stub (name name) msg)]
|
||||
[(_ (name pub-name) msg)
|
||||
#'(define name (lambda args ($oops 'pub-name msg)))])))
|
||||
|
||||
(define-syntax package-stubs
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ pkg name ...)
|
||||
(with-syntax ([msg (format "~a package is not loaded" (datum pkg))])
|
||||
#'(begin (package-stub name msg) ...))])))
|
||||
)
|
||||
|
||||
(package-stubs cafe
|
||||
waiter-prompt-and-read
|
||||
waiter-write
|
||||
waiter-prompt-string
|
||||
new-cafe)
|
||||
(package-stubs compile
|
||||
($clear-dynamic-closure-counts compile)
|
||||
($c-make-closure compile)
|
||||
($c-make-code compile)
|
||||
compile
|
||||
($compile-backend compile)
|
||||
compile-file
|
||||
($compile-host-library compile)
|
||||
compile-library
|
||||
compile-port
|
||||
compile-program
|
||||
compile-script
|
||||
compile-to-file
|
||||
compile-to-port
|
||||
compile-whole-library
|
||||
compile-whole-program
|
||||
($dynamic-closure-counts compile)
|
||||
($loop-unroll-limit compile)
|
||||
make-boot-file
|
||||
($make-boot-file make-boot-file)
|
||||
make-boot-header
|
||||
($make-boot-header make-boot-header)
|
||||
maybe-compile-file
|
||||
maybe-compile-library
|
||||
maybe-compile-program
|
||||
($np-boot-code compile)
|
||||
($np-compile compile)
|
||||
($np-get-timers compile)
|
||||
($np-last-pass compile)
|
||||
($np-reset-timers! compile)
|
||||
($np-tracer compile)
|
||||
($optimize-closures compile)
|
||||
($track-dynamic-closure-counts compile)
|
||||
($track-static-closure-counts compile))
|
||||
(package-stubs fasl
|
||||
($fasl-bld-graph fasl-write)
|
||||
($fasl-enter fasl-write)
|
||||
($fasl-start fasl-write)
|
||||
($fasl-table fasl-write)
|
||||
($fasl-out fasl-write)
|
||||
($fasl-wrf-graph fasl-write)
|
||||
fasl-write
|
||||
fasl-file)
|
||||
(package-stubs inspect
|
||||
inspect
|
||||
inspect/object)
|
||||
(package-stubs interpret
|
||||
interpret)
|
||||
(package-stubs pretty-print
|
||||
pretty-format
|
||||
pretty-line-length
|
||||
pretty-one-line-limit
|
||||
pretty-initial-indent
|
||||
pretty-standard-indent
|
||||
pretty-maximum-lines
|
||||
pretty-print
|
||||
pretty-file)
|
||||
(package-stubs profile
|
||||
profile-clear
|
||||
profile-dump)
|
||||
(package-stubs sc-expand
|
||||
sc-expand
|
||||
($syntax-dispatch sc-expand)
|
||||
syntax-error
|
||||
literal-identifier=?
|
||||
bound-identifier=?
|
||||
free-identifier=?
|
||||
identifier?
|
||||
generate-temporaries
|
||||
syntax->datum
|
||||
datum->syntax)
|
||||
(package-stubs trace
|
||||
trace-output-port
|
||||
trace-print
|
||||
($trace trace)
|
||||
($untrace untrace)
|
||||
($trace-closure trace))
|
||||
(package-stubs compiler-support
|
||||
$cp0
|
||||
$cpvalid
|
||||
$cpletrec
|
||||
$cpcheck)
|
||||
(package-stubs syntax-support
|
||||
$uncprep)
|
||||
|
||||
(define current-eval
|
||||
($make-thread-parameter
|
||||
(lambda args ($oops 'eval "no current evaluator"))
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
($oops 'current-eval "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define current-expand
|
||||
($make-thread-parameter
|
||||
(lambda args ($oops 'expand "no current expander"))
|
||||
(lambda (x)
|
||||
(unless (procedure? x)
|
||||
($oops 'current-expand "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define eval
|
||||
(case-lambda
|
||||
[(x) ((current-eval) x)]
|
||||
[(x env-spec) ((current-eval) x env-spec)]))
|
||||
|
||||
(define expand
|
||||
(case-lambda
|
||||
[(x) ((current-expand) x)]
|
||||
[(x env-spec) ((current-expand) x env-spec)]
|
||||
[(x env-spec records?) ((current-expand) x env-spec records?)]
|
||||
[(x env-spec records? compiling-a-file) ((current-expand) x env-spec records? compiling-a-file)]
|
||||
[(x env-spec records? compiling-a-file outfn) ((current-expand) x env-spec records? compiling-a-file outfn)]))
|
||||
|
||||
(define $compiler-is-loaded? #f)
|
||||
)
|
||||
2062
s/ftype.ss
Normal file
2062
s/ftype.ss
Normal file
File diff suppressed because it is too large
Load diff
47
s/hashtable-types.ss
Normal file
47
s/hashtable-types.ss
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
;;; hashtable-types.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-record-type (hashtable make-xht xht?)
|
||||
(fields (immutable type xht-type) (immutable mutable? xht-mutable?))
|
||||
(nongenerative #{hashtable bu811z2onf9o6tfc-0}))
|
||||
|
||||
(define-record-type ht
|
||||
(parent hashtable)
|
||||
(fields (mutable vec) (mutable minlen) (mutable size))
|
||||
(nongenerative #{ht bu811z2onf9o6tfc-6}))
|
||||
|
||||
(define-record-type eq-ht
|
||||
(parent ht)
|
||||
(fields (immutable subtype)) ; eq-hashtable-subtype-{normal,weak,ephemeron}
|
||||
(nongenerative #{eq-ht icguu8mlhm1y7ywsairxck-0})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type symbol-ht
|
||||
(parent ht)
|
||||
(fields (immutable equiv?))
|
||||
(nongenerative #{symbol-ht bu811z2onf9o6tfc-8})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type gen-ht
|
||||
(parent ht)
|
||||
(fields (immutable hash) (immutable equiv?))
|
||||
(nongenerative #{gen-ht bu811z2onf9o6tfc-7})
|
||||
(sealed #t))
|
||||
|
||||
(define-record-type eqv-ht
|
||||
(parent hashtable)
|
||||
(fields (immutable eqht) (immutable genht))
|
||||
(nongenerative #{eqv-ht bu811z2onf9o6tfc-4})
|
||||
(sealed #t))
|
||||
50
s/i3fb.def
Normal file
50
s/i3fb.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3fb.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3fb))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 4)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
50
s/i3le.def
Normal file
50
s/i3le.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3le.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3le))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 4)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
50
s/i3nb.def
Normal file
50
s/i3nb.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3nb.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3nb))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 4)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
51
s/i3nt.def
Normal file
51
s/i3nt.def
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
;;; i3nt.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3nt))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 16)
|
||||
(define-constant time-t-bits 64)
|
||||
(define-constant max-float-alignment 8)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant thread-handle-uptrs 1)
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor windows)
|
||||
50
s/i3ob.def
Normal file
50
s/i3ob.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3ob.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3ob))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 4)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
50
s/i3osx.def
Normal file
50
s/i3osx.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3osx.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3osx))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 4)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
50
s/i3qnx.def
Normal file
50
s/i3qnx.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3qnx.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3qnx))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 8)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 2)
|
||||
(features iconv expeditor)
|
||||
50
s/i3s2.def
Normal file
50
s/i3s2.def
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
;;; i3s2.def
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define-constant machine-type (constant machine-type-i3s2))
|
||||
(define-constant architecture 'x86)
|
||||
(define-constant address-bits 32)
|
||||
(define-constant ptr-bits 32)
|
||||
(define-constant int-bits 32)
|
||||
(define-constant short-bits 16)
|
||||
(define-constant long-bits 32)
|
||||
(define-constant long-long-bits 64)
|
||||
(define-constant size_t-bits 32)
|
||||
(define-constant ptrdiff_t-bits 32)
|
||||
(define-constant wchar-bits 32)
|
||||
(define-constant time-t-bits 32)
|
||||
(define-constant max-float-alignment 4)
|
||||
(define-constant max-integer-alignment 4)
|
||||
(define-constant asm-arg-reg-max 1)
|
||||
(define-constant asm-arg-reg-cnt 1)
|
||||
(define-constant typedef-ptr "void *")
|
||||
(define-constant typedef-iptr "int")
|
||||
(define-constant typedef-uptr "unsigned int")
|
||||
(define-constant typedef-i8 "char")
|
||||
(define-constant typedef-u8 "unsigned char")
|
||||
(define-constant typedef-i16 "short")
|
||||
(define-constant typedef-u16 "unsigned short")
|
||||
(define-constant typedef-i32 "int")
|
||||
(define-constant typedef-u32 "unsigned int")
|
||||
(define-constant typedef-i64 "long long")
|
||||
(define-constant typedef-u64 "unsigned long long")
|
||||
(define-constant typedef-string-char "unsigned int")
|
||||
(define-constant native-endianness 'little)
|
||||
(define-constant unaligned-floats #t)
|
||||
(define-constant unaligned-integers #t)
|
||||
(define-constant integer-divide-instruction #t)
|
||||
(define-constant software-floating-point #f)
|
||||
(define-constant segment-table-levels 1)
|
||||
(features iconv expeditor)
|
||||
2881
s/inspect.ss
Normal file
2881
s/inspect.ss
Normal file
File diff suppressed because it is too large
Load diff
713
s/interpret.ss
Normal file
713
s/interpret.ss
Normal file
|
|
@ -0,0 +1,713 @@
|
|||
;;; interpret.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;;; TODO
|
||||
;;; - recognize direct close calls in ip2 to avoid creation of closure
|
||||
;;; (but not closure pointer) and overhead of call
|
||||
;;; - handle let & letrec better
|
||||
;;; - use arg regs when available
|
||||
;;; - wire up letrec closures, then treat like let (good luck)
|
||||
;;; - optimize direct calls when no free vars
|
||||
;;; - since closure is just code in this case, can wire it in directly
|
||||
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
(include "expand-lang.ss")
|
||||
|
||||
(define-record-type c-var
|
||||
(fields (immutable id) (immutable parent) (mutable index) (mutable loc))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (id parent)
|
||||
(new id parent #f #f)))))
|
||||
|
||||
(define list-of-c-var?
|
||||
(lambda (x)
|
||||
(and (list? x) (andmap c-var? x))))
|
||||
|
||||
(define-language Linterp
|
||||
(extends Lsrc)
|
||||
(terminals
|
||||
(- ($prelex (x)))
|
||||
(+ (c-var (x))
|
||||
(list-of-c-var (free))))
|
||||
(Expr (e body rtd-expr)
|
||||
(- (case-lambda preinfo cl ...)
|
||||
(call preinfo e0 e1 ...)
|
||||
(moi)
|
||||
(pariah)
|
||||
(ref maybe-src x)
|
||||
(set! maybe-src x e)
|
||||
(profile src))
|
||||
(+ x
|
||||
(close free cl ...)
|
||||
(call e e* ...)
|
||||
(set! x e))))
|
||||
|
||||
(define ip1
|
||||
(let ()
|
||||
(define-record-type c-env
|
||||
(fields (immutable prev) (mutable vars))
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
(protocol
|
||||
(lambda (new)
|
||||
(lambda (prev)
|
||||
(new prev '())))))
|
||||
|
||||
(define-pass ip1 : Lsrc (ir) -> Linterp ()
|
||||
(definitions
|
||||
(define ip1-lambda
|
||||
(lambda (clauses env)
|
||||
(let ([env (make-c-env env)])
|
||||
(let ([bodies
|
||||
(map (lambda (clause)
|
||||
(nanopass-case (Lsrc CaseLambdaClause) clause
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(with-vars (vars x* env)
|
||||
(with-output-language (Linterp CaseLambdaClause)
|
||||
(let ([body (Expr body env)])
|
||||
`(clause (,vars ...) ,interface ,body))))]
|
||||
[else (errorf 'ip1-lambda "found something unexpected ~s\n" clause)]))
|
||||
clauses)])
|
||||
(with-output-language (Linterp Expr)
|
||||
`(close ,(ip1-free env) ,bodies ...))))))
|
||||
(define ip1-letrec
|
||||
(lambda (ids vals body env)
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define build-let
|
||||
(lambda (ids vals body)
|
||||
(if (null? ids)
|
||||
body
|
||||
`(call ,(make-preinfo)
|
||||
(case-lambda ,(make-preinfo-lambda)
|
||||
(clause (,ids ...) ,(length ids) ,body))
|
||||
,vals ...))))
|
||||
(Expr (if (null? ids)
|
||||
body
|
||||
(build-let ids (map (lambda (x) `(quote ,(void))) ids)
|
||||
(fold-left (lambda (body id val)
|
||||
(set-prelex-assigned! id #t)
|
||||
`(seq (set! #f ,id ,val) ,body))
|
||||
body ids vals)))
|
||||
env)))))
|
||||
(Expr : Expr (ir [env #f]) -> Expr ()
|
||||
[(ref ,maybe-src ,x) (ip1-lookup-lexical x env)]
|
||||
[(case-lambda ,preinfo ,cl* ...) (ip1-lambda cl* env)]
|
||||
[(call ,preinfo ,[e] ,[e*] ...) `(call ,e ,e* ...)]
|
||||
[(set! ,maybe-src ,x ,[e]) `(set! ,(ip1-lookup-lexical x env) ,e)]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (ip1-letrec x* e* body env)]
|
||||
[(seq ,[e1] ,[e2])
|
||||
(nanopass-case (Linterp Expr) e1
|
||||
[(quote ,d) e2]
|
||||
[else `(seq ,e1 ,e2)])]
|
||||
[(moi) `(quote #f)]
|
||||
[(pariah) `(quote ,(void))]
|
||||
[(profile ,src) `(quote ,(void))]))
|
||||
|
||||
;;; When we create a lex from a prelex, we replace the name field of
|
||||
;;; the prelex id with an initial mapping from environment to the lex
|
||||
;;; var corresponding to the prelex in the environment. This mapping is
|
||||
;;; augmented by lookup-lexical (for references through rebind-free
|
||||
;;; environments) and trimmed by maybe-free.
|
||||
|
||||
(define-syntax with-var
|
||||
(syntax-rules ()
|
||||
((_ (var idexp env) e1 e2 ...)
|
||||
(let ((id idexp))
|
||||
(let ((name (prelex-name id)))
|
||||
(let ((var (make-c-var id #f)))
|
||||
(prelex-name-set! id (list (cons env var)))
|
||||
(let ((tmp (begin e1 e2 ...)))
|
||||
; restore name to leave prelex undamaged; this is necessary at
|
||||
; present because syntax objects may contain the same prelexes
|
||||
; that arrive here as bound variables
|
||||
(prelex-name-set! id name)
|
||||
tmp)))))))
|
||||
|
||||
(define-syntax with-vars
|
||||
(syntax-rules ()
|
||||
((_ (vars idsexp env) e1 e2 ...)
|
||||
(let f ((ids (reverse idsexp)) (vars '()))
|
||||
(if (null? ids)
|
||||
(begin e1 e2 ...)
|
||||
(with-var (var (car ids) env)
|
||||
(f (cdr ids) (cons var vars))))))))
|
||||
|
||||
(define ip1-free
|
||||
(lambda (e)
|
||||
(map (lambda (id)
|
||||
(let ((ls (prelex-name id)))
|
||||
(prelex-name-set! id (cdr ls))
|
||||
(cdar ls)))
|
||||
(c-env-vars e))))
|
||||
|
||||
(define ip1-lookup-lexical
|
||||
(lambda (id e)
|
||||
(let ((ls (prelex-name id)))
|
||||
(if (eq? (caar ls) e)
|
||||
(cdar ls)
|
||||
(let ((y (ip1-lookup-lexical id (c-env-prev e))))
|
||||
(let ([z (make-c-var id y)])
|
||||
(c-env-vars-set! e (cons id (c-env-vars e)))
|
||||
(prelex-name-set! id (cons (cons e z) (prelex-name id)))
|
||||
z))))))
|
||||
|
||||
(lambda (x) (ip1 x))))
|
||||
|
||||
(define-syntactic-monad $rt a0 a1 fp cp)
|
||||
|
||||
(module (ip2)
|
||||
(define unexpected-loc
|
||||
(lambda (loc)
|
||||
($oops 'interpret-internal "unexpected loc ~s" loc)))
|
||||
|
||||
(define ip2
|
||||
(lambda (x)
|
||||
(define unexpected-record
|
||||
(lambda (x)
|
||||
($oops 'interpret-internal "unexpected record ~s" x)))
|
||||
(define non-procedure
|
||||
(lambda (x)
|
||||
($oops #f "attempt to apply non-procedure ~s" x)))
|
||||
(define unbound-or-non-procedure
|
||||
(lambda (sym x)
|
||||
(if ($unbound-object? x)
|
||||
($oops #f "variable ~:s is not bound" sym)
|
||||
(non-procedure x))))
|
||||
(define-syntax docall-sym
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ sym e1 ...)
|
||||
(with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))])
|
||||
#'($rt lambda ()
|
||||
(let ([t0 (#3%$top-level-value sym)] [t1 ($rt e1)] ...)
|
||||
(unless (procedure? t0) (unbound-or-non-procedure sym t0))
|
||||
(t0 t1 ...))))])))
|
||||
(define-syntax docall
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e0 e1 ...)
|
||||
(with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))])
|
||||
#'($rt lambda ()
|
||||
(let ([t0 e0] [t1 ($rt e1)] ...)
|
||||
(unless (procedure? t0) (non-procedure t0))
|
||||
(t0 t1 ...))))])))
|
||||
(define-syntax docallx
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ e0 e1 ...)
|
||||
(with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))])
|
||||
#'($rt lambda ()
|
||||
(let ([t0 ($rt e0)] [t1 ($rt e1)] ...)
|
||||
(unless (procedure? t0) (non-procedure t0))
|
||||
(t0 t1 ...))))])))
|
||||
(define ip2-fat-call
|
||||
(lambda (fun args)
|
||||
(let ((args (reverse args)))
|
||||
($rt lambda ()
|
||||
(let ((fun ($rt fun)))
|
||||
(let loop ([args args] [vals '()])
|
||||
(if (null? args)
|
||||
(begin
|
||||
(unless (procedure? fun) (non-procedure fun))
|
||||
(apply fun vals))
|
||||
(loop (cdr args) (cons ($rt (car args)) vals)))))))))
|
||||
(nanopass-case (Linterp Expr) x
|
||||
[,x
|
||||
(let ((loc (c-var-loc x)) (i (c-var-index x)))
|
||||
(if (prelex-assigned (c-var-id x))
|
||||
(case loc
|
||||
[(a0) ($rt lambda () (car a0))]
|
||||
[(a1) ($rt lambda () (car a1))]
|
||||
[(fp) ($rt lambda () (car fp))]
|
||||
[(cp) ($rt lambda () (car cp))]
|
||||
[(frame) ($rt lambda () (car (list-ref fp i)))]
|
||||
[(frame-rest) ($rt lambda () (car (list-tail fp i)))]
|
||||
[(closure) ($rt lambda () (car (vector-ref cp i)))]
|
||||
[else (unexpected-loc loc)])
|
||||
(case loc
|
||||
[(a0) ($rt lambda () a0)]
|
||||
[(a1) ($rt lambda () a1)]
|
||||
[(fp) ($rt lambda () fp)]
|
||||
[(cp) ($rt lambda () cp)]
|
||||
[(frame) ($rt lambda () (list-ref fp i))]
|
||||
[(frame-rest) ($rt lambda () (list-tail fp i))]
|
||||
[(closure) ($rt lambda () (vector-ref cp i))]
|
||||
[else (unexpected-loc loc)])))]
|
||||
[,pr (let ((fun ($top-level-value (primref-name pr))))
|
||||
($rt lambda () fun))]
|
||||
[(quote ,d) ($rt lambda () d)]
|
||||
[(close ,free ,cl* ...)
|
||||
(unless (null? free)
|
||||
(if (null? (cdr free))
|
||||
(c-var-loc-set! (car free) 'cp)
|
||||
(let loop ((free free) (i 0))
|
||||
(unless (null? free)
|
||||
(c-var-loc-set! (car free) 'closure)
|
||||
(c-var-index-set! (car free) i)
|
||||
(loop (cdr free) (fx+ i 1))))))
|
||||
(or (and (not (null? cl*))
|
||||
(null? (cdr cl*))
|
||||
(nanopass-case (Linterp CaseLambdaClause) (car cl*)
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(if (null? free)
|
||||
(case interface
|
||||
[(0)
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda ()
|
||||
($rt body ([a0 0] [a1 0] [fp 0] [cp 0])))))]
|
||||
[(1)
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0)
|
||||
($rt body ([a1 0] [fp 0] [cp 0])))))]
|
||||
[(2)
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0 a1)
|
||||
($rt body ([fp 0] [cp 0])))))]
|
||||
[(3)
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0 a1 fp)
|
||||
($rt body ([cp 0])))))]
|
||||
[(4)
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp cp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0 a1 fp cp)
|
||||
($rt body))))]
|
||||
[else #f])
|
||||
(case interface
|
||||
[(0)
|
||||
(ip2-closure free
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda ()
|
||||
($rt body ([a0 0] [a1 0] [fp 0]))))))]
|
||||
[(1)
|
||||
(ip2-closure free
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0)
|
||||
($rt body ([a1 0] [fp 0]))))))]
|
||||
[(2)
|
||||
(ip2-closure free
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0 a1)
|
||||
($rt body ([fp 0]))))))]
|
||||
[(3)
|
||||
(ip2-closure free
|
||||
(let ((body (ip2-body body x* '(a0 a1 fp) #f)))
|
||||
($rt lambda ()
|
||||
(lambda (a0 a1 fp)
|
||||
($rt body)))))]
|
||||
[else #f]))]))
|
||||
; we could use cp if no closure; we could use fp if max interface
|
||||
; is small enough. we don't bother with either presently.
|
||||
(let ((m (let min? ((cl* cl*) (m (length '(a0 a1))))
|
||||
(if (null? cl*)
|
||||
m
|
||||
(nanopass-case (Linterp CaseLambdaClause) (car cl*)
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(min? (cdr cl*)
|
||||
(min (if (fx< interface 0)
|
||||
(fx- -1 interface)
|
||||
interface)
|
||||
m))])))))
|
||||
(define adjust-interface
|
||||
(lambda (x)
|
||||
(if (fx< x 0)
|
||||
(fx+ x m)
|
||||
(fx- x m))))
|
||||
(let ((body (let f ((cl* cl*))
|
||||
(if (null? cl*)
|
||||
($rt lambda (args nargs)
|
||||
($oops #f "incorrect number of arguments to #<procedure>"))
|
||||
(nanopass-case (Linterp CaseLambdaClause) (car cl*)
|
||||
[(clause (,x* ...) ,interface ,body)
|
||||
(ip2-prelude
|
||||
(ip2-body body x* '(a0 a1)
|
||||
(fx< interface 0))
|
||||
(list-tail x* m)
|
||||
(list-tail '(a0 a1) m)
|
||||
(adjust-interface interface)
|
||||
(f (cdr cl*)))])))))
|
||||
(case m
|
||||
[(0)
|
||||
(ip2-closure free
|
||||
($rt lambda ()
|
||||
(lambda args
|
||||
($rt body ([a0 0] [a1 0] [fp 0]) args (length args)))))]
|
||||
[(1)
|
||||
(ip2-closure free
|
||||
($rt lambda ()
|
||||
(lambda (a0 . args)
|
||||
($rt body ([a1 0] [fp 0]) args (length args)))))]
|
||||
[(2)
|
||||
(ip2-closure free
|
||||
($rt lambda ()
|
||||
(lambda (a0 a1 . args)
|
||||
($rt body ([fp 0]) args (length args)))))]))))]
|
||||
[(set! ,x ,e)
|
||||
(let ((e (ip2 e)))
|
||||
(let ((loc (c-var-loc x)) (i (c-var-index x)))
|
||||
(case loc
|
||||
[(a0) ($rt lambda () (set-car! a0 ($rt e)))]
|
||||
[(a1) ($rt lambda () (set-car! a1 ($rt e)))]
|
||||
[(fp) ($rt lambda () (set-car! fp ($rt e)))]
|
||||
[(cp) ($rt lambda () (set-car! cp ($rt e)))]
|
||||
[(frame) ($rt lambda () (set-car! (list-ref fp i) ($rt e)))]
|
||||
[(frame-rest)
|
||||
($rt lambda () (set-car! (list-tail fp i) ($rt e)))]
|
||||
[(closure) ($rt lambda () (set-car! (vector-ref cp i) ($rt e)))]
|
||||
[else (unexpected-loc loc)])))]
|
||||
[(if ,e0 ,e1 ,e2)
|
||||
(let ((e0 (ip2 e0)) (e1 (ip2 e1)) (e2 (ip2 e2)))
|
||||
($rt lambda ()
|
||||
($rt (if ($rt e0) e1 e2))))]
|
||||
[(call ,e ,e* ...)
|
||||
(let ((e* (map (lambda (x) (ip2 x)) e*)))
|
||||
(or (nanopass-case (Linterp Expr) e
|
||||
[,pr
|
||||
(case (length e*)
|
||||
[(0)
|
||||
(let ((e ($top-level-value (primref-name pr))))
|
||||
($rt lambda () (e)))]
|
||||
[(1)
|
||||
(apply
|
||||
(lambda (x1)
|
||||
(let ((e ($top-level-value (primref-name pr))))
|
||||
($rt lambda () (e ($rt x1)))))
|
||||
e*)]
|
||||
[(2)
|
||||
(apply
|
||||
(lambda (x1 x2)
|
||||
(let ((e ($top-level-value (primref-name pr))))
|
||||
($rt lambda () (e ($rt x1) ($rt x2)))))
|
||||
e*)]
|
||||
[(3)
|
||||
(apply
|
||||
(lambda (x1 x2 x3)
|
||||
(let ((e ($top-level-value (primref-name pr))))
|
||||
($rt lambda ()
|
||||
(e ($rt x1) ($rt x2) ($rt x3)))))
|
||||
e*)]
|
||||
[else #f])]
|
||||
[(call ,e1 ,e1* ...)
|
||||
(nanopass-case (Linterp Expr) e1
|
||||
[,pr (and (eq? (primref-name pr) '$top-level-value)
|
||||
(fx= (length e*) 1)
|
||||
(nanopass-case (Linterp Expr) (car e1*)
|
||||
[(quote ,d)
|
||||
(and (symbol? d)
|
||||
(case (length e*)
|
||||
[(0) (docall-sym d)]
|
||||
[(1)
|
||||
(apply
|
||||
(lambda (x1)
|
||||
(docall-sym d x1))
|
||||
e*)]
|
||||
[(2)
|
||||
(apply
|
||||
(lambda (x1 x2)
|
||||
(docall-sym d x1 x2))
|
||||
e*)]
|
||||
[(3)
|
||||
(apply
|
||||
(lambda (x1 x2 x3)
|
||||
(docall-sym d x1 x2 x3))
|
||||
e*)]
|
||||
[else #f]))]
|
||||
[else #f]))]
|
||||
[else #f])]
|
||||
[else #f])
|
||||
(let ((e (ip2 e)))
|
||||
(case (length e*)
|
||||
[(0) (docallx e)]
|
||||
[(1)
|
||||
(apply
|
||||
(lambda (x1) (docallx e x1))
|
||||
e*)]
|
||||
[(2)
|
||||
(apply
|
||||
(lambda (x1 x2) (docallx e x1 x2))
|
||||
e*)]
|
||||
[(3)
|
||||
(apply
|
||||
(lambda (x1 x2 x3) (docallx e x1 x2 x3))
|
||||
e*)]
|
||||
[else (ip2-fat-call e e*)]))))]
|
||||
[(seq ,e1 ,e2)
|
||||
(let ((e1 (ip2 e1)) (e2 (ip2 e2)))
|
||||
($rt lambda () ($rt e1) ($rt e2)))]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
||||
(unless $compiler-is-loaded?
|
||||
($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded"))
|
||||
(let ([p ($compile-backend
|
||||
(let ((t (make-prelex* 'tmp)))
|
||||
(set-prelex-referenced! t #t)
|
||||
(with-output-language (Lsrc Expr)
|
||||
`(case-lambda ,(make-preinfo-lambda)
|
||||
(clause (,t) 1
|
||||
(foreign (,conv* ...) ,name (ref #f ,t)
|
||||
(,arg-type* ...) ,result-type))))))])
|
||||
(let ([e (ip2 e)])
|
||||
($rt lambda () ((p) ($rt e)))))]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
|
||||
(unless $compiler-is-loaded?
|
||||
($oops 'interpret "cannot compile foreign-callable: compiler is not loaded"))
|
||||
(let ([p ($compile-backend
|
||||
(let ((t (make-prelex* 'tmp)))
|
||||
(set-prelex-referenced! t #t)
|
||||
(with-output-language (Lsrc Expr)
|
||||
`(case-lambda ,(make-preinfo-lambda)
|
||||
(clause (,t) 1
|
||||
(fcallable (,conv* ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))])
|
||||
(let ([e (ip2 e)])
|
||||
($rt lambda () ((p) ($rt e)))))]
|
||||
[else (unexpected-record x)])))
|
||||
|
||||
(define ip2-prelude
|
||||
(lambda (body vars regs i next)
|
||||
(define set-args
|
||||
(lambda (vars regs body rest?)
|
||||
(if (null? regs)
|
||||
($rt lambda (args) ($rt body ([fp args])))
|
||||
(let ((reg (car regs)))
|
||||
(if (null? (cdr vars))
|
||||
(if rest?
|
||||
(case reg
|
||||
[(a0) ($rt lambda (args) ($rt body ([a0 args])))]
|
||||
[(a1) ($rt lambda (args) ($rt body ([a1 args])))]
|
||||
[(fp) ($rt lambda (args) ($rt body ([fp args])))]
|
||||
[(cp) ($rt lambda (args) ($rt body ([cp args])))]
|
||||
[else (unexpected-loc reg)])
|
||||
(case reg
|
||||
[(a0) ($rt lambda (args) ($rt body ([a0 (car args)])))]
|
||||
[(a1) ($rt lambda (args) ($rt body ([a1 (car args)])))]
|
||||
[(fp) ($rt lambda (args) ($rt body ([fp (car args)])))]
|
||||
[(cp) ($rt lambda (args) ($rt body ([cp (car args)])))]
|
||||
[else (unexpected-loc reg)]))
|
||||
(let ((body (set-args (cdr vars) (cdr regs) body rest?)))
|
||||
(case reg
|
||||
[(a0) ($rt lambda (args)
|
||||
($rt body ([a0 (car args)]) (cdr args)))]
|
||||
[(a1) ($rt lambda (args)
|
||||
($rt body ([a1 (car args)]) (cdr args)))]
|
||||
[(fp) ($rt lambda (args)
|
||||
($rt body ([fp (car args)]) (cdr args)))]
|
||||
[(cp) ($rt lambda (args)
|
||||
($rt body ([cp (car args)]) (cdr args)))]
|
||||
[else (unexpected-loc reg)])))))))
|
||||
(if (fx>= i 0)
|
||||
(if (fx= i 0)
|
||||
($rt lambda (args nargs)
|
||||
(if (fx= nargs 0)
|
||||
($rt body)
|
||||
($rt next () args nargs)))
|
||||
(let ((body (set-args vars regs body #f)))
|
||||
($rt lambda (args nargs)
|
||||
(if (fx= nargs i)
|
||||
($rt body () args)
|
||||
($rt next () args nargs)))))
|
||||
(let ((body (set-args vars regs body #t)))
|
||||
(if (fx= i -1)
|
||||
($rt lambda (args nargs) ($rt body () args))
|
||||
(let ((i (fx- -1 i)))
|
||||
($rt lambda (args nargs)
|
||||
(if (fx>= nargs i)
|
||||
($rt body () args)
|
||||
($rt next () args nargs)))))))))
|
||||
|
||||
(define ip2-closure
|
||||
(lambda (free code)
|
||||
(let ([free (map (lambda (var)
|
||||
(let* ((var (c-var-parent var))
|
||||
(loc (c-var-loc var))
|
||||
(i (c-var-index var)))
|
||||
(case loc
|
||||
[(a0) ($rt lambda () a0)]
|
||||
[(a1) ($rt lambda () a1)]
|
||||
[(fp) ($rt lambda () fp)]
|
||||
[(cp) ($rt lambda () cp)]
|
||||
[(frame) ($rt lambda () (list-ref fp i))]
|
||||
[(frame-rest) ($rt lambda () (list-tail fp i))]
|
||||
[(closure) ($rt lambda () (vector-ref cp i))]
|
||||
[else (unexpected-loc loc)])))
|
||||
free)])
|
||||
(let ((nfree (length free)))
|
||||
(case nfree
|
||||
[(0) ($rt lambda () ($rt code ([cp 0])))]
|
||||
[(1)
|
||||
(apply
|
||||
(lambda (x1)
|
||||
($rt lambda () ($rt code ([cp ($rt x1)]))))
|
||||
free)]
|
||||
[(2)
|
||||
(apply
|
||||
(lambda (x1 x2)
|
||||
($rt lambda ()
|
||||
($rt code ([cp (vector ($rt x1) ($rt x2))]))))
|
||||
free)]
|
||||
[(3)
|
||||
(apply
|
||||
(lambda (x1 x2 x3)
|
||||
($rt lambda ()
|
||||
($rt code ([cp (vector ($rt x1) ($rt x2) ($rt x3))]))))
|
||||
free)]
|
||||
[(4)
|
||||
(apply
|
||||
(lambda (x1 x2 x3 x4)
|
||||
($rt lambda ()
|
||||
($rt code ([cp (vector ($rt x1) ($rt x2) ($rt x3) ($rt x4))]))))
|
||||
free)]
|
||||
[else
|
||||
($rt lambda ()
|
||||
(let ((v (make-vector nfree ($rt (car free)))))
|
||||
(do ((i 1 (fx+ i 1)) (free (cdr free) (cdr free)))
|
||||
((null? free))
|
||||
(vector-set! v i ($rt (car free))))
|
||||
($rt code ([cp v]))))])))))
|
||||
|
||||
(define ip2-body
|
||||
(lambda (body invars regs rest?)
|
||||
; set locations
|
||||
(let loop ((vars invars) (regs regs) (i 0))
|
||||
(cond
|
||||
[(null? vars)
|
||||
; process the body and wrap in consers for assigned variables
|
||||
(do ((vars invars (cdr vars))
|
||||
(body (ip2 body)
|
||||
(let ((var (car vars)))
|
||||
(if (prelex-assigned (c-var-id var))
|
||||
(case (c-var-loc var)
|
||||
[(a0)
|
||||
($rt lambda ()
|
||||
($rt body ([a0 (cons a0 (void))])))]
|
||||
[(a1)
|
||||
($rt lambda ()
|
||||
($rt body ([a1 (cons a1 (void))])))]
|
||||
[(fp)
|
||||
($rt lambda ()
|
||||
($rt body ([fp (cons fp (void))])))]
|
||||
[(cp)
|
||||
($rt lambda ()
|
||||
($rt body ([cp (cons cp (void))])))]
|
||||
[(frame)
|
||||
(let ((i (c-var-index var)))
|
||||
($rt lambda ()
|
||||
(let ((ls (list-tail fp i)))
|
||||
(set-car! ls (cons (car ls) (void))))
|
||||
($rt body)))]
|
||||
[(frame-rest)
|
||||
(let ((i (fx- (c-var-index var) 1)))
|
||||
($rt lambda ()
|
||||
(let ((ls (list-tail fp i)))
|
||||
(set-cdr! ls (cons (cdr ls) (void))))
|
||||
($rt body)))])
|
||||
body))))
|
||||
((null? vars) body))]
|
||||
[(not (null? regs))
|
||||
(c-var-loc-set! (car vars) (car regs))
|
||||
(loop (cdr vars) (cdr regs) i)]
|
||||
[(and rest? (null? (cdr vars)))
|
||||
(cond
|
||||
[(fx= i 0)
|
||||
; using fp here instead of the equivalent frame-rest[0]
|
||||
; eliminates need for special-casing frame-rest[0] elsewhere.
|
||||
(c-var-loc-set! (car vars) 'fp)
|
||||
(loop (cdr vars) regs i)]
|
||||
[else
|
||||
(c-var-loc-set! (car vars) 'frame-rest)
|
||||
(c-var-index-set! (car vars) i)
|
||||
(loop (cdr vars) regs (fx+ i 1))])]
|
||||
[else
|
||||
(c-var-loc-set! (car vars) 'frame)
|
||||
(c-var-index-set! (car vars) i)
|
||||
(loop (cdr vars) regs (fx+ i 1))])))))
|
||||
|
||||
(define-pass interpret-Lexpand : Lexpand (ir situation for-import? importer ofn eoo) -> * (val)
|
||||
(definitions
|
||||
(define (ibeval x1)
|
||||
($rt (parameterize ([$target-machine (machine-type)] [$sfd #f])
|
||||
(let* ([x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))]
|
||||
[x2a (let ([cpletrec-ran? #f])
|
||||
(let ([x ((run-cp0)
|
||||
(lambda (x)
|
||||
(set! cpletrec-ran? #t)
|
||||
(let ([x ($pass-time 'cp0 (lambda () ($cp0 x #f)))])
|
||||
($pass-time 'cpletrec
|
||||
(lambda () ($cpletrec x)))))
|
||||
x2)])
|
||||
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
|
||||
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
|
||||
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
|
||||
(when eoo (pretty-print ($uncprep x2b) eoo))
|
||||
(let ([x ($pass-time 'ip1 (lambda () (ip1 x2b)))])
|
||||
($pass-time 'ip2 (lambda () (ip2 x))))))
|
||||
([a0 0] [a1 0] [fp 0] [cp 0]))))
|
||||
(Inner : Inner (ir) -> * (val)
|
||||
[,lsrc (ibeval lsrc)]
|
||||
[(program ,uid ,body)
|
||||
(ibeval ($build-invoke-program uid body))]
|
||||
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
|
||||
(ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))]
|
||||
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
|
||||
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
|
||||
[(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? importer ofn)]
|
||||
[(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? importer ofn)]
|
||||
[(program-info ,pinfo) ($install-program-desc pinfo)]
|
||||
[else (sorry! who "unexpected language form ~s" ir)])
|
||||
(Outer : Outer (ir) -> * (val)
|
||||
; can't use cata since (Outer outer1) might return 0 or more than one value
|
||||
[(group ,outer1 ,outer2) (Outer outer1) (Outer outer2)]
|
||||
[(visit-only ,inner) (unless (eq? situation 'revisit) (Inner inner))]
|
||||
[(revisit-only ,inner) (unless (eq? situation 'visit) (Inner inner))]
|
||||
[(recompile-info ,rcinfo) (void)]
|
||||
[,inner (Inner inner)]
|
||||
[else (sorry! who "unexpected language form ~s" ir)])
|
||||
(Outer ir))
|
||||
|
||||
(set! interpret
|
||||
(rec interpret
|
||||
(case-lambda
|
||||
[(x)
|
||||
(interpret x
|
||||
(if (eq? (subset-mode) 'system)
|
||||
($system-environment)
|
||||
(interaction-environment)))]
|
||||
[(x0 env-spec)
|
||||
(unless (environment? env-spec) ($oops 'interpret "~s is not an environment" env-spec))
|
||||
(let ([x1 ($pass-time 'expand
|
||||
(lambda ()
|
||||
(parameterize ([$target-machine (machine-type)] [$sfd #f])
|
||||
(expand x0 env-spec #t))))])
|
||||
($uncprep x1 #t) ; populate preinfo sexpr fields
|
||||
(when (and (expand-output) (not ($noexpand? x0)))
|
||||
(pretty-print ($uncprep x1) (expand-output)))
|
||||
(interpret-Lexpand x1 'load #f #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))])))
|
||||
|
||||
(set! $interpret-backend
|
||||
(lambda (x situation for-import? importer ofn)
|
||||
(interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output))))
|
||||
(current-eval interpret)
|
||||
)
|
||||
|
||||
185
s/io-types.ss
Normal file
185
s/io-types.ss
Normal file
|
|
@ -0,0 +1,185 @@
|
|||
;;; io-types.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
#|
|
||||
In order to be thread safe, size must be zero and the handler procedures
|
||||
must obtain the tc-mutex or use some other mechanism to guarantee mutual
|
||||
exclusion while manipulating the buffer.
|
||||
|
||||
The built-in handlers for binary file output ports are thread-safe iff
|
||||
the buffer mode is none. The handlers for input ports are not thread-safe,
|
||||
since the buffer size may be non-zero to handle lookahead and ungetting.
|
||||
|
||||
In order to be safe for continuation-based multitasking, the buffer must
|
||||
be manipulated only by inline code (which runs between interrupt traps) or
|
||||
within a critical section. The built-in file handlers are task-safe, but
|
||||
the handlers for custom ports and for bytevector ports are not.
|
||||
|
||||
In general caller will check immutable properties of inputs but the
|
||||
handler must check mutable properties of inputs because other threads may
|
||||
change those properties. For example, handlers need not check the types
|
||||
of most input values (e.g., ports, octets, bytevectors) but do have to
|
||||
check for closed ports. (Position and length arguments are an exception,
|
||||
since they may vary by kind of port.) Furthermore, handlers, including put
|
||||
and get, should not expect the buffer to be full or empty when they are
|
||||
called, since in general this cannot be guaranteed if multiple tasks or
|
||||
threads are running. On the other hand, handlers generally won't be
|
||||
called for every operation on a port, since data is usually inserted into
|
||||
or taken from the buffer when appropriate.
|
||||
|
||||
To indicate an input buffer containing an #!eof object, handlers should
|
||||
set the input size empty and set the port-eof-flag.
|
||||
|
||||
Handler fields for unsupported operations should be set to #f. The others
|
||||
must be procedures. All port handlers must supply a procedure for
|
||||
close-port. Input port handlers must supply procedures for ready?,
|
||||
lookahead, unget, get, and get-some. Output port handlers must supply
|
||||
procedures for put, put-some, and flush.
|
||||
|
||||
For port-position, set-port-position!, port-nonblocking?,
|
||||
set-port-nonblocking!, port-length, and set-port-length!, the
|
||||
corresponding "port-has" predicate will return true iff a procedure is
|
||||
supplied. These procedures must take into account input and output
|
||||
buffers as appropriate. Positions must be byte counts for binary ports
|
||||
(see R6RS). For output ports handler must flush the port on "set" (see
|
||||
R6RS), and for input port handler must clear the buffer on "set" if
|
||||
needed.
|
||||
|
||||
The get-some and put-some procedures should not block on nonblocking
|
||||
ports, but should instead return 0 to indicate that no data was written or
|
||||
read. Exception: if a textual output port is line-buffered and the
|
||||
string passed to put-some contains an eol character, put-some must
|
||||
flush at least to the last eol character.
|
||||
|
||||
The close-port procedure must flush the output buffer as appropriate, set
|
||||
the buffer size(s) to zero, clear the port-eof flag, and mark the port
|
||||
closed.
|
||||
|#
|
||||
|
||||
(define-syntax define-port-handler
|
||||
(lambda (x)
|
||||
(syntax-case x (->)
|
||||
[(_ (?record-name ?constructor-name ?pred-name) uid
|
||||
(?field ?param ... -> ?result) ...)
|
||||
(or (not (datum uid)) (identifier? #'uid))
|
||||
#`(begin
|
||||
(define-record-type (?record-name mph ?pred-name)
|
||||
#,(if (datum uid) #'(nongenerative uid) #'(nongenerative))
|
||||
(opaque #t)
|
||||
(sealed #t)
|
||||
(fields (immutable ?field) ...))
|
||||
(define-syntax ?constructor-name
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ [?name ?expr] (... ...))
|
||||
(begin
|
||||
(let loop ([field* '(?field ...)] [name* #'(?name (... ...))])
|
||||
(if (null? field*)
|
||||
(unless (null? name*)
|
||||
(syntax-error (car name*) "unexpected"))
|
||||
(if (null? name*)
|
||||
(syntax-error x (format "missing ~s" (car field*)))
|
||||
(if (eq? (syntax->datum (car name*)) (car field*))
|
||||
(loop (cdr field*) (cdr name*))
|
||||
(syntax-error (car name*) "unexpected")))))
|
||||
(for-each
|
||||
(lambda (name p expr)
|
||||
(unless (p expr)
|
||||
(syntax-error expr (format "invalid ~s ~s rhs syntax" (datum ?constructor-name) (syntax->datum name)))))
|
||||
#'(?name (... ...))
|
||||
(list
|
||||
(lambda (expr)
|
||||
(syntax-case expr (lambda)
|
||||
[(lambda (?param ...) . body) #t]
|
||||
[(lambda . rest) #f]
|
||||
[_ #t]))
|
||||
...)
|
||||
#'(?expr (... ...)))
|
||||
#'(mph ?expr (... ...)))]))))])))
|
||||
|
||||
;; The following input types are guaranteed upon reaching a handler:
|
||||
;; who: symbol
|
||||
;; bool: any object
|
||||
;; p: input, output, or input/output port as appropriate
|
||||
;; elt (binary port): exact nonnegative integer <= 255
|
||||
;; elt (textual port): character
|
||||
;; elt/eof: elt or #!eof
|
||||
;; bv: bytevector
|
||||
;; start, count: exact nonnegative integer
|
||||
;;
|
||||
;; Also: start + count <= length(bv).
|
||||
;;
|
||||
;; The types of pos and len are port-specific and must be checked by
|
||||
;; the handler
|
||||
|
||||
;; Handlers are responsible for returning appropriate values:
|
||||
;; bool: any object
|
||||
;; elt (binary port): exact nonnegative integer <= 255
|
||||
;; elt (textual port): character
|
||||
;; elt/eof: elt or eof
|
||||
;; count: exact nonnegative integer
|
||||
;; count/eof: count or eof
|
||||
;; pos (binary port): exact nonnegative integer
|
||||
;; pos (textual port): any object
|
||||
;; len (binary port): exact nonnegative integer
|
||||
;; len (textual port): any object
|
||||
;;
|
||||
;; Also: output count must be less than or equal to input count.
|
||||
|
||||
; exporting all but port-handler, since it conflicts with the
|
||||
; primtiive named port-handler
|
||||
(module (make-port-handler port-handler? port-handler-ready?
|
||||
port-handler-lookahead port-handler-unget
|
||||
port-handler-get port-handler-get-some
|
||||
port-handler-clear-input port-handler-put
|
||||
port-handler-put-some port-handler-flush
|
||||
port-handler-clear-output port-handler-close-port
|
||||
port-handler-port-position
|
||||
port-handler-set-port-position!
|
||||
port-handler-port-length
|
||||
port-handler-set-port-length!
|
||||
port-handler-port-nonblocking?
|
||||
port-handler-set-port-nonblocking!)
|
||||
(define-port-handler (port-handler make-port-handler port-handler?) #{port-handler cx3umjhy9nkkuqku-a}
|
||||
; input:
|
||||
(ready? who p -> bool)
|
||||
(lookahead who p -> elt/eof)
|
||||
(unget who p elt/eof -> void)
|
||||
(get who p -> elt/eof)
|
||||
(get-some who p bv start count -> count/eof)
|
||||
(clear-input who p -> void)
|
||||
|
||||
; output:
|
||||
(put who p elt -> void)
|
||||
(put-some who p bv start count -> count)
|
||||
(flush who p -> void)
|
||||
(clear-output who p -> void)
|
||||
|
||||
; all:
|
||||
(close-port who p -> void)
|
||||
|
||||
; optional:
|
||||
(port-position who p -> pos)
|
||||
(set-port-position! who p pos -> void)
|
||||
(port-length who p -> len)
|
||||
(set-port-length! who p len -> void)
|
||||
(port-nonblocking? who p -> bool)
|
||||
(set-port-nonblocking! who p bool -> void)))
|
||||
|
||||
;;; max-*-copy is the maximum amount a bytevector put operation will copy
|
||||
;;; from the supplied bytevector to the port's buffer. beyond this amount
|
||||
;;; it will get/send contents directly from/to the underlying source/sink.
|
||||
(define max-put-copy 256)
|
||||
(define max-get-copy 256)
|
||||
111
s/layout.ss
Normal file
111
s/layout.ss
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
;;; layout.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define compute-field-offsets
|
||||
; type-disp is the offset from the ptr to the object's true address
|
||||
; ls is a list of field descriptors
|
||||
(lambda (who type-disp ls)
|
||||
(define parse-field
|
||||
(lambda (f)
|
||||
(define supported-type
|
||||
(lambda (x)
|
||||
(let ([x (filter-foreign-type x)])
|
||||
(and (memq x (record-datatype list)) x))))
|
||||
(define (err) ($oops who "invalid field specifier ~s" f))
|
||||
(define (s0 f)
|
||||
(cond
|
||||
[(symbol? f) (values f #t 'scheme-object 'scheme-object 1)]
|
||||
[(list? f) (s1 f)]
|
||||
[else (err)]))
|
||||
(define (s1 f)
|
||||
(cond
|
||||
[(null? f) (err)]
|
||||
[(null? (cdr f))
|
||||
(if (symbol? (car f))
|
||||
(values (car f) #t 'scheme-object 'scheme-object 1)
|
||||
(err))]
|
||||
[(eq? (car f) 'immutable) (s2 (cdr f) #f)]
|
||||
[(eq? (car f) 'mutable) (s2 (cdr f) #t)]
|
||||
[else (s2 f #t)]))
|
||||
(define (s2 f mutable?)
|
||||
(cond
|
||||
[(null? f) (err)]
|
||||
[(null? (cdr f))
|
||||
(if (symbol? (car f))
|
||||
(values (car f) mutable? 'scheme-object 'scheme-object 1)
|
||||
(err))]
|
||||
[(supported-type (car f)) =>
|
||||
(lambda (real-type) (s3 (cdr f) mutable? (car f) real-type))]
|
||||
[else (s3 f mutable? 'scheme-object 'scheme-object)]))
|
||||
(define (s3 f mutable? type real-type)
|
||||
(cond
|
||||
[(null? f) (err)]
|
||||
[(symbol? (car f)) (s4 (cdr f) mutable? type real-type (car f))]
|
||||
[else (err)]))
|
||||
(define (s4 f mutable? type real-type name)
|
||||
(cond
|
||||
[(null? f) (values name mutable? type real-type 1)]
|
||||
[(and (integer? (car f)) (nonnegative? (car f)))
|
||||
(values name mutable? type real-type (car f))]
|
||||
[else (err)]))
|
||||
(s0 f)))
|
||||
(define type->bytes
|
||||
(lambda (ty)
|
||||
(define-syntax ->bytes
|
||||
(syntax-rules () ((_ type bytes pred) bytes)))
|
||||
(record-datatype cases ty ->bytes
|
||||
($oops who "unrecognized type ~s" ty))))
|
||||
(define get-max-alignment
|
||||
(lambda (ty)
|
||||
(case ty
|
||||
[(single-float double-float) (constant max-float-alignment)]
|
||||
[else (constant max-integer-alignment)])))
|
||||
(define align
|
||||
(lambda (n bytes type)
|
||||
(let ([k (gcd (get-max-alignment type) bytes)])
|
||||
(logand (+ n (fx- k 1)) (fx- k)))))
|
||||
(with-values
|
||||
(let f ((ls ls) (byte 0))
|
||||
(if (null? ls)
|
||||
(values 0 0 '() byte) ; pm, mpm, flds, size
|
||||
(with-values (parse-field (car ls))
|
||||
(lambda (name mutable? type real-type len)
|
||||
(let* ((bytes (type->bytes real-type))
|
||||
; align even if len is zero to give element its
|
||||
; proper alignment, since zero at the end can mean
|
||||
; variable-length
|
||||
(byte (align byte bytes real-type)))
|
||||
(with-values (f (cdr ls) (+ byte (* bytes len)))
|
||||
(lambda (pm mpm flds size)
|
||||
(let ((flds (cons (make-fld name mutable? type (+ type-disp byte)) flds)))
|
||||
(if (eq? real-type 'scheme-object)
|
||||
(let ((m (ash (- (ash 1 len) 1)
|
||||
(fxsrl byte (constant log2-ptr-bytes)))))
|
||||
(values
|
||||
(+ pm m)
|
||||
(if mutable? (+ mpm m) mpm)
|
||||
flds
|
||||
size))
|
||||
(values pm mpm flds size))))))))))
|
||||
(lambda (pm mpm flds size)
|
||||
(define sanitize-mask
|
||||
; if bits are set for each word, return mask of -1
|
||||
; to give gc a quick test for pure vs. impure
|
||||
(lambda (m size)
|
||||
(if (= (- (ash 1 (quotient (+ size -1 (constant ptr-bytes)) (constant ptr-bytes))) 1) m)
|
||||
-1
|
||||
m)))
|
||||
(values (sanitize-mask pm size) mpm flds size)))))
|
||||
|
||||
1637
s/library.ss
Normal file
1637
s/library.ss
Normal file
File diff suppressed because it is too large
Load diff
769
s/mathprims.ss
Normal file
769
s/mathprims.ss
Normal file
|
|
@ -0,0 +1,769 @@
|
|||
;;; mathprims.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
;;; you may not use this file except in compliance with the License.
|
||||
;;; You may obtain a copy of the License at
|
||||
;;;
|
||||
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;;;
|
||||
;;; Unless required by applicable law or agreed to in writing, software
|
||||
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(eval-when (compile)
|
||||
|
||||
(define-syntax define-relop
|
||||
(syntax-rules ()
|
||||
[(_ name pred? err not-nan?)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%name x1 x2)]
|
||||
[(x1 x2 x3) (if (#2%name x1 x2) (#2%name x2 x3) (begin (#2%name x2 x3) #f))]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||||
(if (#2%name x1 x2)
|
||||
(or (null? rest) (loop x2 (car rest) (cdr rest)))
|
||||
(let loop ([rest rest])
|
||||
(cond
|
||||
[(null? rest) #f]
|
||||
[(pred? (car rest)) (loop (cdr rest))]
|
||||
[else (err 'name (car rest))]))))]
|
||||
[(x1)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(#3%not-nan? x1)]))]))
|
||||
|
||||
(define-syntax define-r6rs-relop ; requires 2+ arguments
|
||||
(syntax-rules ()
|
||||
[(_ name pred? err)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%name x1 x2)]
|
||||
[(x1 x2 x3) (if (#2%name x1 x2) (#2%name x2 x3) (begin (#2%name x2 x3) #f))]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||||
(if (#2%name x1 x2)
|
||||
(or (null? rest) (loop x2 (car rest) (cdr rest)))
|
||||
(let loop ([rest rest])
|
||||
(cond
|
||||
[(null? rest) #f]
|
||||
[(pred? (car rest)) (loop (cdr rest))]
|
||||
[else (err 'name (car rest))]))))]))]))
|
||||
|
||||
(define-syntax define-addop
|
||||
(syntax-rules ()
|
||||
[(_ name)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%name x1 x2)]
|
||||
[(x1 x2 x3) (#2%name (#2%name x1 x2) x3)]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||||
(let ([x (#2%name x1 x2)])
|
||||
(if (null? rest) x (loop x (car rest) (cdr rest)))))]
|
||||
[(x1) (#2%name x1)]
|
||||
[() (#2%name)]))]))
|
||||
|
||||
(define-syntax define-subop
|
||||
(syntax-rules ()
|
||||
[(_ name pred? err)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%name x1 x2)]
|
||||
[(x1 x2 x3) (#2%name (#2%name x1 x2) x3)]
|
||||
[(x1) (#2%name x1)]
|
||||
[(x0 x1 . rest)
|
||||
(unless (pred? x0) (err 'name x0))
|
||||
(let loop ([x0 x0] [x1 x1] [rest rest])
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(if (null? rest)
|
||||
(#3%name x0 x1)
|
||||
(loop (#3%name x0 x1) (car rest) (cdr rest))))]))]))
|
||||
|
||||
(define-syntax define-generic-subop
|
||||
(syntax-rules ()
|
||||
[(_ name)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%name x1 x2)]
|
||||
[(x1 x2 x3) (#2%name (#2%name x1 x2) x3)]
|
||||
[(x1) (#2%name x1)]
|
||||
[(x0 x1 . rest)
|
||||
(let loop ([x0 x0] [x1 x1] [rest rest])
|
||||
(if (null? rest)
|
||||
(#2%name x0 x1)
|
||||
(loop (#2%name x0 x1) (car rest) (cdr rest))))]))]))
|
||||
|
||||
(define-syntax define-cfl-relop
|
||||
(syntax-rules ()
|
||||
[(_ name pred? err not-nan?)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(#3%name x1 x2)]
|
||||
[(x1 x2 x3)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(unless (pred? x3) (err 'name x3))
|
||||
(and (#3%name x1 x2) (#3%name x2 x3))]
|
||||
[(x1 x2 . rest)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(if (#3%name x1 x2)
|
||||
(or (null? rest) (loop x2 (car rest) (cdr rest)))
|
||||
(let loop ([rest rest])
|
||||
(cond
|
||||
[(null? rest) #f]
|
||||
[(pred? (car rest)) (loop (cdr rest))]
|
||||
[else (err 'name (car rest))]))))]
|
||||
[(x1)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(not-nan? x1)]))]))
|
||||
|
||||
(define-syntax define-cfl-addop
|
||||
(syntax-rules ()
|
||||
[(_ name pred? err)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(#3%name x1 x2)]
|
||||
[(x1 x2 x3)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(unless (pred? x3) (err 'name x3))
|
||||
(#3%name (#3%name x1 x2) x3)]
|
||||
[(x1 x2 . rest)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(let loop ([x1 x1] [x2 x2] [rest rest])
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(let ([x (#3%name x1 x2)])
|
||||
(if (null? rest) x (loop x (car rest) (cdr rest)))))]
|
||||
[(x1)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(#3%name x1)]
|
||||
[() (name)]))]))
|
||||
|
||||
(define-syntax define-cfl-subop
|
||||
(syntax-rules ()
|
||||
[(_ name pred? err)
|
||||
(set! name
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(#3%name x1 x2)]
|
||||
[(x1 x2 x3)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(unless (pred? x2) (err 'name x2))
|
||||
(unless (pred? x3) (err 'name x3))
|
||||
(#3%name (#3%name x1 x2) x3)]
|
||||
[(x1)
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(#3%name x1)]
|
||||
[(x0 x1 . rest)
|
||||
(unless (pred? x0) (err 'name x0))
|
||||
(let loop ([x0 x0] [x1 x1] [rest rest])
|
||||
(unless (pred? x1) (err 'name x1))
|
||||
(if (null? rest)
|
||||
(#3%name x0 x1)
|
||||
(loop (#3%name x0 x1) (car rest) (cdr rest))))]))]))
|
||||
)
|
||||
|
||||
(define 1- (lambda (x) (#2%1- x)))
|
||||
|
||||
(define 1+ (lambda (x) (#2%1+ x)))
|
||||
|
||||
(define sub1 (lambda (x) (#2%sub1 x)))
|
||||
|
||||
(define -1+ (lambda (x) (#2%-1+ x)))
|
||||
|
||||
(define add1 (lambda (x) (#2%add1 x)))
|
||||
|
||||
(define-addop +)
|
||||
(define-generic-subop -)
|
||||
(define-addop *)
|
||||
(define-generic-subop /)
|
||||
|
||||
(define-addop logand)
|
||||
(define-addop bitwise-and)
|
||||
(define-addop logior)
|
||||
(define-addop bitwise-ior)
|
||||
(define-addop logor)
|
||||
(define-addop logxor)
|
||||
(define-addop bitwise-xor)
|
||||
|
||||
(define (lognot x) (#2%lognot x))
|
||||
(define (bitwise-not x) (#2%bitwise-not x))
|
||||
|
||||
(define (logbit? x y) (#2%logbit? x y))
|
||||
(define (bitwise-bit-set? x y) (#2%bitwise-bit-set? x y))
|
||||
(define (logbit0 x y) (#2%logbit0 x y))
|
||||
(define (logbit1 x y) (#2%logbit1 x y))
|
||||
(define (logtest x y) (#2%logtest x y))
|
||||
|
||||
(eval-when (compile)
|
||||
(define-syntax define-number-relop
|
||||
(syntax-rules ()
|
||||
[(_ name)
|
||||
(define name
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%name x1 x2)]
|
||||
[(x1 x2 x3) (if (#2%name x1 x2) (#2%name x2 x3) (begin (#2%name x2 x3) #f))]
|
||||
[(x1) (begin (#2%name x1 0) #t)]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [ls rest])
|
||||
(if (or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||||
(#2%name x1 x2)
|
||||
(begin (#2%name x1 x2) #f)))]))])))
|
||||
|
||||
(define-number-relop =)
|
||||
(define-number-relop <)
|
||||
(define-number-relop >)
|
||||
(define-number-relop <=)
|
||||
(define-number-relop >=)
|
||||
|
||||
(eval-when (compile)
|
||||
(define-syntax define-r6rs-number-relop ; requires 2+ argument
|
||||
(syntax-rules ()
|
||||
[(_ r6rs:name name)
|
||||
(define-who #(r6rs: name)
|
||||
(case-lambda
|
||||
[(x1 x2) (#2%r6rs:name x1 x2)]
|
||||
[(x1 x2 x3) (if (#2%r6rs:name x1 x2)
|
||||
(#2%r6rs:name x2 x3)
|
||||
(begin (#2%r6rs:name x2 x3) #f))]
|
||||
[(x1 x2 . rest)
|
||||
(let loop ([x1 x1] [x2 x2] [ls rest])
|
||||
(if (or (null? ls) (loop x2 (car ls) (cdr ls)))
|
||||
(#2%r6rs:name x1 x2)
|
||||
(begin (#2%r6rs:name x1 x2) #f)))]))])))
|
||||
|
||||
(define-r6rs-number-relop r6rs:= =)
|
||||
(define-r6rs-number-relop r6rs:< <)
|
||||
(define-r6rs-number-relop r6rs:> >)
|
||||
(define-r6rs-number-relop r6rs:<= <=)
|
||||
(define-r6rs-number-relop r6rs:>= >=)
|
||||
|
||||
(eval-when (compile) (optimize-level 3))
|
||||
|
||||
(let ()
|
||||
(define flargerr
|
||||
(lambda (who x)
|
||||
($oops who "~s is not a flonum" x)))
|
||||
|
||||
(set! fl-make-rectangular
|
||||
(lambda (x y)
|
||||
(unless (flonum? x) (flargerr 'fl-make-rectangular x))
|
||||
(unless (flonum? y) (flargerr 'fl-make-rectangular y))
|
||||
(#3%fl-make-rectangular x y)))
|
||||
|
||||
(define-addop fl+)
|
||||
(define-subop fl- flonum? flargerr)
|
||||
(define-addop fl*)
|
||||
(define-subop fl/ flonum? flargerr)
|
||||
|
||||
(set! flabs
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr 'flabs x))
|
||||
(#3%flabs x)))
|
||||
|
||||
(set! flround
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr 'flround x))
|
||||
(#3%flround x)))
|
||||
|
||||
(set! fllp
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr 'fllp x))
|
||||
(#3%fllp x)))
|
||||
|
||||
(define-relop fl= flonum? flargerr fl=)
|
||||
(define-relop fl< flonum? flargerr fl=)
|
||||
(define-relop fl> flonum? flargerr fl=)
|
||||
(define-relop fl<= flonum? flargerr fl=)
|
||||
(define-relop fl>= flonum? flargerr fl=)
|
||||
(define-r6rs-relop fl=? flonum? flargerr)
|
||||
(define-r6rs-relop fl<? flonum? flargerr)
|
||||
(define-r6rs-relop fl>? flonum? flargerr)
|
||||
(define-r6rs-relop fl<=? flonum? flargerr)
|
||||
(define-r6rs-relop fl>=? flonum? flargerr)
|
||||
|
||||
(set-who! $fleqv?
|
||||
(lambda (x y)
|
||||
(unless (flonum? x) (flargerr who x))
|
||||
(unless (flonum? y) (flargerr who y))
|
||||
(#3%$fleqv? x y)))
|
||||
|
||||
(set-who! $flhash
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr who x))
|
||||
(#3%$flhash x)))
|
||||
|
||||
(set-who! $flonum-exponent ; requires optimize-level 3
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr who x))
|
||||
($flonum-exponent x)))
|
||||
|
||||
(set-who! $flonum-sign ; requires optimize-level 3
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr who x))
|
||||
($flonum-sign x)))
|
||||
|
||||
(set-who! flonum->fixnum
|
||||
(let ([flmnf (fixnum->flonum (most-negative-fixnum))]
|
||||
[flmpf (fixnum->flonum (most-positive-fixnum))])
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr who x))
|
||||
(unless (fl<= flmnf x flmpf)
|
||||
($oops who "result for ~s would be outside of fixnum range" x))
|
||||
(#3%flonum->fixnum x))))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(define fxargerr
|
||||
(lambda (who x)
|
||||
($oops who "~s is not a fixnum" x)))
|
||||
|
||||
(define /zeroerr
|
||||
(lambda (who)
|
||||
($oops who "attempt to divide by zero")))
|
||||
|
||||
(define fxanserr
|
||||
(lambda (who . args)
|
||||
($impoops who "fixnum overflow computing ~s" (cons who args))))
|
||||
|
||||
(define-addop fx+)
|
||||
(define-subop fx- fixnum? fxargerr)
|
||||
|
||||
(set-who! #(r6rs: fx+) (lambda (x y) (#2%r6rs:fx+ x y)))
|
||||
(set-who! #(r6rs: fx-)
|
||||
(case-lambda
|
||||
[(x) (#2%r6rs:fx- x)]
|
||||
[(x y) (#2%r6rs:fx- x y)]))
|
||||
|
||||
(set! fx1-
|
||||
(lambda (x)
|
||||
(#2%fx1- x)))
|
||||
|
||||
(set! fx1+
|
||||
(lambda (x)
|
||||
(#2%fx1+ x)))
|
||||
|
||||
(set! fxzero?
|
||||
(lambda (x)
|
||||
(#2%fxzero? x)))
|
||||
|
||||
(set! fx*
|
||||
(rec fx*
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
; should handle fixnums (avoiding overflow)
|
||||
(let ([n (* x1 x2)])
|
||||
(if (fixnum? n) n (fxanserr 'fx* x1 x2)))
|
||||
(fxargerr 'fx* x2))
|
||||
(fxargerr 'fx* x1))]
|
||||
[(x1 x2 x3)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
(if (fixnum? x3)
|
||||
; should handle fixnums (avoiding overflow)
|
||||
(let ([n (* x1 x2)])
|
||||
(if (fixnum? n)
|
||||
; should handle fixnums (avoiding overflow)
|
||||
(let ([n (* n x3)])
|
||||
(if (fixnum? n) n (fxanserr 'fx* x1 x2 x3)))
|
||||
(fxanserr 'fx* x1 x2 x3)))
|
||||
(fxargerr 'fx* x3))
|
||||
(fxargerr 'fx* x2))
|
||||
(fxargerr 'fx* x1))]
|
||||
[(x1) (if (fixnum? x1) x1 (fxargerr 'fx* x1))]
|
||||
[() 1]
|
||||
[(x1 . rest)
|
||||
(let loop ([a x1] [ls rest])
|
||||
(if (null? ls)
|
||||
a
|
||||
(loop (fx* a (car ls)) (cdr ls))))])))
|
||||
|
||||
(set-who! #(r6rs: fx*)
|
||||
(lambda (x1 x2)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
; should handle fixnums (avoiding overflow)
|
||||
(let ([n (* x1 x2)])
|
||||
(if (fixnum? n) n (fxanserr who x1 x2)))
|
||||
(fxargerr who x2))
|
||||
(fxargerr who x1))))
|
||||
|
||||
(set! fxquotient
|
||||
(rec fxquotient
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
(begin
|
||||
(when (fx= x2 0) (/zeroerr 'fxquotient))
|
||||
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||||
(fxanserr 'fxquotient x1 x2)
|
||||
(#3%fxquotient x1 x2)))
|
||||
(fxargerr 'fxquotient x2))
|
||||
(fxargerr 'fxquotient x1))]
|
||||
[(x1 x2 x3)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
(if (fixnum? x3)
|
||||
(begin
|
||||
(when (fx= x2 0) (/zeroerr 'fxquotient))
|
||||
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||||
(fxanserr 'fxquotient x1 x2 x3)
|
||||
(let ([n (#3%fxquotient x1 x2)])
|
||||
(when (fx= x3 0) (/zeroerr 'fxquotient))
|
||||
(if (and (fx= x3 -1) (fx= n (most-negative-fixnum)))
|
||||
(fxanserr 'fxquotient x1 x2 x3)
|
||||
(#3%fxquotient n x3)))))
|
||||
(fxargerr 'fxquotient x3))
|
||||
(fxargerr 'fxquotient x2))
|
||||
(fxargerr 'fxquotient x1))]
|
||||
[(x1)
|
||||
(if (fixnum? x1)
|
||||
(if (fx= x1 0)
|
||||
(/zeroerr 'fxquotient)
|
||||
(#3%fxquotient 1 x1))
|
||||
(fxargerr 'fxquotient x1))]
|
||||
[(x1 . rest)
|
||||
(let loop ([a x1] [ls rest])
|
||||
(if (null? ls)
|
||||
a
|
||||
(loop (fxquotient a (car ls)) (cdr ls))))])))
|
||||
|
||||
(set! fx/
|
||||
(rec fx/ ;; same as fxquotient---should it be?
|
||||
(case-lambda
|
||||
[(x1 x2)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
(begin
|
||||
(when (fx= x2 0) (/zeroerr 'fx/))
|
||||
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||||
(fxanserr 'fx/ x1 x2)
|
||||
(#3%fx/ x1 x2)))
|
||||
(fxargerr 'fx/ x2))
|
||||
(fxargerr 'fx/ x1))]
|
||||
[(x1 x2 x3)
|
||||
(if (fixnum? x1)
|
||||
(if (fixnum? x2)
|
||||
(if (fixnum? x3)
|
||||
(begin
|
||||
(when (fx= x2 0) (/zeroerr 'fx/))
|
||||
(if (and (fx= x2 -1) (fx= x1 (most-negative-fixnum)))
|
||||
(fxanserr 'fx/ x1 x2 x3)
|
||||
(let ([n (#3%fx/ x1 x2)])
|
||||
(when (fx= x3 0) (/zeroerr 'fx/))
|
||||
(if (and (fx= x3 -1) (fx= n (most-negative-fixnum)))
|
||||
(fxanserr 'fx/ x1 x2 x3)
|
||||
(#3%fx/ n x3)))))
|
||||
(fxargerr 'fx/ x3))
|
||||
(fxargerr 'fx/ x2))
|
||||
(fxargerr 'fx/ x1))]
|
||||
[(x1)
|
||||
(if (fixnum? x1)
|
||||
(if (fx= x1 0)
|
||||
(/zeroerr 'fx/)
|
||||
(#3%fx/ 1 x1))
|
||||
(fxargerr 'fx/ x1))]
|
||||
[(x1 . rest)
|
||||
(let loop ([a x1] [ls rest])
|
||||
(if (null? ls)
|
||||
a
|
||||
(loop (fx/ a (car ls)) (cdr ls))))])))
|
||||
|
||||
(set! fxabs
|
||||
(lambda (x)
|
||||
(unless (fixnum? x) (fxargerr 'fxabs x))
|
||||
(when (fx= x (most-negative-fixnum)) (fxanserr 'fxabs x))
|
||||
(#3%fxabs x)))
|
||||
|
||||
(define-relop fx= fixnum? fxargerr fx=)
|
||||
(define-relop fx< fixnum? fxargerr fx=)
|
||||
(define-relop fx> fixnum? fxargerr fx=)
|
||||
(define-relop fx<= fixnum? fxargerr fx=)
|
||||
(define-relop fx>= fixnum? fxargerr fx=)
|
||||
(define-r6rs-relop fx=? fixnum? fxargerr)
|
||||
(define-r6rs-relop fx<? fixnum? fxargerr)
|
||||
(define-r6rs-relop fx>? fixnum? fxargerr)
|
||||
(define-r6rs-relop fx<=? fixnum? fxargerr)
|
||||
(define-r6rs-relop fx>=? fixnum? fxargerr)
|
||||
|
||||
(set! $fxu<
|
||||
(lambda (x y)
|
||||
(unless (fixnum? x) (fxargerr '$fxu< x))
|
||||
(unless (fixnum? y) (fxargerr '$fxu< y))
|
||||
(#3%$fxu< x y)))
|
||||
|
||||
(define-addop fxlogand)
|
||||
(define-addop fxlogior)
|
||||
(define-addop fxlogor)
|
||||
(define-addop fxlogxor)
|
||||
(define-addop fxand)
|
||||
(define-addop fxior)
|
||||
(define-addop fxxor)
|
||||
|
||||
(set! fxsll
|
||||
(lambda (x y)
|
||||
(#2%fxsll x y)))
|
||||
|
||||
(set! fxarithmetic-shift-left
|
||||
(lambda (x y)
|
||||
(#2%fxarithmetic-shift-left x y)))
|
||||
|
||||
(set! fxsrl
|
||||
(lambda (x y)
|
||||
(#2%fxsrl x y)))
|
||||
|
||||
(set! fxsra
|
||||
(lambda (x y)
|
||||
(#2%fxsra x y)))
|
||||
|
||||
(set! fxarithmetic-shift-right
|
||||
(lambda (x y)
|
||||
(#2%fxarithmetic-shift-right x y)))
|
||||
|
||||
(set! fxarithmetic-shift
|
||||
(lambda (x y)
|
||||
(#2%fxarithmetic-shift x y)))
|
||||
|
||||
(set! fxlognot
|
||||
(lambda (x)
|
||||
(#2%fxlognot x)))
|
||||
|
||||
(set! fxnot
|
||||
(lambda (x)
|
||||
(#2%fxnot x)))
|
||||
|
||||
(set! fxlogtest
|
||||
(lambda (x y)
|
||||
(#2%fxlogtest x y)))
|
||||
|
||||
(set! fxlogbit?
|
||||
(lambda (x y)
|
||||
(#2%fxlogbit? x y)))
|
||||
|
||||
(set! fxbit-set?
|
||||
(lambda (x y)
|
||||
(#2%fxbit-set? x y)))
|
||||
|
||||
(set! fxlogbit0
|
||||
(lambda (x y)
|
||||
(#2%fxlogbit0 x y)))
|
||||
|
||||
(set! fxlogbit1
|
||||
(lambda (x y)
|
||||
(#2%fxlogbit1 x y)))
|
||||
|
||||
(set-who! fxcopy-bit
|
||||
(lambda (n k b)
|
||||
; optimize-level 2 handler doesn't kick in unless b=0 or b=1
|
||||
(unless (fixnum? n) (fxargerr who n))
|
||||
(unless (fixnum? k) (fxargerr who k))
|
||||
(unless ($fxu< k (fx- (fixnum-width) 1))
|
||||
($oops who "invalid bit index ~s" k))
|
||||
(case b
|
||||
[(0) (#3%fxlogbit0 k n)]
|
||||
[(1) (#3%fxlogbit1 k n)]
|
||||
[else ($oops who "invalid bit value ~s" b)])))
|
||||
|
||||
(set! fxeven?
|
||||
(lambda (x)
|
||||
(#2%fxeven? x)))
|
||||
|
||||
(set! fxodd?
|
||||
(lambda (x)
|
||||
(#2%fxodd? x)))
|
||||
|
||||
(set! fxremainder
|
||||
(lambda (x y)
|
||||
(unless (fixnum? x) (fxargerr 'fxremainder x))
|
||||
(unless (fixnum? y) (fxargerr 'fxremainder y))
|
||||
(when (fx= y 0) (/zeroerr 'fxremainder))
|
||||
(#3%fxremainder x y)))
|
||||
|
||||
(set! fxmodulo
|
||||
(lambda (x y)
|
||||
(unless (fixnum? x) (fxargerr 'fxmodulo x))
|
||||
(unless (fixnum? y) (fxargerr 'fxmodulo y))
|
||||
(when (fx= y 0) (/zeroerr 'fxmodulo))
|
||||
(let ([r (fxremainder x y)])
|
||||
(if (if (fxnegative? y) (fxpositive? r) (fxnegative? r))
|
||||
(fx+ r y)
|
||||
r))))
|
||||
|
||||
(set! fxmin
|
||||
(case-lambda
|
||||
[(x y)
|
||||
(unless (fixnum? x) (fxargerr 'fxmin x))
|
||||
(unless (fixnum? y) (fxargerr 'fxmin y))
|
||||
(if (fx< y x) y x)]
|
||||
[(x y z)
|
||||
(unless (fixnum? x) (fxargerr 'fxmin x))
|
||||
(unless (fixnum? y) (fxargerr 'fxmin y))
|
||||
(unless (fixnum? z) (fxargerr 'fxmin z))
|
||||
(if (fx< y x)
|
||||
(if (fx< z y) z y)
|
||||
(if (fx< z x) z x))]
|
||||
[(x . y)
|
||||
(unless (fixnum? x) (fxargerr 'fxmin x))
|
||||
(let f ([x x] [y y])
|
||||
(if (null? y)
|
||||
x
|
||||
(f (let ([z (car y)])
|
||||
(unless (fixnum? z) (fxargerr 'fxmin z))
|
||||
(if (fx< z x) z x))
|
||||
(cdr y))))]))
|
||||
|
||||
(set! fxmax
|
||||
(case-lambda
|
||||
[(x y)
|
||||
(unless (fixnum? x) (fxargerr 'fxmax x))
|
||||
(unless (fixnum? y) (fxargerr 'fxmax y))
|
||||
(if (fx> y x) y x)]
|
||||
[(x y z)
|
||||
(unless (fixnum? x) (fxargerr 'fxmax x))
|
||||
(unless (fixnum? y) (fxargerr 'fxmax y))
|
||||
(unless (fixnum? z) (fxargerr 'fxmax z))
|
||||
(if (fx> y x)
|
||||
(if (fx> z y) z y)
|
||||
(if (fx> z x) z x))]
|
||||
[(x . y)
|
||||
(unless (fixnum? x) (fxargerr 'fxmax x))
|
||||
(let f ([x x] [y y])
|
||||
(if (null? y)
|
||||
x
|
||||
(f (let ([z (car y)])
|
||||
(unless (fixnum? z) (fxargerr 'fxmax z))
|
||||
(if (fx> z x) z x))
|
||||
(cdr y))))]))
|
||||
|
||||
(set! fxnegative?
|
||||
(lambda (x)
|
||||
(#2%fxnegative? x)))
|
||||
|
||||
(set! fxpositive?
|
||||
(lambda (x)
|
||||
(#2%fxpositive? x)))
|
||||
|
||||
(set! fxnonnegative?
|
||||
(lambda (x)
|
||||
(#2%fxnonnegative? x)))
|
||||
|
||||
(set! fxnonpositive?
|
||||
(lambda (x)
|
||||
(#2%fxnonpositive? x)))
|
||||
|
||||
(set! fixnum->flonum
|
||||
(lambda (x)
|
||||
(unless (fixnum? x) (fxargerr 'fixnum->flonum x))
|
||||
(#3%fixnum->flonum x)))
|
||||
|
||||
(set-who! fxlength
|
||||
(lambda (x)
|
||||
(if (fixnum? x)
|
||||
(#3%fxlength x)
|
||||
(fxargerr who x))))
|
||||
|
||||
(set-who! fxfirst-bit-set
|
||||
(lambda (x)
|
||||
(if (fixnum? x)
|
||||
(#3%fxfirst-bit-set x)
|
||||
(fxargerr who x))))
|
||||
|
||||
(set-who! fxif
|
||||
(lambda (x y z)
|
||||
(if (fixnum? x)
|
||||
(if (fixnum? y)
|
||||
(if (fixnum? z)
|
||||
(#3%fxif x y z)
|
||||
(fxargerr who z))
|
||||
(fxargerr who y))
|
||||
(fxargerr who x))))
|
||||
|
||||
(set-who! fxbit-field
|
||||
(lambda (n start end)
|
||||
(if (fixnum? n)
|
||||
(if (and (fixnum? start) ($fxu< start (fixnum-width)))
|
||||
(if (and (fixnum? end) ($fxu< end (fixnum-width)))
|
||||
(if (fx<= start end)
|
||||
(fxsra (fxand n (fxnot (fxsll -1 end))) start)
|
||||
($oops who "start index ~s is greater than end index ~s" start end))
|
||||
($oops who "~s is not a valid end index" end))
|
||||
($oops who "~s is not a valid start index" start))
|
||||
(fxargerr who n))))
|
||||
|
||||
(set-who! fxcopy-bit-field
|
||||
(lambda (n start end m)
|
||||
(if (fixnum? n)
|
||||
(if (and (fixnum? start) ($fxu< start (fixnum-width)))
|
||||
(if (and (fixnum? end) ($fxu< end (fixnum-width)))
|
||||
(if (fx<= start end)
|
||||
(if (fixnum? m)
|
||||
(let ([mask (fx- (fxsll 1 (fx- end start)) 1)])
|
||||
(fxior
|
||||
(fxand n (fxnot (fxsll mask start)))
|
||||
(fxsll (fxand m mask) start)))
|
||||
(fxargerr who m))
|
||||
($oops who "start index ~s is greater than end index ~s" start end))
|
||||
($oops who "~s is not a valid end index" end))
|
||||
($oops who "~s is not a valid start index" start))
|
||||
(fxargerr who n))))
|
||||
)
|
||||
|
||||
;;; The "cfl" operations could be done at level 0 by expanding them out.
|
||||
;;; They might be more efficient that way since they wouldn't have to
|
||||
;;; do double flonum checking.
|
||||
|
||||
(define cflonum?
|
||||
(lambda (x)
|
||||
(cflonum? x)))
|
||||
|
||||
(let ()
|
||||
|
||||
(define noncflonum-error
|
||||
(lambda (who x)
|
||||
($oops who "~s is not a cflonum" x)))
|
||||
|
||||
(set! cfl-real-part
|
||||
(lambda (z)
|
||||
(type-case z
|
||||
[($inexactnum?) ($inexactnum-real-part z)]
|
||||
[(flonum?) z]
|
||||
[else (noncflonum-error 'cfl-real-part z)])))
|
||||
|
||||
(set! cfl-imag-part
|
||||
(lambda (z)
|
||||
(type-case z
|
||||
[($inexactnum?) ($inexactnum-imag-part z)]
|
||||
[(flonum?) 0.0]
|
||||
[else (noncflonum-error 'cfl-imag-part z)])))
|
||||
|
||||
(define-cfl-addop cfl+ cflonum? noncflonum-error)
|
||||
(define-cfl-addop cfl* cflonum? noncflonum-error)
|
||||
(define-cfl-subop cfl- cflonum? noncflonum-error)
|
||||
(define-cfl-subop cfl/ cflonum? noncflonum-error)
|
||||
(define-cfl-relop cfl= cflonum? noncflonum-error cfl=)
|
||||
|
||||
(set! cfl-conjugate
|
||||
(lambda (x)
|
||||
(type-case x
|
||||
[(cflonum?) (#3%cfl-conjugate x)]
|
||||
[else (noncflonum-error 'cfl-conjugate x)])))
|
||||
|
||||
)
|
||||
)
|
||||
1004
s/mkheader.ss
Normal file
1004
s/mkheader.ss
Normal file
File diff suppressed because it is too large
Load diff
Some files were not shown because too many files have changed in this diff Show more
Reference in a new issue