Skip to content
Snippets Groups Projects
Commit 5930ab86 authored by Mark Evenson's avatar Mark Evenson :speech_balloon:
Browse files

Merge branch 'jd-branch' into 'master'

Fixes plus new tests

Restructure caused bug when deleting compiled files.

Also added `readtable-case` tests and `defsetf` long form.

See merge request !3
parents dcaa3a30 f95ae1a6
No related branches found
No related tags found
No related merge requests found
...@@ -154,3 +154,14 @@ ...@@ -154,3 +154,14 @@
(setf (defsetf.6-accessor x) 'c) (setf (defsetf.6-accessor x) 'c)
x)) x))
c (c . b)) c (c . b))
;;; Test that defsetf works with places
(deftest defsetf.7a
(progn
(defsetf access-fn (x) (val-1 val-2)
`(list ,x ,val-1 ,val-2))
(eval (read-from-string
"(setf (access-fn 1) (values 2 3))")))
(1 2 3))
...@@ -10,7 +10,13 @@ ...@@ -10,7 +10,13 @@
(let* ((fn (compile-file-pathname "doit.lsp")) (let* ((fn (compile-file-pathname "doit.lsp"))
(type (pathname-type fn)) (type (pathname-type fn))
(dir-pathname (make-pathname :name :wild :type type)) (dir-pathname (make-pathname :name :wild :type type))
(files (directory dir-pathname))) (subdir-pathname (make-pathname :directory '(:relative :wild)
:name :wild :type type))
(format-pathname (make-pathname :directory '(:relative "printer/format")
:name :wild :type type))
(files (append (directory dir-pathname)
(directory subdir-pathname)
(directory format-pathname))))
(assert type) (assert type)
(assert (not (string-equal type "lsp"))) (assert (not (string-equal type "lsp")))
(mapc #'delete-file files)) (mapc #'delete-file files))
......
...@@ -136,8 +136,8 @@ rt_1000_8: ...@@ -136,8 +136,8 @@ rt_1000_8:
clean: clean:
@rm -f auxiliary/*.{out,fas,cls,fasl,o,so,~,fn,x86f,ufsl,abcl,lib} @rm -f */*.{out,fas,cls,fasl,o,so,~,fn,x86f,ufsl,abcl,lib}
@rm -f sandbox/*.{out,fas,cls,fasl,o,so,~,fn,x86f,ufsl,abcl,lib} @rm -f */*/*.{out,fas,cls,fasl,o,so,~,fn,x86f,ufsl,abcl,lib}
@rm -f test*.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# @rm -f test*.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\#
@rm -f *.dfsl *.d64fsl @rm -f *.dfsl *.d64fsl
@(cd beyond-ansi; $(MAKE) clean) @(cd beyond-ansi; $(MAKE) clean)
......
...@@ -5,6 +5,8 @@ ...@@ -5,6 +5,8 @@
(in-package :cl-test) (in-package :cl-test)
;;; readtable-case setting
(deftest readtable-case.1 (deftest readtable-case.1
(with-standard-io-syntax (with-standard-io-syntax
(readtable-case *readtable*)) (readtable-case *readtable*))
...@@ -53,6 +55,35 @@ ...@@ -53,6 +55,35 @@
(list rtc rt2))))) (list rtc rt2)))))
nil) nil)
;; readtable-case reading
(symbol-macrolet ((lookup-table
'(:SYMBOL ("zebra" "Zebra" "ZEBRA" "zebr\\a" "zebr\\A" "ZEBR\\a" "ZEBR\\A" "Zebr\\a" "Zebr\\A")
:UPCASE (|ZEBRA| |ZEBRA| |ZEBRA| |ZEBRa| |ZEBRA| |ZEBRa| |ZEBRA| |ZEBRa| |ZEBRA|)
:DOWNCASE (|zebra| |zebra| |zebra| |zebra| |zebrA| |zebra| |zebrA| |zebra| |zebrA|)
:PRESERVE (|zebra| |Zebra| |ZEBRA| |zebra| |zebrA| |ZEBRa| |ZEBRA| |Zebra| |ZebrA|)
:INVERT (|ZEBRA| |Zebra| |zebra| |ZEBRa| |ZEBRA| |zebra| |zebrA| |Zebra| |ZebrA|))))
(macrolet
((def-readtable-case-test (reader-case)
`(deftest ,(make-symbol (concatenate 'string "READTABLE-CASE.CASE-"
(symbol-name reader-case)))
(let ((*readtable* (copy-readtable)))
(setf (readtable-case *readtable*) ,reader-case)
(mapcar #'(lambda (x)
(read-from-string x))
',(getf lookup-table :symbol)))
,(getf lookup-table reader-case))))
(def-readtable-case-test :upcase)
(def-readtable-case-test :downcase)
(def-readtable-case-test :preserve)
(def-readtable-case-test :invert)))
;; when readtable was :invert quoted characters may get inverted too
(deftest readtable.case.invert-char
(let ((*readtable* (copy-readtable)))
(setf (readtable-case *readtable*) :invert)
(read-from-string "#\\a"))
#\a 3)
;;; Error cases ;;; Error cases
(deftest readtable-case.error.1 (deftest readtable-case.error.1
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment