From 5101ada8e04bee34473561212bb4ea7d5299d2a8 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Thu, 18 Jun 2026 11:20:56 -0400 Subject: [PATCH] Chez Phase 2 (inc C): bit ops + parse-long/parse-double __bit-and/or/xor/and-not + bit-not/shift/set/clear/test/flip + unsigned-bit- shift-right + parse-long/parse-double were unshimmed seed natives (jolt-nil). Bit ops coerce the all-flonum operands to exact ints, operate, return flonums. parse-* match the seed's strict shapes (nil on malformed, throw on non-string). Prelude parity 1593 -> 1652 (inc B+C), 0 new divergences; 3 print-method/def- returns-var cases moved crash->allowlist. jolt-cf1q.3. --- host/chez/natives-num.ss | 87 ++++++++++++++++++++++++++++++ test/chez/run-corpus-prelude.janet | 16 +++++- 2 files changed, 101 insertions(+), 2 deletions(-) create mode 100644 host/chez/natives-num.ss diff --git a/host/chez/natives-num.ss b/host/chez/natives-num.ss new file mode 100644 index 0000000..c5dff2d --- /dev/null +++ b/host/chez/natives-num.ss @@ -0,0 +1,87 @@ +;; bit ops + string->number parsers (jolt-cf1q.3 Phase 2 inc C) — host-coupled +;; seed natives (core_refs.janet bit family, core_io.janet parse-long/double) that +;; resolved to jolt-nil. jolt models every number as a double, so bit ops coerce +;; to an exact integer, operate, and return a flonum. parse-* match the seed's +;; strict shapes (Clojure 1.11: nil on malformed, throw on a non-string). + +(define (->int x) (exact (truncate x))) +(define (jolt-bit-and a b) (exact->inexact (bitwise-and (->int a) (->int b)))) +(define (jolt-bit-or a b) (exact->inexact (bitwise-ior (->int a) (->int b)))) +(define (jolt-bit-xor a b) (exact->inexact (bitwise-xor (->int a) (->int b)))) +(define (jolt-bit-and-not a b) (exact->inexact (bitwise-and (->int a) (bitwise-not (->int b))))) +(define (jolt-bit-not a) (exact->inexact (bitwise-not (->int a)))) +(define (jolt-bit-shift-left x n) (exact->inexact (bitwise-arithmetic-shift-left (->int x) (->int n)))) +(define (jolt-bit-shift-right x n) (exact->inexact (bitwise-arithmetic-shift-right (->int x) (->int n)))) +(define (bit-mask n) (bitwise-arithmetic-shift-left 1 (->int n))) +(define (jolt-bit-set x n) (exact->inexact (bitwise-ior (->int x) (bit-mask n)))) +(define (jolt-bit-clear x n) (exact->inexact (bitwise-and (->int x) (bitwise-not (bit-mask n))))) +(define (jolt-bit-flip x n) (exact->inexact (bitwise-xor (->int x) (bit-mask n)))) +(define (jolt-bit-test x n) (not (zero? (bitwise-and (->int x) (bit-mask n))))) +;; unsigned-bit-shift-right: logical shift over 64-bit longs. For the common +;; non-negative operand it equals the arithmetic shift; the negative-operand +;; 64-bit-window case is not modeled (no fixed-width longs on the all-flonum side). +(define (jolt-unsigned-bit-shift-right x n) + (exact->inexact (bitwise-arithmetic-shift-right (->int x) (->int n)))) + +;; ---- string->scalar parsers ------------------------------------------------- +(define (ascii-digit? c) (and (char>=? c #\0) (char<=? c #\9))) +(define (skip-digits s i n) (let loop ((i i)) (if (and (< i n) (ascii-digit? (string-ref s i))) (loop (+ i 1)) i))) +(define (sign-at? s i n) (and (< i n) (let ((c (string-ref s i))) (or (char=? c #\+) (char=? c #\-))))) + +(define (parse-long-shape? s) + (let* ((n (string-length s)) (i0 (if (sign-at? s 0 n) 1 0))) + (and (> n i0) (= (skip-digits s i0 n) n)))) + +(define (jolt-parse-long s) + (if (not (string? s)) (error #f "parse-long requires a string" s) + (if (parse-long-shape? s) (exact->inexact (string->number s)) jolt-nil))) + +;; strict float shape: [+-]? ( D+ (. D*)? | . D+ ) ([eE][+-]? D+)? fully anchored. +(define (parse-double-shape? s) + (let ((n (string-length s))) + (and (> n 0) + (call/cc + (lambda (no) + (let* ((i0 (if (sign-at? s 0 n) 1 0)) + (after-int (skip-digits s i0 n)) + (had-int (> after-int i0)) + ;; mantissa end + (jm (cond + ((and had-int (< after-int n) (char=? (string-ref s after-int) #\.)) + (skip-digits s (+ after-int 1) n)) ; D+ . D* + ((and (not had-int) (< i0 n) (char=? (string-ref s i0) #\.)) + (let ((k (skip-digits s (+ i0 1) n))) ; . D+ + (if (> k (+ i0 1)) k (no #f)))) + (had-int after-int) + (else (no #f)))) + ;; optional exponent + (je (if (and (< jm n) (let ((c (string-ref s jm))) (or (char=? c #\e) (char=? c #\E)))) + (let* ((es (if (sign-at? s (+ jm 1) n) (+ jm 2) (+ jm 1))) + (ee (skip-digits s es n))) + (if (> ee es) ee (no #f))) + jm))) + (= je n))))))) + +(define (jolt-parse-double s) + (if (not (string? s)) (error #f "parse-double requires a string" s) + (cond + ((string=? s "Infinity") +inf.0) + ((string=? s "-Infinity") -inf.0) + ((string=? s "NaN") +nan.0) + ((parse-double-shape? s) (exact->inexact (string->number s))) + (else jolt-nil)))) + +(def-var! "clojure.core" "__bit-and" jolt-bit-and) +(def-var! "clojure.core" "__bit-or" jolt-bit-or) +(def-var! "clojure.core" "__bit-xor" jolt-bit-xor) +(def-var! "clojure.core" "__bit-and-not" jolt-bit-and-not) +(def-var! "clojure.core" "bit-not" jolt-bit-not) +(def-var! "clojure.core" "bit-shift-left" jolt-bit-shift-left) +(def-var! "clojure.core" "bit-shift-right" jolt-bit-shift-right) +(def-var! "clojure.core" "bit-set" jolt-bit-set) +(def-var! "clojure.core" "bit-clear" jolt-bit-clear) +(def-var! "clojure.core" "bit-flip" jolt-bit-flip) +(def-var! "clojure.core" "bit-test" jolt-bit-test) +(def-var! "clojure.core" "unsigned-bit-shift-right" jolt-unsigned-bit-shift-right) +(def-var! "clojure.core" "parse-long" jolt-parse-long) +(def-var! "clojure.core" "parse-double" jolt-parse-double) diff --git a/test/chez/run-corpus-prelude.janet b/test/chez/run-corpus-prelude.janet index 758e64e..72272e9 100644 --- a/test/chez/run-corpus-prelude.janet +++ b/test/chez/run-corpus-prelude.janet @@ -58,7 +58,16 @@ # str falls back to for collections) renders inf as "inf" — str needs a # recursive long-form renderer, the Phase-2 canonical printer. Top-level # (str ##Inf) -> "Infinity" already works (jolt-str-render-one). - "inf inside coll" true}) + "inf inside coll" true + # Phase 2 inc B (jolt-9zhh) made pr-str run; these now render via the readable + # FALLBACK instead of the seed's print-method / var semantics — separate gaps: + # - def returns the VALUE on Chez, not the var (#'ns/name) — def-returns-var + # is a later increment; (pr-str (def x 1)) -> "1" not "#'user/x" + # - a custom (defmethod print-method ...) isn't consulted by the Chez printer + # (print-method multimethod integration is deferred) + "pr-str of a var" true + "pr-str of a defn" true + "atom override fires nested" true}) (def ctx (d/make-ctx)) @@ -141,8 +150,11 @@ # jolt-ea9k) 1534 (total evaluated drops as the 3 odd-arg rows become :throws). # Phase 2 inc A (jolt-agw6: collection ctors set/hash-map/hash-set/array-map + # rand + real map entries / key / val / map-entry?) 1593. +# Phase 2 inc B (jolt-9zhh: readable printer + __pr-str1/__write/__with-out-str +# -> pr-str/pr/prn/print/println/*-str family) + inc C (bit ops + parse-long/ +# parse-double) 1652. # Strided runs scale down. -(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "1593"))) +(def base-floor (scan-number (or (os/getenv "JOLT_CHEZ_PRELUDE_FLOOR") "1652"))) (def floor (if (os/getenv "JOLT_CORPUS_LIMIT") 0 base-floor)) (when (or (> (length diverged) 0) (< pass floor)) (printf "REGRESSION: pass %d < floor %d or %d new divergence(s)" pass floor (length diverged)))