Skip to content

Commit

Permalink
primarily intending to integrate Colin Walter's O(N) map code and
Browse files Browse the repository at this point in the history
fixing BUTLAST (but doing some other stuff too, since achieving the
primary objective involved a lot of inspecting other code):

another revision of MAP stuff, part I:
  * I switched over to code inspired by Colin Walters' O(N) MAP
    code (from the cmucl-imp mailing list 2000 Sep 02) for the
    general non-DEFTRANSFORM case.
  * HIGH-SECURITY-SUPPORT error checking logic goes away, pending
    part II
  * I made some  miscellaneous cleanups of old arity-1 code too.
  * The old MAP-FOR-EFFECT, MAP-TO-LIST, and MAP-TO-SIMPLE macros,
    and the old functions MAP-WITHOUT-ERRORCHECKING, and
    GET-MINIMUM-LENGTH-SEQUENCES go away.
  * The old #+!HIGH-SECURITY length-checking logic goes
    away, to be replaced by stuff in part II.
  * New O(N) functions %MAP-FOR-EFFECT, %MAP-TO-LIST, and
    %MAP-TO-VECTOR are added, and MAP is redefined in terms of them.
  * Add a note pointing out that since MAP-INTO has not been
    rewritten to take advantage of all the new mapping technology,
    it's still slow.
  * Delete no-longer-used ELT-SLICE macro.

another revision of MAP stuff, part II: Peter Van Eynde might go into
a killing frenzy, or at least his ansi-test suite will gnaw SBCL to
death, unless we raise type errors on length mismatches like
  (MAP '(SIMPLE-VECTOR 128) #'+ #(1 2) #(1 1)).
How to do this without clobbering efficiency? More DEFTRANSFORMs, I
think..
  * MAP becomes a wrapper around %MAP. %MAP doesn't do this
    kind of length checking, MAP does. The old DEFUN MAP,
    DEFKNOWN MAP, and DEFTRANSFORM MAP stuff all turns into
    corresponding definitions for %MAP. The wrapper is
    implemented both as a DEFUN MAP and a DEFTRANSFORM MAP.
  * Now make DEFTRANSFORM MAP smarter:
    ** If necessary, check at runtime that ARRAY-DIMENSION
       matches what we pull out of SPECIFIER-TYPE.
    ** No test is done when SPEED > SAFETY.
    ** No test is needed when we can tell at compile time that
       the result type doesn't specify the length of the result.
  * Also add the same kind of ARRAY-DIMENSION/SPECIFIER-TYPE runtime
    check to DEFUN MAP.
  * While I'm at it, since DEFTRANSFORM MAP needs to think hard about
    the type of the result anyway, it might as well declare what
    it's figured out (TRULY-THE) to benefit any code downstream.

Start playing with MAP regression tests. Add tests/assertoid.lisp to
support future regression tests.

Once I started using the QUIT :UNIX-CODE keyword argument in my test
cases, I could see that it isn't very mnemonic. So I changed it to the
more-descriptive name :UNIX-STATUS, leaving the old name supported but
deprecated.

Oops! The old DEFTRANSFORM MAP (now DEFTRANSFORM %MAP) should really
only be done when (>= SPEED SPACE), but it wasn't declared that way.

While looking for an example of a DEFTRANSFORM with &REST arguments
to use as a model for the code in the new DEFTRANSFORM from MAP to
%MAP, I noticed that the problem of taking a list of names and
generating a corresponding list of gensyms is solved in many different
places in the code, in several ways. Also, the related problem of just
creating a list of N gensyms is solved in several places in in the
code. This seems unnecessarily error-prone and wasteful, so I went
looking for such cases and turned them into calls to MAKE-GENSYM-LIST.

another revision of MAP stuff, part III:
  * Search for 'map' in the output from clocc ansi-tests/tests.lisp,
    to check that the new MAP code isn't too obviously broken.
  * Add some regression tests in test/map.impure.lisp.

Oops! The various %MAP-..-ARITY-1 helper functions expect a function
argument, but DEFTRANSFORM MAP can call them passing them a function
name instead.
  * Change the helper functions so that they can handle
    function names as arguments.
  * Define %COERCE-CALLABLE-TO-FUNCTION to help with this. Note that
    this seems to be what %COERCE-NAME-TO-FUNCTION meant long ago,
    judging from DEFTRANSFORM %COERCE-NAME-TO-FUNCTION; so
    appropriate that DEFTRANSFORM for %COERCE-CALLABLE-TO-FUNCTION.
  * Use %COERCE-CALLABLE-TO-FUNCTION elsewhere that expressions
    involving %COERCE-NAME-TO-FUNCTION were used previously.

deleted the old commented-out version of DEFMACRO HANDLER-CASE
(since it was marked "Delete this when the system is stable.":-)

deleted the old commented-out version of GEN-FORMAT-DEF-FORM,
since it was supposed to be safe to do so after sbcl-0.6.4

I removed the apology for not using PRINT-OBJECT everywhere in the
printer from the bugs list in the man page, since it seems to be
rather tricky to construct a test case which exposes the system's
non-PRINT-OBJECT-ness without the test case itself violating the ANSI
spec.

I updated, cleaned up, or removed outright some other outdated or
confusing entries in the BUGS file and from the bugs list on the man
page.

Now that BUTLAST no longer blows up on the new problem cases a la
(BUTLAST NIL -1), I wonder whether I could stop it from blowing
up on the old problem cases a la (BUTLAST NIL)? It looks like
a compiler problem, since the interpreted definition of BUTLAST works,
even though the compiled one doesn't. In fact, it's a declaration
problem, since LENGTH is set to -1 when LIST=NIL, but is declared
as an INDEX. (Of course it's likely also a compiler problem, since
the compiler is supposed to signal type errors for this kind of
declaration error.) I fixed the misdeclaration, and noted the
possible compiler bug in BUGS.

After writing the new revised weird type declarations for the
not-necessarily positive LENGTH, and writing explanatory comments,
  ;; (Despite the name, LENGTH can be -1 when when LIST is an ATOM.)
for each of the cut-and-pasted (LET ((LENGTH ..)) ..) forms in BUTLAST
and NBUTLAST, I said "screw it" -- no, that's not it, I quoted Martin
Fowler and Kent Beck: "If you see the same code structure in more than
one place, you can be sure that your program will be better if you
find a way to unify them," and "It's surprising how often you look at
thickly commented code and notice that the comments are there because
the code is bad." So I just rewrote BUTLAST and NBUTLAST. Hopefully
the new versions will be better-behaved than the old ones.

Now that the INDEX type is used in DEFUN MAKE-GENSYM-LIST, which
belongs in early-extensions.lisp, INDEX should be defined before
early-extensions.lisp, i.e. earlier than its current definition in
early-c.lisp. Move it to early-extensions.lisp. Then to make that
work, since DEF!TYPE is used to define INDEX, defbangtype.lisp needs
to precede early-extensions.lisp in stems-and-flags.lisp-expr; so move
it. Also, INDEX is defined in terms of SB!XC:ARRAY-DIMENSION-LIMIT, so
early-array.lisp needs to move before the new location of
defbangtype.lisp. And then early-vm.lisp needs to move before that, so
I might as well move the rest of the early-vm-ish stuff back too. And
then DEFTYPE is used before deftype.lisp, so I need to change DEFMACRO
DEF!TYPE to DEF!MACRO DEF!TYPE, so I need to move defbangmacro.lisp
before deftype.lisp. (This is like a trip down memory lane to the
endless tweaks and recompiles it took me to find and unravel the
twisted order dependencies which make CMU CL unbootstrappable. Ah,
those were the days..:-)

The DEFTYPEs for INDEX and POSN in early-assem.lisp duplicate
the functionality of the SB-KERNEL:INDEX type.
  * Change uses of the SB-ASSEM::POSN type to uses of the INDEX type.
  * Delete the SB-ASSEM::POSN type and the SB-ASSEM::MAX-POSN constant.
  * Move SB-KERNEL:INDEX into SB-INT, since it's not really
    just a kernel-level thing, but makes sense for implementing
    user-level stuff in SB-INT and SB-EXT and SB-C (and SB-ASSEM).
  * Grep for all '[a-z]:+index[^-a-z]' and rename them (or just
    remove prefixes) to match new SB-INT-ness of INDEX.
  * Make the SB-ASSEM package use the SB-INT package; delete
    the SB-ASSEM::INDEX type and SB-ASSEM::MAX-INDEX constant.
    And since as a rule anything which can see SB-INT deserves
    to see SB-EXT too, make SB-ASSEM use SB-EXT as well.
  • Loading branch information
William Harold Newman committed Sep 22, 2000
1 parent c9c0e64 commit e4eb979
Show file tree
Hide file tree
Showing 6 changed files with 216 additions and 9 deletions.
2 changes: 1 addition & 1 deletion src/compiler/generic/genesis.lisp
Expand Up @@ -2807,7 +2807,7 @@ initially undefined function references:~2%")
(*data-page* 0))

(format t
"[building initial core file in file ~S: ~%"
"[building initial core file in ~S: ~%"
filenamestring)
(force-output)

Expand Down
2 changes: 1 addition & 1 deletion src/pcl/braid.lisp
Expand Up @@ -47,7 +47,7 @@
(i 0 (1+ i)))
((>= i no-of-slots)) ;endp rem-slots))
(declare (list rem-slots)
(type sb-kernel:index i))
(type sb-int:index i))
(setf (aref slots i) (first rem-slots)))
slots))
(t
Expand Down
6 changes: 3 additions & 3 deletions src/pcl/fngen.lisp
Expand Up @@ -109,10 +109,10 @@
new))

(defun fgen-test (fgen) (svref fgen 0))
(defun fgen-gensyms (fgen) (svref fgen 1))
(defun fgen-generator (fgen) (svref fgen 2))
(defun fgen-gensyms (fgen) (svref fgen 1))
(defun fgen-generator (fgen) (svref fgen 2))
(defun fgen-generator-lambda (fgen) (svref fgen 3))
(defun fgen-system (fgen) (svref fgen 4))
(defun fgen-system (fgen) (svref fgen 4))

(defun get-function-generator (lambda test-converter code-converter)
(let* ((test (compute-test lambda test-converter))
Expand Down
93 changes: 93 additions & 0 deletions tests/assertoid.lisp
@@ -0,0 +1,93 @@
;;;; the ASSERTOID macro, asserting something with added generality
;;;; to help in regression tests

(cl:in-package :cl-user)

;;; EXPR is an expression to evaluate (both with EVAL and with
;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
;;; expression to be tested in other than the default optimization
;;; level(s).
;;;
;;; The messiness with the various flavors of EXPECTED stuff is
;;; to handle various issues:
;;; * Some things are expected to signal errors instead of returning
;;; ordinary values.
;;; * Some things are expected to return multiple values.
;;; * Some things can return any of several values (e.g. generalized
;;; booleans).
;;; The default is to expect a generalized boolean true.
;;;
;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
;;; shorthand for special cases of EXPECTED-LAMBDA.
;;;
;;; Use EXPECTED-ERROR to require an error to be thrown. Use
;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and
;;; that further it satisfies the given lambda.
(defmacro assertoid (expr
&key
extra-optimizations
(expected-eql nil expected-eql-p)
(expected-equal nil expected-equal-p)
(expected-equalp nil expected-equalp-p)
(expected-lambda (cond
(expected-eql-p
(lambda (x)
(eql x (eval expected-eql))))
(expected-equal-p
(lambda (x)
(equal x (eval expected-equal))))
(expected-equalp-p
(lambda (x)
(equalp x (eval expected-equalp))))
(t
(lambda (x)
x)))
expected-lambda-p)
(expected-error-type nil expected-error-type-p)
(expected-error-lambda (if expected-error-type
(lambda (condition)
(typep condition
expected-error-type))
nil)
expected-error-lambda-p))
(when (> (count-if #'identity
(vector expected-eql-p
expected-equal-p
expected-equalp-p
expected-lambda-p
expected-error-type-p
expected-error-lambda-p))
1)
(error "multiple EXPECTED-FOO arguments"))
(when expected-error-lambda
(error "stub: expected-error functionality not supported yet"))
(let ((eval-expected-lambda (eval expected-lambda)))
(flet ((frob (evaloid)
(let ((result (funcall evaloid expr)))
(unless (funcall eval-expected-lambda result)
(error "failed assertoid" expr))))
(compile-as-evaloid (optimizations)
(lambda (expr)
(funcall (compile nil
`(lambda ()
(declare (optimize ,@optimizations))
,expr))))))
(frob #'eval)
(frob (compile-as-evaloid ()))
(dolist (i extra-optimizations)
(frob (compile-as-evaloid i))))))

;;; examples
(assertoid (= 2 (length (list 1 2))))
(assertoid (= 2 (length (list 1 2)))
:extra-optimizations (((speed 2) (space 3))
((speed 1) (space 3))))
(assertoid (cons 1 2)
:expected-lambda (lambda (x) (equal x '(1 . 2))))
(assertoid (cons (list 1 2) (list 1 2))
:expected-equal '((1 2) 1 2))
;;; not implemented yet:
#+nil (assertoid (length (eval (find-package :cl)))
:expected-error-type 'type-error)
103 changes: 103 additions & 0 deletions tests/map-tests.impure.lisp
@@ -0,0 +1,103 @@
(cl:in-package :cl-user)

(load "assertoid.lisp")

;;; tests of MAP
;;; FIXME: Move these into their own file.
(assertoid (map 'vector #'+ '(1 2 3) '(30 20))
:expected-equalp #(31 22))
(assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100))
:expected-equal '(201))

(defmacro with-mapnil-test-fun (fun-name &body body)
`(let ((reversed-result nil))
(flet ((,fun-name (&rest rest)
(push rest reversed-result)))
,@body
(nreverse reversed-result))))
(assertoid (with-mapnil-test-fun fun
(map nil #'fun #(1)))
:expected-equal '((1)))
(assertoid (with-mapnil-test-fun fun
(map nil #'fun #() '(1 2 3)))
:expected-equal '())
(assertoid (with-mapnil-test-fun fun
(map nil #'fun #(a b c) '(alpha beta) '(aleph beth)))
:expected-equal '((a alpha aleph) (b beta beth)))

;;; Exercise MAP repeatedly on the same dataset by providing various
;;; combinations of sequence type arguments, declarations, and so
;;; forth.
(defvar *list-1* '(1))
(defvar *list-2* '(1 2))
(defvar *list-3* '(1 2 3))
(defvar *list-4* '(1 2 3 4))
(defvar *vector-10* #(10))
(defvar *vector-20* #(10 20))
(defvar *vector-30* #(10 20 30))
(defmacro maptest (&key
result-seq
fun-name
arg-seqs
arg-types
(result-element-types '(t)))
(let ((reversed-assertoids nil))
(dotimes (arg-type-index (expt 2 (length arg-types)))
(labels (;; Arrange for EXPR to be executed.
(arrange (expr)
(push expr reversed-assertoids))
;; We toggle the various type declarations on and
;; off depending on the bit pattern in ARG-TYPE-INDEX,
;; so that we get lots of different things to test.
(eff-arg-type (i)
(if (and (< i (length arg-types))
(plusp (logand (expt 2 i)
arg-type-index)))
(nth i arg-types)
t))
(args-with-type-decls ()
(let ((reversed-result nil))
(dotimes (i (length arg-seqs) (nreverse reversed-result))
(push `(the ,(eff-arg-type i)
,(nth i arg-seqs))
reversed-result)))))
(dolist (fun `(',fun-name #',fun-name))
(dolist (result-type (cons 'list
(mapcan (lambda (et)
`((vector ,et)
(simple-array ,et 1)))
result-element-types)))
(arrange
`(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
:expected-equalp (coerce ,result-seq
',result-type)))))
(arrange
`(assertoid (mapcar (lambda (args) (apply #',fun-name args))
(with-mapnil-test-fun mtf
(map nil
;; (It would be nice to test MAP
;; NIL with function names, too,
;; but I can't see any concise way
;; to do it..)
#'mtf
,@(args-with-type-decls))))
:expected-equal (coerce ,result-seq 'list)))))
`(progn ,@(nreverse reversed-assertoids))))
(maptest :result-seq '(2 3)
:fun-name 1+
:arg-seqs (*list-2*)
:arg-types (list))
(maptest :result-seq '(nil nil nil)
:fun-name oddp
:arg-seqs (*vector-30*)
:arg-types (vector))
(maptest :result-seq '(12 24)
:fun-name +
:arg-seqs (*list-2* *list-2* *vector-30*)
:arg-types (list list vector))

(print "returning successfully")
(terpri)
;;(sb-impl::flush-standard-output-streams)
;;(finish-output)
(quit :unix-status 104)
19 changes: 15 additions & 4 deletions tests/run-tests.sh
Expand Up @@ -5,27 +5,38 @@
# how we invoke SBCL
sbcl=${1:-sbcl --noprint --noprogrammer}

# "Ten four" is the closest numerical slang I can find to "OK", so
# it's the return value we expect from a successful test.
tenfour () {
if [ $? = 104 ]; then
echo ok
else
echo test failed: $?
return 1
fi
}

# *.pure.lisp files are ordinary Lisp code with no side effects,
# and we can run them all in a single Lisp process.
(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl < pure.lisp
(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl ; tenfour

# *.impure.lisp files are Lisp code with side effects (e.g. doing DEFSTRUCT
# or DEFTYPE or DEFVAR). Each one needs to be run as a separate
# invocation of Lisp.
for f in *.impure.lisp; do
echo $f | $sbcl < pure.lisp
echo $f | $sbcl ; tenfour
done

# *.test.sh files are scripts to test stuff, typically stuff which can't
# so easily be tested within Lisp itself. A file foo.test.sh
# may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp,
# or foo.pl.
for f in *.test.sh; do
sh $f || exit failed test $f
sh $f ; tenfour
done

# *.assertoids files contain ASSERTOID statements to test things
# interpreted and at various compilation levels.
for f in *.assertoids; do
echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")'
echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' ; tenfour
done

0 comments on commit e4eb979

Please sign in to comment.