Skip to content

Commit

Permalink
Merge pull request #5 from clasp-developers/tests
Browse files Browse the repository at this point in the history 
Adds tests and github automation for tests. Also fixes a buncha small bugs.
  • Loading branch information
@Bike
Bike authored Oct 1, 2023
2 parents 6a9f609 + f9cc9d4 commit cbb2373
Show file tree
Hide file tree
Showing 46 changed files with 5,093 additions and 121 deletions.
66 changes: 66 additions & 0 deletions .github/workflows/test.yml
View file
Original file line number Diff line number Diff line change
@@ -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"
86 changes: 57 additions & 29 deletions Cross/vm.lisp
View file
Original file line number Diff line number Diff line change
@@ -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))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand All @@ -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)))
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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))
Expand Down
50 changes: 50 additions & 0 deletions arg-conditions.lisp
View file
Original file line number Diff line number Diff line change
@@ -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))))
11 changes: 6 additions & 5 deletions cmpltv.lisp
View file
Original file line number Diff line number Diff line change
@@ -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)
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit cbb2373

Please sign in to comment.