suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 51565c302ae92857a1a41e2955e4567ffeb1515a
This commit is contained in:
Matthew Flatt 2002-09-04 19:25:45 +00:00
parent 307f479a4d
commit e3aaa0f699
1 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/mred/mred.ss
View File

@ -6150,18 +6150,22 @@
(unless (and (list? style) (andmap symbol? style))
(raise-type-error (who->name who) "list of style symbols" style))
(when reqd
(unless (ormap (lambda (i) (memq i reqd)) style)
(raise-type-error (who->name who)
(format "style list including ~a"
(if (= (length reqd) 1)
(car reqd)
(string-append
"one of "
(let loop ([l reqd])
(if (null? (cdr l))
(format "or ~a" (car l))
(format "~a, ~a" (car l) (loop (cdr l))))))))
style)))
(letrec ([or-together (lambda (l)
(if (= (length l) 2)
(format "~a or ~a" (car l) (cadr l))
(let loop ([l l])
(if (null? (cdr l))
(format "or ~a" (car l))
(format "~a, ~a" (car l) (loop (cdr l)))))))])
(unless (ormap (lambda (i) (memq i reqd)) style)
(raise-type-error (who->name who)
(format "style list, missing ~a"
(if (= (length reqd) 1)
(car reqd)
(string-append
"one of "
(or-together reqd))))
style))))
(if (and (not reqd) (null? other-allowed))
(unless (null? style)
(raise-type-error (who->name who) "empty style list" style))