Merge pull request #2 from s-expressionists/client-3

Integrate with Incless and Inravina

.github/workflows/test.yml

@@ -0,0 +1,53 @@
+name: test
+
+on:
+  workflow_dispatch:
+  push:
+    branches: [ main ]
+  pull_request:
+
+jobs:
+  test:
+    name: ${{ matrix.lisp }}
+    defaults:
+      run:
+        shell: bash -l {0}
+    strategy:
+      fail-fast: false
+      matrix:
+        lisp:
+        - clasp
+        - sbcl
+    runs-on: ubuntu-latest
+    container:
+      image: ghcr.io/yitzchak/archlinux-cl:latest
+    steps:
+    - name: Checkout trivial-stream-column
+      uses: actions/checkout@v3
+      with:
+        repository: yitzchak/trivial-stream-column
+        path: trivial-stream-column
+    - name: Checkout Incless
+      uses: actions/checkout@v3
+      with:
+        repository: s-expressionists/Incless
+        path: incless
+    - name: Checkout Inravina
+      uses: actions/checkout@v3
+      with:
+        repository: s-expressionists/Inravina
+        path: inravina
+    - name: Checkout Repository
+      uses: actions/checkout@v3
+      with:
+        path: invistra
+    - name: Setup Lisp Environment
+      run: |
+        make-rc
+        asdf-add
+    - name: Run Regression Tests
+      run: |
+        lisp -i ${{ matrix.lisp }} -e "(ql:quickload :invistra-extrinsic/test)" -e "(asdf:test-system :invistra-extrinsic)"
+    - name: Run ANSI Tests
+      run: |
+        lisp -i ${{ matrix.lisp }} -e "(ql:quickload :invistra-shim/test)" -e "(asdf:test-system :invistra-shim)"

.gitignore

@@ -23,4 +23,5 @@
 *.out
 *-cache.yaml
 *~
-\#*\#
+\#*\#
+dependencies

code/basic-output.lisp

@@ -0,0 +1,156 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 22.3.1 Basic output
+
+(in-package #:invistra)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 22.3.1.1 ~c Character
+
+(define-directive #\c c-directive nil (named-parameters-directive) ())
+
+(define-format-directive-interpreter c-directive
+  (let ((char (consume-next-argument 'character)))
+    (cond ((and (not colonp) (not at-signp))
+           ;; Neither colon nor at-sign.
+           ;; The HyperSpec says to do what WRITE-CHAR does.
+           (write-char char *destination*))
+          ((not at-signp)
+           ;; We have only a colon modifier.
+           ;; The HyperSpec says to do what WRITE-CHAR does for
+           ;; printing characters, and what char-name does otherwise.
+           ;; The definition of "printing char" is a graphic character
+           ;; other than space.
+           (if (and (graphic-char-p char) (not (eql char #\Space)))
+               (write-char char *destination*)
+               (write-string (char-name char) *destination*)))
+          ((not colonp)
+           ;; We have only an at-sign modifier.
+           ;; The HyperSpec says to print it the way the Lisp
+           ;; reader can understand, which I take to mean "use PRIN1".
+           ;; It also says to bind *PRINT-ESCAPE* to t.
+           (let ((*print-escape* t))
+             (incless:write-object client char *destination*)))
+          (t
+           ;; We have both a colon and and at-sign.
+           ;; The HyperSpec says to do what ~:C does, but
+           ;; also to mention unusual shift keys on the
+           ;; keyboard required to type the character.
+           ;; I don't see how to do that, so we do the same
+           ;; as for ~:C.
+           (if (and (graphic-char-p char) (not (eql char #\Space)))
+               (write-char char *destination*)
+               (write-string (char-name char) *destination*))))))
+
+(define-format-directive-compiler c-directive
+  `((let ((char (consume-next-argument 'character)))
+      ,(cond ((and (not colonp) (not at-signp))
+              `(write-char char *destination*))
+             ((not at-signp)
+              `(if (and (graphic-char-p char) (not (eql char #\Space)))
+                   (write-char char *destination*)
+                   (write-string (char-name char) *destination*)))
+             ((not colonp)
+              `(let ((*print-escape* t))
+                 (incless:write-object ,(incless:client-form client) char *destination*)))
+             (t
+              `(if (and (graphic-char-p char) (not (eql char #\Space)))
+                   (write-char char *destination*)
+                   (write-string (char-name char) *destination*)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 22.3.1.2 ~% Newline.
+
+(define-directive #\% percent-directive nil (named-parameters-directive no-modifiers-mixin)
+    ((how-many :type (integer 0) :default-value 1)))
+
+(define-format-directive-interpreter percent-directive
+  (loop repeat how-many
+        do (terpri *destination*)))
+
+(define-format-directive-compiler percent-directive
+  (let ((how-many (compile-time-value directive 'how-many)))
+    (case how-many
+      (0 '())
+      (1 '((terpri *destination*)))
+      (2 '((terpri *destination*)
+           (terpri *destination*)))
+      (otherwise
+        `((loop repeat how-many
+                do (terpri *destination*)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 22.3.1.3 ~& Fresh line and newlines.
+
+(define-directive #\& ampersand-directive nil (named-parameters-directive no-modifiers-mixin)
+    ((how-many :type (integer 0) :default-value 1)))
+
+(define-format-directive-interpreter ampersand-directive
+  (unless (zerop how-many)
+    (fresh-line *destination*)
+    (loop repeat (1- how-many)
+          do (terpri *destination*))))
+
+(define-format-directive-compiler ampersand-directive
+  (let ((how-many (compile-time-value directive 'how-many)))
+    (case how-many
+      ((:argument-reference :remaining-argument-count)
+       `((unless (zerop how-many)
+           (fresh-line *destination*)
+           (loop repeat (1- how-many)
+                 do (terpri *destination*)))))
+      (0 nil)
+      (1 `((fresh-line *destination*)))
+      (2 `((fresh-line *destination*)
+           (terpri *destination*)))
+      (otherwise
+       `((fresh-line *destination*)
+         (loop repeat ,(1- how-many)
+               do (terpri *destination*)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 22.3.1.4 ~| Page separators.
+
+(define-directive #\| vertical-bar-directive nil (named-parameters-directive no-modifiers-mixin)
+    ((how-many :type (integer 0) :default-value 1)))
+
+(define-format-directive-interpreter vertical-bar-directive
+  (loop repeat how-many
+        do (write-char #\Page *destination*)))
+
+(define-format-directive-compiler vertical-bar-directive
+  (let ((how-many (compile-time-value directive 'how-many)))
+    (case how-many
+      (0 nil)
+      (1 `((write-char #\Page *destination*)))
+      (2 `((write-char #\Page *destination*)
+           (write-char #\Page *destination*)))
+      (otherwise
+       `((loop repeat how-many
+               do (write-char #\Page *destination*)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 22.3.1.5 ~~ Tildes.
+
+(define-directive #\~ tilde-directive nil (named-parameters-directive no-modifiers-mixin)
+    ((how-many :type (integer 0) :default-value 1)))
+
+(define-format-directive-interpreter tilde-directive
+  (loop repeat how-many
+        do (write-char #\~ *destination*)))
+
+(define-format-directive-compiler tilde-directive
+  (let ((how-many (compile-time-value directive 'how-many)))
+    (case how-many
+      (0 nil)
+      (1 `((write-char #\~ *destination*)))
+      (2 `((write-char #\~ *destination*)
+           (write-char #\~ *destination*)))
+      (otherwise
+       `((loop repeat how-many
+               do (write-char #\~ *destination*)))))))

code/burger-dybvig.lisp

@@ -1,3 +1,5 @@
+(cl:in-package #:invistra)
+
 ;;; First some background.
 ;;;
 ;;; Let us say we are dealing with IEEE 754-2008 binary64 floats to
@@ -221,13 +223,15 @@
 ;;; r < 10^k.  We use the floating-point logarithmic function
 ;;; to find an approximate value of k, then we find the exact
 ;;; one by a small search around the appriximation.
-(defun scale (r)
-  (let* ((try (1- (ceiling (log r 10))))
+(defun scale (r &optional high-ok)
+  (let* ((try (1- (ceiling (log (coerce r 'long-float) 10))))
          (expt (expt 10 try)))
-    (loop while (<= r expt)
+    (loop while (or (and high-ok (< r expt))
+                    (and (not high-ok) (<= r expt)))
           do (decf try)
              (setf expt (/ expt 10)))
-    (loop until (<= r expt)
+    (loop until (or (and high-ok (< r expt))
+                    (and (not high-ok) (<= r expt)))
           do (incf try)
              (setf expt (* expt 10)))
     try))
@@ -340,16 +344,19 @@
   (multiple-value-bind (f e)
       (integer-decode-float x)
     ;; adjust mantissa and exponent
-    (let ((diff (- (float-precision x) (float-digits x))))
-      (setf f (* f (expt 2 diff)))
-      (decf e diff))
-    (let (r s m+ m-)
+    (when (< (float-precision x) (float-digits x))
+      (let ((shift (- (float-digits x) (integer-length f))))
+        (setf f (ash f shift))
+        (decf e shift)))
+    (let (r s m+ m-
+          (high-ok #+(or clasp sbcl) (evenp f) #-(or clasp sbcl) nil)
+          (low-ok #+(or clasp sbcl) (evenp f) #-(or clasp sbcl) nil))
       (if (>= e 0)
           (progn (if (= (decode-float x) 0.5)
                      (setf m- (expt 2 e)
                            m+ (* m- 2)
                            s 4
-                           r (* f m+  2))
+                           r (* f m+ 2))
                      (setf m- (expt 2 e)
                            m+ m-
                            s 2
@@ -365,31 +372,38 @@
                            m+ 1
                            s (* (expt 2 (- e)) 2)
                            r (* f 2)))))
-      (let ((k (scale (/ (+ r m+) s))))
+      (let ((k (scale (/ (+ r m+) s) high-ok)))
         (if (>= k 0)
             (setf s (* s (expt 10 k)))
             (let ((coeff (expt 10 (- k))))
               (setf r (* r coeff)
                     m+ (* m+ coeff)
                     m- (* m- coeff))))
-        (loop with result = '()
-              do (multiple-value-bind (quotient remainder)
-                     (floor (* r 10) s)
-                   (setf r remainder
-                         m+ (* m+ 10)
-                         m- (* m- 10))
-                   (if (and (>= r m-) (<= (+ r m+) s))
-                       (push quotient result)
-                       (progn (push (+ quotient
-                                       (if (< r m-)
-                                           (if (> (+ r m+) s)
-                                               ;; break the tie
-                                               (if (< (* 2 r) s) 0 1)
-                                               0)
-                                           1))
-                                    result)
-                              (loop-finish))))
-              finally (return (values (nreverse result) k)))))))
+        (prog ((result (make-array 16 :adjustable t
+                                      :fill-pointer 0
+                                      :initial-element 0
+                                      :element-type '(integer 0 9)))
+               tc1 tc2)
+         next
+           (multiple-value-bind (quotient remainder)
+               (floor (* r 10) s)
+             (setf r remainder
+                   m+ (* m+ 10)
+                   m- (* m- 10)
+                   tc1 (if low-ok (<= r m-) (< r m-))
+                   tc2 (if high-ok
+                           (>= (+ r m+) s)
+                           (> (+ r m+) s)))
+             (when (or tc1 tc2)
+               (vector-push-extend (if (or (and (not tc1) tc2)
+                                           (not (or (and tc1 (not tc2))
+                                                    (< (* r 2) s))))
+                                       (1+ quotient)
+                                       quotient)
+                                   result)
+               (return (values result k)))
+             (vector-push-extend quotient result)
+             (go next)))))))
 
 ;;; Test that the two implemetations above give the same result
 ;;; for all single floats.  Running this test may take a few days
@@ -399,12 +413,12 @@
         for i from 0
         until (= x 0)
         do (when (zerop (mod i 1000000))
-             (format *trace-output* "~s~%" x)
+             (cl:format *trace-output* "~s~%" x)
              (finish-output *trace-output*))
         do (multiple-value-bind (d1 k1)
                (burger-dybvig-1 x)
              (multiple-value-bind (d2 k2)
                  (burger-dybvig-2 x)
                (when (not (and (equal d1 d2)
                                (= k1 k2)))
-                 (format *trace-output* "no: ~s~%" x))))))
+                 (cl:format *trace-output* "no: ~s~%" x))))))