File: list-interface.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (46 lines) | stat: -rw-r--r-- 1,377 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


;  ,open interfaces packages meta-types sort syntactic
;  ,config scheme

(define (list-interface thing)
  (cond ((structure? thing)
	 (list-interface-1 (structure-interface thing)
			   (lambda (name)
			     (let ((x (structure-lookup thing name #t)))
			       (if (binding? x)
				   (binding-type x)
				   #f)))))
	((interface? thing)
	 (list-interface-1 thing (lambda (name)
				   (interface-ref thing name))))
	(else '?)))

(define (list-interface-1 int lookup)
  (let ((l '()))
    (for-each-declaration (lambda (name type)
			    (if (not (memq name l))  ;compound signatures...
				(set! l (cons name l))))
			  int)
    (for-each (lambda (name)
		(write name)
		(display (make-string
			  (max 0 (- 25 (string-length
					(symbol->string name))))
			  #\space))
		(write-char #\space)
		(write (careful-type->sexp (lookup name)))    ;( ...)
		(newline))
	      (sort-list l (lambda (name1 name2)
			     (string<? (symbol->string name1)
				       (symbol->string name2)))))))

(define (careful-type->sexp thing)
  (cond ((not thing) 'undefined)
	((or (symbol? thing) (null? thing) (number? thing))
	 thing)     ;?
	((pair? thing)    ;e.g. (variable #{Type :value})
	 (cons (careful-type->sexp (car thing))
	       (careful-type->sexp (cdr thing))))
	(else (type->sexp thing #t))))