mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Band-aid for issue #61.

Browse Source
This commit is contained in:
Gerd Heber 2015-08-02 11:17:46 -05:00
parent c52da283b7
commit 6cc1acf71b
2 changed files with 29 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/simplicial-sets.lisp
View File

@ -364,25 +364,27 @@
(- 1dlop (logcount right)))))))) (- 1dlop (logcount right))))))))
(DEFUN A-FACE4 (face indx dmns absm) (DEFUN A-FACE4 (face indx dmns absm)
(declare (declare
(type face face) (type face face)
(fixnum indx dmns) (fixnum indx dmns)
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm
(multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop) (dgop gmsm) absm
(declare (fixnum dgop2) (multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop)
#-(or ccl ecl lispworks sbcl) (declare (fixnum dgop2)
(type (or fixnum nil) 1dlop)) #-(or ccl ecl lispworks sbcl)
;; Bug LispWorks if this or-type defined (type (or fixnum nil) 1dlop))
(unless 1dlop ;; Bug LispWorks if this or-type defined
(return-from a-face4 (absm dgop2 gmsm))) (unless 1dlop
(locally (declare (fixnum 1dlop)) (return-from a-face4 (absm dgop2 gmsm)))
(let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) gmsm))) (locally (declare (fixnum 1dlop))
(declare (type absm gmsm-face)) (let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop))
(with-absm (dgop3 gmsm3) gmsm-face gmsm)))
(absm (dgop*dgop dgop2 dgop3) gmsm3)))))))) (declare (type absm gmsm-face))
(with-absm (dgop3 gmsm3) gmsm-face
(absm (dgop*dgop dgop2 dgop3) gmsm3))))))))
(DEFUN 1DGNR (indx absm) (DEFUN 1DGNR (indx absm)

19
test/suspensions-test.lisp
View File

@ -54,7 +54,7 @@
(cat:? scoal 3 7) (cat:? scoal 3 7)
(cat:cprd scoal 3 7))) (cat:cprd scoal 3 7)))
#|
(test suspension-face (test suspension-face
(cat:cat-init) (cat:cat-init)
(let* ((ss (cat:deltab)) (let* ((ss (cat:deltab))
@ -62,15 +62,22 @@
(m (cat:moore 2 3))) (m (cat:moore 2 3)))
(funcall face 4 4 15) (funcall face 4 4 15)
(funcall face 0 4 15) (funcall face 0 4 15)
(cat:check-faces #'cat:f-cmpr face 4 15) #+(or ecl sbcl)
(cat:check-faces #'cat:f-cmpr face 3 7) (signals type-error (cat:check-faces #'cat:f-cmpr face 4 15))
(cat:check-faces #'cat:f-cmpr face 2 3) #+(or ecl sbcl)
(signals type-error (cat:check-faces #'cat:f-cmpr face 3 7))
#+(or ecl sbcl)
(signals type-error (cat:check-faces #'cat:f-cmpr face 2 3))
#-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 4 15)
#-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 3 7)
#-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 2 3)
(setf face (cat:suspension-face (cat:face m))) (setf face (cat:suspension-face (cat:face m)))
(dotimes (i 5) (print (funcall face i 4 'm3))) (dotimes (i 5) (print (funcall face i 4 'm3)))
(dotimes (i 6) (print (funcall face i 5 'mm4))) (dotimes (i 6) (print (funcall face i 5 'mm4)))
(cat:check-faces #'cat:s-cmpr face 4 'm3) (cat:check-faces #'cat:s-cmpr face 4 'm3)
(cat:check-faces #'cat:s-cmpr face 5 'mm4))) (cat:check-faces #'cat:s-cmpr face 5 'mm4)
|# ))
(test suspension1 (test suspension1
(cat:cat-init) (cat:cat-init)