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))))))))
(DEFUN A-FACE4 (face indx dmns absm)
(DEFUN A-FACE4 (face indx dmns absm)
(declare
(type face face)
(fixnum indx dmns)
(type absm absm))
(the absm
(with-absm (dgop gmsm) absm
(multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop)
(declare (fixnum dgop2)
#-(or ccl ecl lispworks sbcl)
(type (or fixnum nil) 1dlop))
;; Bug LispWorks if this or-type defined
(unless 1dlop
(return-from a-face4 (absm dgop2 gmsm)))
(locally (declare (fixnum 1dlop))
(let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) gmsm)))
(declare (type absm gmsm-face))
(with-absm (dgop3 gmsm3) gmsm-face
(absm (dgop*dgop dgop2 dgop3) gmsm3))))))))
(with-absm
(dgop gmsm) absm
(multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop)
(declare (fixnum dgop2)
#-(or ccl ecl lispworks sbcl)
(type (or fixnum nil) 1dlop))
;; Bug LispWorks if this or-type defined
(unless 1dlop
(return-from a-face4 (absm dgop2 gmsm)))
(locally (declare (fixnum 1dlop))
(let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop))
gmsm)))
(declare (type absm gmsm-face))
(with-absm (dgop3 gmsm3) gmsm-face
(absm (dgop*dgop dgop2 dgop3) gmsm3))))))))
(DEFUN 1DGNR (indx absm)

19
test/suspensions-test.lisp
View File

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