source: project/release/3/dns/dns.scm @ 12008

Last change on this file since 12008 was 12008, checked in by elf, 13 years ago

error in resolution

File size: 25.1 KB
Line 
1;;;
2;;; dns.scm - domain name service lookups
3;;; written by elf@ephemeral.net
4;;; dialect:  r6rs with chicken sockets
5;;; srfis:    1, 6, 13, 23
6;;;
7
8;;; a simple dns resolver interface.
9;;;
10;;; meta functions:
11;;;
12;;; (dns:supported-types)
13;;; (dns:supported-types-verbose)
14;;; list of supported query types.  supported-types-verbose returns pairs
15;;; of (type . description).
16;;;
17;;; (dns:name->label <name>)
18;;; encodes <name> (string) into dns label format.
19;;;
20;;;
21;;; resolution:
22;;;
23;;; (dns:resolve <server> <domain> [recurse?] [verbose?] [type-list])
24;;; resolves <domain> (domain name string) by querying <server> (string).
25;;; recurse? is an optional boolean for whether recursive queries are desired.
26;;; verbose? is an optional boolean - if #t, return all RRs, not just answer.
27;;; type=list is an optional list of query types (see dns:supported-types).
28;;; default query type is A.
29;;;
30;;; (dns:resolve-ip4 <server> <ip> [recurse?] [verbose?] [zone] [type-list])
31;;; resolves <ip> (ipv4 string) by querying <server> (string).
32;;; recurse? is an optional boolean for whether recursive queries are desired.
33;;; verbose? is an optional boolean - if #t, return all RRs, not just answer.
34;;; zone is a label (see dns:name->label) to append to the reversed ip.
35;;; type-list is an optional list of query types (see dns:supported-types).
36;;; default query type is PTR.
37;;; default zone is in-addr.arpa.
38;;;
39;;; (dns:resolve-ip6 <server> <ip> [recurse?] [verbose?] [zone] [type-list])
40;;; resolves <ip> (ipv6 string) by querying <server> (string).
41;;; recurse? is an optional boolean for whether recursive queries are desired.
42;;; verbose? is an optional boolean - if #t, return all RRs, not just answer.
43;;; zone is a label (see dns:name->label) to append to the reversed ip.
44;;; type-list is an optional list of query types (see dns:supported-types).
45;;; default query type is PTR.
46;;; default zone is ip6.arpa.
47;;;
48
49
50
51(use syntax-case)  ; chicken define-syntax
52(use srfi-1)       ; list library
53(use srfi-6)       ; string ports
54(use srfi-13)      ; string library
55(use srfi-16)      ; case-lambda
56(use srfi-23)      ; error reporting
57(use sockets)      ; socket handling
58
59
60
61(eval-when (compile)
62    (declare
63        ;(unit dns)
64        (import "sockets")
65        (uses library eval extras srfi-1 srfi-13)
66        (bound-to-procedure dns:supported-types
67                            dns:supported-types-verbose
68                            dns:name->label
69                            dns:resolve
70                            dns:resolve-ip4
71                            dns:resolve-ip6
72                            dns:parse-a
73                            dns:parse-label
74                            dns:parse-soa
75                            dns:parse-null
76                            dns:parse-mx
77                            dns:parse-txt
78                            dns:parse-aaaa
79                            num->bstr16
80                            bstr16->num
81                            num->bstr32
82                            bstr32->num
83                            bstr32->ipv4
84                            bstr128->ipv6
85                            dns:label->name
86                            dns:ipv4->label
87                            dns:ipv6->label
88                            dns:send-udp
89                            dns:send-tcp
90                            dns:parse-response
91                            dns:parse-data
92                            dns:parse-qrr
93                            dns:parse-rr
94                            dns:create-header
95                            dns:create-query
96                            dns:handle-resolver
97                            )
98        (always-bound dns:parse-a
99                      dns:parse-label
100                      dns:parse-soa
101                      dns:parse-null
102                      dns:parse-mx
103                      dns:parse-txt
104                      dns:parse-aaaa
105                      )
106        (export dns:supported-types
107                dns:supported-types-verbose
108                dns:name->label
109                dns:resolve
110                dns:resolve-ip4
111                dns:resolve-ip6)
112        (run-time-macros)
113        (inline)
114        (fixnum-arithmetic)
115        (no-bound-checks)
116        (no-procedure-checks)
117        (standard-bindings)
118        (extended-bindings)
119        (usual-integrations)))
120
121
122
123;; constants
124
125;; this is necessary so that dns-types will load correctly
126(define-syntax wrap
127    (syntax-rules ()
128        ((_ f)
129            (lambda (data offset rdata) (f data offset rdata)))))
130
131
132;; dns-types
133;; (type-symbol description type-num parser)
134(define dns-types
135    (list (list 'A      "ipv4 address"              1    (wrap dns:parse-a))
136          (list 'NS     "name server"               2    (wrap dns:parse-label))
137          (list 'CNAME  "canonical name for alias"  5    (wrap dns:parse-label))
138          (list 'SOA    "start of authority"        6    (wrap dns:parse-soa))
139          (list 'NULL   "null (anything)"           10   (wrap dns:parse-null))
140          (list 'PTR    "domain name pointer"       12   (wrap dns:parse-label))
141          (list 'MX     "mail exchanger"            15   (wrap dns:parse-mx))
142          (list 'TXT    "text strings"              16   (wrap dns:parse-txt))
143          (list 'AAAA   "ipv6 address"              28   (wrap dns:parse-aaaa))
144          (list 'SPF    "SPF records"               99   (wrap dns:parse-txt))
145          (list 'ANY    "all matching records"      255  #f)))
146
147(define dns-qtypes
148    (map
149        (lambda (x)
150            (cons (caddr x) (car x)))
151        dns-types))
152
153
154;; default strings
155(define default-null    "\x00")
156(define default-ipv4    "\x07in-addr\x04arpa\x00")
157(define default-ipv6    "\x03ip6\x04arpa\x00")
158
159
160
161;; utility functions
162
163;; (dnserr func-name str ...)
164;; throws an error, whose message is composed by appending str ...
165(define-syntax dnserr
166    (syntax-rules ()
167        ((_ func str ...)
168            (error 'func (conc str ...)))))
169
170
171;; (dns:supported-types)
172;; get the list of supported query types
173(define (dns:supported-types)
174    (map car dns-types))
175
176
177;; (dns:supported-types-verbose)
178;; get the list of supported query types with descriptions
179(define (dns:supported-types-verbose)
180    (map
181        (lambda (x)
182            (cons (car x) (cdar x)))
183        dns-types))
184
185
186;; (num->bstr16 n)
187;; converts an integer to a 2 octet string
188(define (num->bstr16 n)
189    (string (integer->char (fxshr (fxand n (fxshl 255 8)) 8))
190            (integer->char (fxand n 255))))
191
192
193;; (bstr16->num str offset)
194;; converts a 2 octet string (at offset) to an integer
195(define (bstr16->num str offset)
196    (+ (fxshl (char->integer (string-ref str offset)) 8)
197       (char->integer (string-ref str (+ 1 offset)))))
198
199
200;; (num->bstr32 n)
201;; converts an integer to a 4 octet string
202(define (num->bstr32 n)
203    (string (integer->char (fxshr (fxand n (fxshl 255 24)) 24))
204            (integer->char (fxshr (fxand n (fxshl 255 16)) 16))
205            (integer->char (fxshr (fxand n (fxshl 255 8)) 8))
206            (integer->char (fxand n 255))))
207
208
209;; (bstr32->num str offset)
210;; converts a 4 octet string (at offset) to an integer
211(define (bstr32->num str offset)
212    (+ (fxshl (char->integer (string-ref str offset)) 24)
213       (fxshl (char->integer (string-ref str (+ 1 offset))) 16)
214       (fxshl (char->integer (string-ref str (+ 2 offset))) 8)
215       (char->integer (string-ref str (+ 3 offset)))))
216
217
218;; (bstr32->ipv4 str)
219;; converts a 4 octet string to an ipv4 address
220(define (bstr32->ipv4 str)
221    (string-append (number->string (char->integer (string-ref str 0))) "."
222                   (number->string (char->integer (string-ref str 1))) "."
223                   (number->string (char->integer (string-ref str 2))) "."
224                   (number->string (char->integer (string-ref str 3)))))
225
226
227;; (bstr128->ipv6 str)
228;; converts a 16 octet string to an ipv6 address
229(define (bstr128->ipv6 str)
230    (string-join
231        (map
232            (lambda (x)
233                (let ((n   (number->string (char->integer x) 16)))
234                    (if (= 1 (string-length n))
235                        (string-append "0" n)
236                        n)))
237            (string->list str))
238        ":"))
239
240
241;; (dns:name->label name)
242;; encodes name as a dns label
243(define (dns:name->label name)
244    (let loop ((hnl   (map
245                          (lambda (x)
246                              (cons (integer->char (string-length x)) x))
247                          (string-split name "." #t)))
248               (zer   #f)
249               (ret   '()))
250        (cond ((null? hnl)
251                  (apply conc (reverse (cons default-null ret))))
252              (zer
253                  (dnserr dns:name->label "consecutive dots in name - " name))
254              ((eq? #\nul (caar hnl))
255                  (loop (cdr hnl) #t ret))
256              ((char<? (caar hnl) #\@)
257                  (loop (cdr hnl) zer (cons (cdar hnl) (cons (caar hnl) ret))))
258              (else
259                  (dnserr dns:name->label "segment too long - " (cdar hnl))))))
260
261
262;; (dns:label->name data offset)
263;; returns a pair - (name . offset)
264;; where name is the label translated into a name,
265;;       offset is the position after the label
266;; (this handles compression properly)
267(define (dns:label->name data offset)
268    (let loop ((off   offset)
269               (len   (char->integer (string-ref data offset)))
270               (ret   ""))
271        (cond ((> len 63)
272                  (cons (string-append
273                            ret
274                            (car (dns:label->name
275                                     data
276                                     (fxand 16383 (bstr16->num data off)))))
277                        (+ off 2)))
278              ((= len 0)
279                  (cons ret (+ 1 off)))
280              (else
281                  (let ((t   (+ 1 off len)))
282                      (loop t
283                            (char->integer (string-ref data t))
284                            (string-append ret
285                                           (substring data (+ 1 off) t)
286                                           ".")))))))
287
288
289;; (dns:ipv4->label addr zone)
290;; creates an ipv4 reverse lookup label
291(define (dns:ipv4->label addr zone)
292    (let loop ((adl   (map
293                          (lambda (x)
294                              (cons (string-length x) x))
295                          (string-split addr "." #t)))
296               (len   0)
297               (ret   '()))
298        (cond ((null? adl)
299                  (if (> len 4)
300                      (dnserr dns:ipv4->label "too many octets - " addr)
301                      (string-append (apply conc ret) zone)))
302              ((not (string->number (cdar adl)))
303                  (dnserr dns:ipv4->label
304                          "invalid ipv4 segment - " (cdar adl)))
305              ((<= 1 (caar adl) 3)
306                  (loop (cdr adl) (+ 1 len) 
307                        (cons (integer->char (caar adl))
308                              (cons (cdar adl) ret))))
309              (else
310                  (dnserr dns:ipv4->label
311                          "invalid ipv4 segment - " (cdar adl))))))
312
313
314;; (dns:ipv6->label addr zone)
315;; creates an ipv6 reverse lookup label
316(define (dns:ipv6->label addr zone)
317    (let loop ((adl   (map
318                          (lambda (x)
319                              (cons (string-length x) x))
320                          (string-split addr ":" #t)))
321               (len   0)
322               (pre   "")
323               (pce   #t)  ; #t for ret, #f for pre
324               (ret   zone))
325        (cond ((null? adl)
326                  (if (> len 32)
327                      (dnserr dns:ipv6->label "too many nibbles - " addr)
328                      (string-append pre
329                                     (string-join (map
330                                                      (lambda (x)
331                                                          "\x010")
332                                                      (iota (- 32 len)))
333                                                  "")
334                                     ret)))
335              ((= 0 (caar adl))
336                  (if pce
337                      (loop (cdr adl) len pre #f ret)
338                      (dnserr dns:ipv6->label "too many :: - " addr)))
339              ((= 1 (caar adl))
340                  (if pce
341                      (loop (cdr adl) (+ 2 len) pre pce
342                            (conc "\x01" (cdar adl) "\x010" ret))
343                      (loop (cdr adl) (+ 2 len)
344                            (conc "\x01" (cdar adl) "\x010" pre) pce ret)))
345              (else
346                  (let ((l   (string-join
347                                 (map
348                                     (lambda (x)
349                                         (string-append "\x01" (string x)))
350                                     (reverse (string->list (cdar adl))))
351                                 "")))
352                      (if pce
353                          (loop (cdr adl) (+ (caar adl) len) pre pce
354                                (string-append l ret))
355                          (loop (cdr adl) (+ (caar adl) len)
356                                (string-append l pre) pce ret)))))))
357
358
359
360;; socket functions
361
362;; (dns:send-udp server query verbose?)
363;; sends the query via udp
364(define (dns:send-udp server query verbose?)
365    (let ((sock   (socket-open* 'udp)))
366        (socket-connect! sock server 53)
367        (socket-send sock query)
368        (if (= 0 (socket-select sock 1))
369            (begin
370                (socket-close sock)
371                (dns:send-udp server query verbose?))
372            (receive (len data)
373                     (socket-recv sock 32768)
374                     (socket-close sock)
375                     (dns:parse-response server query data verbose?)))))
376
377
378;; (dns:send-tcp server query verbose?)
379;; sends the query via tcp
380(define (dns:send-tcp server query verbose?)
381    (let ((sock   (socket-open 'tcp)))
382        (socket-connect! sock server 53)
383        (socket-send sock (num->bstr16 (string-length query)))
384        (socket-send sock query)
385        (receive (len1 plen)
386                 (socket-recv sock 2)
387                 (receive (len2 data)
388                          (socket-recv sock (bstr16->num plen 0))
389                          (socket-close sock)
390                          (dns:parse-response server query data verbose?)))))
391
392
393
394;; query creation functions
395
396
397;; (dns:create-header recurse?)
398;; creates a new header for a dns query
399(define (dns:create-header recurse?)
400    (string-append (num->bstr16 (random 65536))
401                   (if recurse? "\x01" "\x00")
402                   "\x00\x00\x01\x00\x00\x00\x00\x00\x00"))
403
404
405;; (dns:create-query name type recurse?)
406;; creates a new query packet
407(define (dns:create-query name type recurse?)
408    (let ((qtype   (assoc type dns-types)))
409        (if qtype
410            (string-append (dns:create-header recurse?)
411                           name
412                           (num->bstr16 (caddr qtype))
413                           "\x00\x01")
414            (dnserr dns:create-query "invalid query type - " type))))
415
416
417
418;; response parser functions
419
420;; (dns:parse-response server query data verbose?)
421;; parses the response header and dispatch
422(define (dns:parse-response server query data verbose?)
423    (if (= 2 (fxand 2 (char->integer (string-ref data 2)))) ; truncated
424        (dns:send-tcp server query verbose?)
425        (let ((rcode   (fxand 15 (char->integer (string-ref data 3))))
426              (qd      (bstr16->num data 4))
427              (an      (bstr16->num data 6))
428              (ns      (bstr16->num data 8))
429              (ar      (bstr16->num data 10)))
430            (case rcode
431                  ((0)     (dns:parse-data qd an ns ar data verbose?))
432                  ((1)     (list (cons 'ERR "FORMERR")))
433                  ((2)     (list (cons 'ERR "SERVFAIL")))
434                  ((3)     (list (cons 'ERR "NXDOMAIN")))
435                  ((4)     (list (cons 'ERR "NOTIMPL")))
436                  ((5)     (list (cons 'ERR "REFUSED")))
437                  ((6)     (list (cons 'ERR "YXDOMAIN")))
438                  ((7)     (list (cons 'ERR "YXRRSET")))
439                  ((8)     (list (cons 'ERR "NXRRSET")))
440                  ((9)     (list (cons 'ERR "NOTAUTH")))
441                  ((10)    (list (cons 'ERR "NOTZONE")))
442                  (else    (list (cons 'ERR "UNKNOWN")))))))
443
444
445;; (dns:parse-data qdcnt ancnt nscnt arcnt data verbose?)
446;; parse the response data into RRs and dispatch
447(define (dns:parse-data qdcnt ancnt nscnt arcnt data verbose?)
448    (let ((qdr   (dns:parse-qrr data qdcnt)))
449        (if verbose?
450            (let loop1 ((off   (cdr qdr))
451                        (n     ancnt)
452                        (qdr   (car qdr))
453                        (anr   '()))
454                (if (= 0 n)
455                    (let loop2 ((off   off)
456                                (n     nscnt)
457                                (nsr   '()))
458                        (if (= 0 n)
459                            (let loop3 ((off   off)
460                                        (n     arcnt)
461                                        (arr   '()))
462                                (if (= 0 n)
463                                    (list (cons 'QUESTION (reverse qdr))
464                                          (cons 'ANSWER (reverse anr))
465                                          (cons 'AUTHORITY (reverse nsr))
466                                          (cons 'ADDITIONAL (reverse arr)))
467                                    (let ((a   (dns:parse-rr data off)))
468                                        (loop3 (cdr a) (- n 1)
469                                               (cons (car a) arr)))))
470                            (let ((a   (dns:parse-rr data off)))
471                                (loop2 (cdr a) (- n 1) (cons (car a) nsr)))))
472                    (let ((a   (dns:parse-rr data off)))
473                        (loop1 (cdr a) (- n 1) qdr (cons (car a) anr)))))
474            (let loop ((off   (cdr qdr))
475                       (n     ancnt)
476                       (ret   '()))
477                (if (= 0 n)
478                    (reverse ret)
479                    (let ((a   (dns:parse-rr data off)))
480                        (loop (cdr a) (- n 1) (cons (car a) ret))))))))
481
482
483;; (dns:parse-qrr data qdcnt)
484;; parses the question section of a response
485(define (dns:parse-qrr data qdcnt)
486    (let loop ((off   12)
487               (n     qdcnt)
488               (ret   '()))
489        (if (= 0 n)
490            (cons ret off)
491            (let ((l   (dns:label->name data off)))
492                (loop (+ 4 (cdr l)) (- n 1)
493                      (cons (list (car l)
494                                   (cdr (assoc (bstr16->num data (cdr l))
495                                               dns-qtypes))) ret))))))
496
497
498;; (dns:parse-rr data offset)
499;; parses the answer/authority/additional sections of a response
500(define (dns:parse-rr data offset)
501    (let* ((name    (dns:label->name data offset))
502           (type    (bstr16->num data (cdr name)))
503           (class   (bstr16->num data (+ 2 (cdr name))))
504           (ttl     (bstr16->num data (+ 4 (cdr name))))
505           (len     (bstr16->num data (+ 8 (cdr name))))
506           (rdata   (substring data (+ 10 (cdr name)) (+ 10 len (cdr name))))
507           (off     (+ 10 len (cdr name)))
508           (typen   (assoc type dns-qtypes)))
509        (if typen
510            (cons (list (car name)
511                        (cdr typen)
512                        ((cadddr (assoc (cdr typen) dns-types))
513                            data (+ 10 (cdr name)) rdata))
514                  off)
515            (cons (list (car name) type rdata) off))))
516
517
518;; (dns:parse-a data offset rdata)
519;; parses RRs returning ipv4 addresses
520(define (dns:parse-a data offset rdata)
521    (bstr32->ipv4 rdata))
522
523
524;; (dns:parse-label data offset rdata)
525;; parses RRs returning labels (domain names, etc)
526(define (dns:parse-label data offset rdata)
527    (car (dns:label->name data offset)))
528
529
530;; (dns:parse-txt data offset rdata)
531;; parses RRs returning character strings
532(define (dns:parse-txt data offset rdata)
533    (let loop ((off   0)
534               (len   (string-length rdata))
535               (ret   '()))
536        (if (>= off len)
537            (reverse ret)
538            (let ((l   (char->integer (string-ref data off))))
539                (loop (+ 1 len off) len
540                      (cons (substring data (+ 1 off) (+ off len)) ret))))))
541
542
543;; (dns:parse-aaaa data offset rdata)
544;; parses RRs returning ipv6 addresses
545(define (dns:parse-aaaa data offset rdata)
546    (bstr128->ipv6 rdata))
547
548
549;; (dns:parse-null data offset rdata)
550;; parses NULL RRs
551(define (dns:parse-null data offset rdata)
552    rdata)
553
554
555;; (dns:parse-mx data offset rdata)
556;; parses MX RRs
557(define (dns:parse-mx data offset rdata)
558    (cons (bstr16->num rdata 0)
559          (car (dns:label->name data (+ 2 offset)))))
560
561
562;; (dns:parse-soa data offset rdata)
563;; parses SOA RRs
564(define (dns:parse-soa data offset rdata)
565    (let* ((mn   (dns:label->name data offset))
566           (rn   (dns:label->name data (cdr mn))))
567        (list (car mn)
568              (car rn)
569              (bstr32->num data (cdr rn))
570              (bstr32->num data (+ 4 (cdr rn)))
571              (bstr32->num data (+ 8 (cdr rn)))
572              (bstr32->num data (+ 12 (cdr rn)))
573              (bstr32->num data (+ 16 (cdr rn))))))
574
575
576
577;; resolver functions
578
579;; (dns:resolve server domain #!optional recurse? verbose? type-list)
580;; resolves a name
581(define dns:resolve
582    (case-lambda
583        ((server domain)
584            (dns:resolve server domain #f #f '(A)))
585        ((server domain recurse?)
586            (dns:resolve server domain recurse? #f '(A)))
587        ((server domain recurse? verbose?)
588            (dns:resolve server domain recurse? verbose? '(A)))
589        ((server domain recurse? verbose? typelist)
590            (dns:handle-resolver server
591                                 (dns:name->label domain)
592                                 recurse? verbose? typelist))
593        (args
594            (dnserr dns:resolve "invalid args list - " args))))
595
596
597;; (dns:resolve-ip4 server ip #!optional recurse? verbose? zone type-list)
598;; resolves an ipv4 address
599(define dns:resolve-ip4
600    (case-lambda
601        ((server ip)
602            (dns:resolve-ip4 server ip #f #f default-ipv4 '(PTR)))
603        ((server ip recurse?)
604            (dns:resolve-ip4 server ip recurse? #f default-ipv4 '(PTR)))
605        ((server ip recurse? verbose?)
606            (dns:resolve-ip4 server ip recurse? verbose? default-ipv4 '(PTR)))
607        ((server ip recurse? verbose? zone)
608            (dns:resolve-ip4 server ip recurse? verbose? zone '(PTR)))
609        ((server ip recurse? verbose? zone typelist)
610            (dns:handle-resolver server
611                                 (dns:ipv4->label ip zone)
612                                 recurse? verbose? typelist))
613        (args
614            (dnserr dns:resolve-ip4 "invalid args list - " args))))
615
616
617;; (dns:resolve-ip6 server ip #!optional recurse? verbose? zone type-list)
618;; resolves an ipv6 address
619(define dns:resolve-ip6
620    (case-lambda
621        ((server ip)
622            (dns:resolve-ip6 server ip #f #f default-ipv6 '(PTR)))
623        ((server ip recurse?)
624            (dns:resolve-ip6 server ip recurse? #f default-ipv6 '(PTR)))
625        ((server ip recurse? verbose?)
626            (dns:resolve-ip6 server ip recurse? verbose? default-ipv6 '(PTR)))
627        ((server ip recurse? verbose? zone)
628            (dns:resolve-ip6 server ip recurse? verbose? zone '(PTR)))
629        ((server ip recurse? verbose? zone typelist)
630            (dns:handle-resolver server
631                                 (dns:ipv6->label ip zone)
632                                 recurse? verbose? typelist))
633        (args
634            (dnserr dns:resolve-ip6 "invalid args list - " args))))
635
636
637;; (dns:handle-resolver server qlabel recurse? verbose? typelist)
638;; creates and sends the queries
639(define (dns:handle-resolver server qlabel recurse? verbose? typelist)
640    (let ((ret   (map
641                     (lambda (x)
642                         (let ((q   (dns:create-query qlabel x recurse?)))
643                             (if (< (string-length q) 512)
644                                 (dns:send-udp server q verbose?)
645                                 (dns:send-tcp server q verbose?))))
646                     typelist)))
647        (if verbose?
648            (let loop ((l    ret)
649                       (er   '())
650                       (qd   '())
651                       (an   '())
652                       (ns   '())
653                       (ar   '()))
654               (cond ((null? l)
655                         (if (null? er)
656                             (list (delete-duplicates qd equal?)
657                                   (delete-duplicates an equal?)
658                                   (delete-duplicates ns equal?)
659                                   (delete-duplicates ar equal?))
660                             (list (cons 'ERROR er)
661                                   (delete-duplicates qd equal?)
662                                   (delete-duplicates an equal?)
663                                   (delete-duplicates ns equal?)
664                                   (delete-duplicates ar equal?))))
665                     ((= 1 (length (car l)))
666                         (loop (cdr l) (append er (car l)) qd an ns ar))
667                     (else
668                         (loop (cdr l)
669                               er
670                               (append qd (list-ref (car l) 0))
671                               (append an (list-ref (car l) 1))
672                               (append ns (list-ref (car l) 2))
673                               (append ar (list-ref (car l) 3))))))
674            (apply append ret))))
675
Note: See TracBrowser for help on using the repository browser.