Tests

.github/workflows/test.yml

@@ -0,0 +1,66 @@
+name: Test
+
+on:
+  workflow_dispatch:
+  push:
+    branches: [ main ]
+  pull_request:
+
+jobs:
+  test:
+    name: ${{ matrix.host }} / ${{ matrix.mode }}
+
+    defaults:
+      run:
+        shell: bash -l {0}
+
+    strategy:
+      fail-fast: false
+      matrix:
+        host:
+        - sbcl # non-sbcl hosts would require more changes below
+        mode:
+        - native
+        - cross
+
+    runs-on: ubuntu-22.04
+
+    steps:
+    - name: Install SBCL
+      if: matrix.host == 'sbcl'
+      run: |
+        sudo apt-get update
+        sudo apt install -y sbcl
+
+    - name: Install Quicklisp
+      run: |
+        curl -kLO https://beta.quicklisp.org/quicklisp.lisp
+        sbcl --non-interactive --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(ql-util:without-prompting (ql:add-to-init-file))"
+
+    - name: Checkout repository
+      uses: actions/checkout@v4
+      with:
+        path: cvm
+
+# Clostrum is not in Quicklisp as of now, so get it from github.
+
+    - name: Checkout Clostrum
+      uses: actions/checkout@v4
+      with:
+        repository: s-expressionists/Clostrum
+        path: Clostrum
+
+    - name: Configure ASDF to find everything
+      run: |
+        mkdir -p $HOME/.config/common-lisp/source-registry.conf.d
+        echo "(:TREE #P\"${{ github.workspace }}/\")" > $HOME/.config/common-lisp/source-registry.conf.d/cvm.conf
+
+    - name: Run native client tests
+      if: matrix.mode == 'native'
+      run: |
+        sbcl --load "${{ github.workspace }}/cvm/test/script.lisp"
+
+    - name: Run cross client tests
+      if: matrix.mode == 'cross'
+      run: |
+        sbcl --load "${{ github.workspace }}/cvm/test/cross/script.lisp"

Cross/vm.lisp

@@ -1,6 +1,7 @@
 (defpackage #:cvm.cross.vm
   (:use #:cl)
-  (:local-nicknames (#:m #:cvm.machine))
+  (:local-nicknames (#:m #:cvm.machine)
+                    (#:arg #:cvm.argparse))
   (:export #:initialize-vm)
   (:export #:*trace*)
   (:export #:symbol-cell))
@@ -106,13 +107,24 @@
   (let ((cell (symbol-cell symbol global-cell)))
     (setf (car cell) new)))
 
-(defvar *dynenv* nil)
+(define-condition out-of-extent-unwind (control-error)
+  ())
+
+(defun exit-to (vm entry-dynenv new-ip)
+  ;; Make sure the entry is still on the DE stack.
+  ;; If it is, reset the DE stack, and throw.
+  ;; Otherwise complain.
+  (let ((old-de-stack (member entry-dynenv (vm-dynenv-stack vm))))
+    (when (null old-de-stack)
+      (error 'out-of-extent-unwind))
+    (setf (vm-dynenv-stack vm) old-de-stack)
+    (throw (entry-dynenv-tag entry-dynenv) new-ip)))
 
 (defun instruction-trace (bytecode stack ip bp sp frame-size)
   (fresh-line *trace-output*)
   (let ((frame-end (+ bp frame-size))
         ;; skip package prefixes on inst names.
-        (*package* (find-package "CVM/MACHINE")))
+        (*package* (find-package "CVM.MACHINE")))
     (prin1 (list (m:disassemble-instruction bytecode ip)
                  bp
                  sp
@@ -184,6 +196,13 @@
            (error "Invalid bytecode: Reached end"))
          (when trace
            (instruction-trace bytecode stack ip bp sp frame-size))
+         ;; The catch is for NLX. Without NLX, a (go loop) at the
+         ;; bottom skips back up to the loop without setting IP.
+         ;; When something NLXs to this frame, we throw the new IP
+         ;; to the tag, set the IP, and then jump up to the loop.
+         ;; We use CATCH instead of BLOCK on the theory that BLOCK
+         ;; will have to allocate each loop, but well, I suspect
+         ;; CATCH will too generally.
          (setf ip
                (catch tag
                  (ecase (code)
@@ -272,20 +291,23 @@
                    ((#.m:check-arg-count-<=)
                     (let ((n (next-code)))
                       (unless (<= (vm-arg-count vm) n)
-                        (error "Invalid number of arguments: Got ~d, need at most ~d."
-                               (vm-arg-count vm) n)))
+                        (error 'arg:wrong-number-of-arguments
+                               :given-nargs (vm-arg-count vm)
+                               :max-nargs n)))
                     (incf ip))
                    ((#.m:check-arg-count->=)
                     (let ((n (next-code)))
                       (unless (>= (vm-arg-count vm) n)
-                        (error "Invalid number of arguments: Got ~d, need at least ~d."
-                               (vm-arg-count vm) n)))
+                        (error 'arg:wrong-number-of-arguments
+                               :given-nargs (vm-arg-count vm)
+                               :min-nargs n)))
                     (incf ip))
                    ((#.m:check-arg-count-=)
                     (let ((n (next-code)))
                       (unless (= (vm-arg-count vm) n)
-                        (error "Invalid number of arguments: Got ~d, need exactly ~d."
-                               (vm-arg-count vm) n)))
+                        (error 'arg:wrong-number-of-arguments
+                               :given-nargs (vm-arg-count vm)
+                               :min-nargs n :max-nargs n)))
                     (incf ip))
                    ((#.m:jump-if-supplied-8)
                     (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker)
@@ -343,7 +365,7 @@
                            (key-literal-start (next-code))
                            (key-literal-end (+ key-literal-start key-count))
                            (key-frame-start (+ bp (next-code)))
-                           (unknown-key-p nil)
+                           (unknown-keys nil)
                            (allow-other-keys-p nil))
                       ;; Initialize all key values to #<unbound-marker>
                       (loop for index from key-frame-start below (+ key-frame-start key-count)
@@ -353,30 +375,35 @@
                             ((< arg-index more-start)
                              (cond ((= arg-index (1- more-start)))
                                    ((= arg-index (- more-start 2))
-                                    (error "Passed odd number of &KEY args!"))
+                                    (error 'arg:odd-keywords))
                                    (t
                                     (error "BUG! This can't happen!"))))
                           (let ((key (stack (1- arg-index))))
-                            (if (eq key :allow-other-keys)
-                                (setf allow-other-keys-p (stack arg-index))
-                                (loop for key-index from key-literal-start
-                                        below key-literal-end
-                                      for offset of-type (unsigned-byte 16)
-                                      from key-frame-start
-                                      do (when (eq (constant key-index) key)
-                                           (setf (stack offset) (stack arg-index))
-                                           (return))
-                                      finally (setf unknown-key-p key))))))
+                            (when (eq key :allow-other-keys)
+                              (setf allow-other-keys-p (stack arg-index)))
+                            (loop for key-index from key-literal-start
+                                    below key-literal-end
+                                  for offset of-type (unsigned-byte 16)
+                                  from key-frame-start
+                                  do (when (eq (constant key-index) key)
+                                       (setf (stack offset) (stack arg-index))
+                                       (return))
+                                  finally (unless (or allow-other-keys-p
+                                                      (eq key :allow-other-keys))
+                                            (push key unknown-keys))))))
                       (when (and (not (or (logbitp 7 key-count-info)
                                           allow-other-keys-p))
-                                 unknown-key-p)
-                        (error "Unknown key arg ~a!" unknown-key-p)))
+                                 unknown-keys)
+                        (error 'arg:unrecognized-keyword-argument
+                               :unrecognized-keywords unknown-keys)))
                     (incf ip))
                    ((#.m:save-sp)
-                    (setf (stack (+ bp (next-code))) sp)
+                    (setf (stack (+ bp (next-code)))
+                          (list sp (vm-dynenv-stack vm)))
                     (incf ip))
                    ((#.m:restore-sp)
-                    (setf sp (stack (+ bp (next-code))))
+                    (setf (values sp (vm-dynenv-stack vm))
+                          (values-list (stack (+ bp (next-code)))))
                     (incf ip))
                    ((#.m:entry)
                     (let ((de (make-entry-dynenv tag)))
@@ -415,13 +442,13 @@
                     (return))
                    ((#.m:exit-8)
                     (incf ip (next-code-signed))
-                    (throw (entry-dynenv-tag (spop)) ip))
+                    (exit-to vm (spop) ip))
                    ((#.m:exit-16)
                     (incf ip (next-code-signed-16))
-                    (throw (entry-dynenv-tag (spop)) ip))
+                    (exit-to vm (spop) ip))
                    ((#.m:exit-24)
                     (incf ip (next-code-signed-24))
-                    (throw (entry-dynenv-tag (spop)) ip))
+                    (exit-to vm (spop) ip))
                    ((#.m:entry-close)
                     (pop (vm-dynenv-stack vm))
                     (incf ip))
@@ -495,7 +522,8 @@
                       (#.m:const
                        (spush (constant (+ (next-code) (ash (next-code) 8))))
                        (incf ip)))))
-                 (go loop)))))))
+                 (go loop)))
+         (go loop)))))
 
 (defmethod m:compute-instance-function ((client cvm.cross:client)
                                         (closure m:bytecode-closure))

arg-conditions.lisp

@@ -0,0 +1,50 @@
+(defpackage #:cvm.argparse
+  (:use #:cl)
+  (:export #:argument-error
+           #:wrong-number-of-arguments #:odd-keywords
+           #:unrecognized-keyword-argument)
+  (:export #:parse-macro))
+
+(in-package #:cvm.argparse)
+
+;;; abstract parent type for errors signaled by lambda list processing
+(define-condition argument-error (program-error)
+  ((%called-function :initform nil :initarg :called-function
+                     :reader called-function)))
+
+;;; nabbed from clasp
+(define-condition wrong-number-of-arguments (argument-error)
+  ((%given-nargs :initarg :given-nargs :reader given-nargs)
+   (%min-nargs :initarg :min-nargs :reader min-nargs :initform nil)
+   (%max-nargs :initarg :max-nargs :reader max-nargs :initform nil))
+  (:report (lambda (condition stream)
+             (let* ((min (min-nargs condition))
+                    (max (max-nargs condition))
+                    ;; FIXME: get an actual name if possible
+                    (dname nil))
+               (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?"
+                       dname (given-nargs condition)
+                       (cond ((null max)  "at least ~d")
+                             ((null min)  "at most ~*~d")
+                             ;; I think "exactly 0" is better than "at most 0", thus duplication
+                             ((= min max) "exactly ~d")
+                             ((zerop min) "at most ~*~d")
+                             (t           "between ~d and ~d"))
+                       min max)))))
+
+(define-condition odd-keywords (argument-error)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "Odd number of keyword arguments~:[~; for ~s~]."
+                     (called-function condition)
+                     ;; FIXME: again, get an actual name somehow.
+                     nil))))
+
+(define-condition unrecognized-keyword-argument (argument-error)
+  ((%unrecognized-keywords :initarg :unrecognized-keywords
+                           :reader unrecognized-keywords))
+  (:report (lambda (condition stream)
+             (format stream "Unrecognized keyword arguments ~S~:[~; for ~S~]."
+                     (unrecognized-keywords condition)
+                     (called-function condition) ; FIXME: name
+                     nil))))

cmpltv.lisp

@@ -1,6 +1,7 @@
 (defpackage #:cvm.compile-file
   (:use #:cl)
-  (:local-nicknames (#:cmp #:cvm.compile))
+  (:local-nicknames (#:cmp #:cvm.compile)
+                    (#:arg #:cvm.argparse))
   (:shadow #:compile-file #:macroexpand-1 #:macroexpand)
   (:export #:with-constants
            #:ensure-constant #:add-constant #:find-constant-index)
@@ -1263,13 +1264,13 @@
       (bytecode-compile-toplevel-progn body new-env))))
 
 (defun bytecode-compile-toplevel-macrolet (bindings body env)
-  (let ((macros nil))
+  (let ((macros nil)
+        (aenv (cmp:lexenv-for-macrolet env)))
     (dolist (binding bindings)
       (let* ((name (car binding)) (lambda-list (cadr binding))
              (body (cddr binding))
-             (eform (trivial-cltl2:parse-macro name lambda-list body env))
-             (aenv (cmp:lexenv-for-macrolet env))
-             (expander (cmp:compile eform aenv))
+             (expander (cmp:compute-macroexpander
+                        name lambda-list body aenv))
              (info (cmp:make-local-macro name expander)))
         (push (cons name info) macros)))
     (bytecode-compile-toplevel-locally