pjs/js2/semantics/Test/StandardFunction.lisp

77 строки
2.9 KiB
Common Lisp
Исходник Обычный вид История

1999-07-27 04:57:03 +04:00
(progn
(defparameter *sfw*
(generate-world
"SF"
'((grammar standard-function-grammar :lalr-1 :start)
(production :start () start-none)
(deftuple x-long (value (integer-range (neg (expt 2 63)) (- (expt 2 63) 1))))
(deftuple x-u-long (value (integer-range 0 (- (expt 2 64) 1))))
(deftype x-general-number (union long u-long float32 float64))
(deftype x-finite-general-number (union long u-long finite-float32 finite-float64))
1999-07-27 04:57:03 +04:00
(define (x-digit-value (c character)) integer
(cond
((set-in c (range-set-of-ranges character #\0 #\9))
(return (- (character-to-code c) (character-to-code #\0))))
((set-in c (range-set-of-ranges character #\A #\Z))
(return (+ (- (character-to-code c) (character-to-code #\A)) 10)))
((set-in c (range-set-of-ranges character #\a #\z))
(return (+ (- (character-to-code c) (character-to-code #\a)) 10)))
(nil (bottom))))
(define (x-real-to-float64 (x rational)) float64
(const s (range-set integer) (range-set-of integer (neg (expt 2 1024)) 0 (expt 2 1024)))
(const a integer (integer-set-min s))
(cond
((= a (expt 2 1024)) (return +infinity64))
((= a (neg (expt 2 1024))) (return -infinity64))
((/= a 0) (return (bottom)))
((< x 0 rational) (return -zero64))
(nil (return +zero64))))
(define (x-float32-to-float64 (x float32)) float64
(case x
(:select (tag +zero32) (return +zero64))
(:select (tag -zero32) (return -zero64))
(:select (tag +infinity32) (return +infinity64))
(:select (tag -infinity32) (return -infinity64))
(:select (tag nan32) (return nan64))
(:narrow nonzero-finite-float32 (return (real-to-float64 (& value x))))))
(define (x-truncate-finite-float64 (x finite-float64)) integer
(rwhen (in x (tag +zero64 -zero64) :narrow-false)
(return 0))
(const r rational (& value x))
(if (> r 0 rational)
(return (floor r))
(return (ceiling r))))
#|(define (compare (x rational) (y rational)) order
(cond
((< x y rational) (return less))
((= x y rational) (return equal))
(nil (return greater))))|#
1999-07-27 04:57:03 +04:00
)))
(defparameter *sfg* (world-grammar *sfw* 'standard-function-grammar)))
#|
(values
(depict-rtf-to-local-file
"Test/StandardFunctionSemantics.rtf"
"Standard Function Semantics"
#'(lambda (rtf-stream)
(depict-world-commands rtf-stream *sfw* :heading-offset 1)))
(depict-html-to-local-file
"Test/StandardFunctionSemantics.html"
"Standard Function Semantics"
t
#'(lambda (html-stream)
(depict-world-commands html-stream *sfw* :heading-offset 1))
:external-link-base ""))
1999-07-27 04:57:03 +04:00
|#
(length (grammar-states *sfg*))