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

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

typo fix

File size: 25.0 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              ((<= 1 (caar adl) 3)
303                  (loop (cdr adl) (+ 1 len) 
304                        (cons (integer->char (caar adl))
305                              (cons (cdar adl) ret))))
306              (else
307                  (dnserr dns:ipv4->label
308                          "invalid ipv4 segment - " (cdar adl))))))
309
310
311;; (dns:ipv6->label addr zone)
312;; creates an ipv6 reverse lookup label
313(define (dns:ipv6->label addr zone)
314    (let loop ((adl   (map
315                          (lambda (x)
316                              (cons (string-length x) x))
317                          (string-split addr ":" #t)))
318               (len   0)
319               (pre   "")
320               (pce   #t)  ; #t for ret, #f for pre
321               (ret   zone))
322        (cond ((null? adl)
323                  (if (> len 32)
324                      (dnserr dns:ipv6->label "too many nibbles - " addr)
325                      (string-append pre
326                                     (string-join (map
327                                                      (lambda (x)
328                                                          "\x010")
329                                                      (iota (- 32 len)))
330                                                  "")
331                                     ret)))
332              ((= 0 (caar adl))
333                  (if pce
334                      (loop (cdr adl) len pre #f ret)
335                      (dnserr dns:ipv6->label "too many :: - " addr)))
336              ((= 1 (caar adl))
337                  (if pce
338                      (loop (cdr adl) (+ 2 len) pre pce
339                            (conc "\x01" (cdar adl) "\x010" ret))
340                      (loop (cdr adl) (+ 2 len)
341                            (conc "\x01" (cdar adl) "\x010" pre) pce ret)))
342              (else
343                  (let ((l   (string-join
344                                 (map
345                                     (lambda (x)
346                                         (string-append "\x01" (string x)))
347                                     (reverse (string->list (cdar adl))))
348                                 "")))
349                      (if pce
350                          (loop (cdr adl) (+ (caar adl) len) pre pce
351                                (string-append l ret))
352                          (loop (cdr adl) (+ (caar adl) len)
353                                (string-append l pre) pce ret)))))))
354
355
356
357;; socket functions
358
359;; (dns:send-udp server query verbose?)
360;; sends the query via udp
361(define (dns:send-udp server query verbose?)
362    (let ((sock   (socket-open* 'udp)))
363        (socket-connect! sock server 53)
364        (socket-send sock query)
365        (if (= 0 (socket-select sock 1))
366            (begin
367                (socket-close sock)
368                (dns:send-udp server query verbose?))
369            (receive (len data)
370                     (socket-recv sock 32768)
371                     (socket-close sock)
372                     (dns:parse-response server query data verbose?)))))
373
374
375;; (dns:send-tcp server query verbose?)
376;; sends the query via tcp
377(define (dns:send-tcp server query verbose?)
378    (let ((sock   (socket-open 'tcp)))
379        (socket-connect! sock server 53)
380        (socket-send sock (num->bstr16 (string-length query)))
381        (socket-send sock query)
382        (receive (len1 plen)
383                 (socket-recv sock 2)
384                 (receive (len2 data)
385                          (socket-recv sock (bstr16->num plen 0))
386                          (socket-close sock)
387                          (dns:parse-response server query data verbose?)))))
388
389
390
391;; query creation functions
392
393
394;; (dns:create-header recurse?)
395;; creates a new header for a dns query
396(define (dns:create-header recurse?)
397    (string-append (num->bstr16 (random 65536))
398                   (if recurse? "\x01" "\x00")
399                   "\x00\x00\x01\x00\x00\x00\x00\x00\x00"))
400
401
402;; (dns:create-query name type recurse?)
403;; creates a new query packet
404(define (dns:create-query name type recurse?)
405    (let ((qtype   (assoc type dns-types)))
406        (if qtype
407            (string-append (dns:create-header recurse?)
408                           name
409                           (num->bstr16 (caddr qtype))
410                           "\x00\x01")
411            (dnserr dns:create-query "invalid query type - " type))))
412
413
414
415;; response parser functions
416
417;; (dns:parse-response server query data verbose?)
418;; parses the response header and dispatch
419(define (dns:parse-response server query data verbose?)
420    (if (= 2 (fxand 2 (char->integer (string-ref data 2)))) ; truncated
421        (dns:send-tcp server query verbose?)
422        (let ((rcode   (fxand 15 (char->integer (string-ref data 3))))
423              (qd      (bstr16->num data 4))
424              (an      (bstr16->num data 6))
425              (ns      (bstr16->num data 8))
426              (ar      (bstr16->num data 10)))
427            (case rcode
428                  ((0)     (dns:parse-data qd an ns ar data verbose?))
429                  ((1)     (list (cons 'ERR "FORMERR")))
430                  ((2)     (list (cons 'ERR "SERVFAIL")))
431                  ((3)     (list (cons 'ERR "NXDOMAIN")))
432                  ((4)     (list (cons 'ERR "NOTIMPL")))
433                  ((5)     (list (cons 'ERR "REFUSED")))
434                  ((6)     (list (cons 'ERR "YXDOMAIN")))
435                  ((7)     (list (cons 'ERR "YXRRSET")))
436                  ((8)     (list (cons 'ERR "NXRRSET")))
437                  ((9)     (list (cons 'ERR "NOTAUTH")))
438                  ((10)    (list (cons 'ERR "NOTZONE")))
439                  (else    (list (cons 'ERR "UNKNOWN")))))))
440
441
442;; (dns:parse-data qdcnt ancnt nscnt arcnt data verbose?)
443;; parse the response data into RRs and dispatch
444(define (dns:parse-data qdcnt ancnt nscnt arcnt data verbose?)
445    (let ((qdr   (dns:parse-qrr data qdcnt)))
446        (if verbose?
447            (let loop1 ((off   (cdr qdr))
448                        (n     ancnt)
449                        (qdr   (car qdr))
450                        (anr   '()))
451                (if (= 0 n)
452                    (let loop2 ((off   off)
453                                (n     nscnt)
454                                (nsr   '()))
455                        (if (= 0 n)
456                            (let loop3 ((off   off)
457                                        (n     arcnt)
458                                        (arr   '()))
459                                (if (= 0 n)
460                                    (list (cons 'QUESTION (reverse qdr))
461                                          (cons 'ANSWER (reverse anr))
462                                          (cons 'AUTHORITY (reverse nsr))
463                                          (cons 'ADDITIONAL (reverse arr)))
464                                    (let ((a   (dns:parse-rr data off)))
465                                        (loop3 (cdr a) (- n 1)
466                                               (cons (car a) arr)))))
467                            (let ((a   (dns:parse-rr data off)))
468                                (loop2 (cdr a) (- n 1) (cons (car a) nsr)))))
469                    (let ((a   (dns:parse-rr data off)))
470                        (loop1 (cdr a) (- n 1) qdr (cons (car a) anr)))))
471            (let loop ((off   (cdr qdr))
472                       (n     ancnt)
473                       (ret   '()))
474                (if (= 0 n)
475                    (reverse ret)
476                    (let ((a   (dns:parse-rr data off)))
477                        (loop (cdr a) (- n 1) (cons (car a) ret))))))))
478
479
480;; (dns:parse-qrr data qdcnt)
481;; parses the question section of a response
482(define (dns:parse-qrr data qdcnt)
483    (let loop ((off   12)
484               (n     qdcnt)
485               (ret   '()))
486        (if (= 0 n)
487            (cons ret off)
488            (let ((l   (dns:label->name data off)))
489                (loop (+ 4 (cdr l)) (- n 1)
490                      (cons (list (car l)
491                                   (cdr (assoc (bstr16->num data (cdr l))
492                                               dns-qtypes))) ret))))))
493
494
495;; (dns:parse-rr data offset)
496;; parses the answer/authority/additional sections of a response
497(define (dns:parse-rr data offset)
498    (let* ((name    (dns:label->name data offset))
499           (type    (bstr16->num data (cdr name)))
500           (class   (bstr16->num data (+ 2 (cdr name))))
501           (ttl     (bstr16->num data (+ 4 (cdr name))))
502           (len     (bstr16->num data (+ 8 (cdr name))))
503           (rdata   (substring data (+ 10 (cdr name)) (+ 10 len (cdr name))))
504           (off     (+ 10 len (cdr name)))
505           (typen   (assoc type dns-qtypes)))
506        (if typen
507            (cons (list (car name)
508                        (cdr typen)
509                        ((cadddr (assoc (cdr typen) dns-types))
510                            data (+ 10 (cdr name)) rdata))
511                  off)
512            (cons (list (car name) type rdata) off))))
513
514
515;; (dns:parse-a data offset rdata)
516;; parses RRs returning ipv4 addresses
517(define (dns:parse-a data offset rdata)
518    (bstr32->ipv4 rdata))
519
520
521;; (dns:parse-label data offset rdata)
522;; parses RRs returning labels (domain names, etc)
523(define (dns:parse-label data offset rdata)
524    (car (dns:label->name data offset)))
525
526
527;; (dns:parse-txt data offset rdata)
528;; parses RRs returning character strings
529(define (dns:parse-txt data offset rdata)
530    (let loop ((off   0)
531               (len   (string-length rdata))
532               (ret   '()))
533        (if (>= off len)
534            (reverse ret)
535            (let ((l   (char->integer (string-ref data off))))
536                (loop (+ 1 len off) len
537                      (cons (substring data (+ 1 off) (+ off len)) ret))))))
538
539
540;; (dns:parse-aaaa data offset rdata)
541;; parses RRs returning ipv6 addresses
542(define (dns:parse-aaaa data offset rdata)
543    (bstr128->ipv6 rdata))
544
545
546;; (dns:parse-null data offset rdata)
547;; parses NULL RRs
548(define (dns:parse-null data offset rdata)
549    rdata)
550
551
552;; (dns:parse-mx data offset rdata)
553;; parses MX RRs
554(define (dns:parse-mx data offset rdata)
555    (cons (bstr16->num rdata 0)
556          (car (dns:label->name data (+ 2 offset)))))
557
558
559;; (dns:parse-soa data offset rdata)
560;; parses SOA RRs
561(define (dns:parse-soa data offset rdata)
562    (let* ((mn   (dns:label->name data offset))
563           (rn   (dns:label->name data (cdr mn))))
564        (list (car mn)
565              (car rn)
566              (bstr32->num data (cdr rn))
567              (bstr32->num data (+ 4 (cdr rn)))
568              (bstr32->num data (+ 8 (cdr rn)))
569              (bstr32->num data (+ 12 (cdr rn)))
570              (bstr32->num data (+ 16 (cdr rn))))))
571
572
573
574;; resolver functions
575
576;; (dns:resolve server domain #!optional recurse? verbose? type-list)
577;; resolves a name
578(define dns:resolve
579    (case-lambda
580        ((server domain)
581            (dns:resolve server domain #f #f '(A)))
582        ((server domain recurse?)
583            (dns:resolve server domain recurse? #f '(A)))
584        ((server domain recurse? verbose?)
585            (dns:resolve server domain recurse? verbose? '(A)))
586        ((server domain recurse? verbose? typelist)
587            (dns:handle-resolver server
588                                 (dns:name->label domain)
589                                 recurse? verbose? typelist))
590        (args
591            (dnserr dns:resolve "invalid args list - " args))))
592
593
594;; (dns:resolve-ip4 server ip #!optional recurse? verbose? zone type-list)
595;; resolves an ipv4 address
596(define dns:resolve-ip4
597    (case-lambda
598        ((server ip)
599            (dns:resolve-ip4 server ip #f #f default-ipv4 '(PTR)))
600        ((server ip recurse?)
601            (dns:resolve-ip4 server ip recurse? #f default-ipv4 '(PTR)))
602        ((server ip recurse? verbose?)
603            (dns:resolve-ip4 server ip recurse? verbose? default-ipv4 '(PTR)))
604        ((server ip recurse? verbose? zone)
605            (dns:resolve-ip4 server ip recurse? verbose? zone '(PTR)))
606        ((server ip recurse? verbose? zone typelist)
607            (dns:handle-resolver server
608                                 (dns:ipv4->label ip zone)
609                                 recurse? verbose? typelist))
610        (args
611            (dnserr dns:resolve-ip4 "invalid args list - " args))))
612
613
614;; (dns:resolve-ip6 server ip #!optional recurse? verbose? zone type-list)
615;; resolves an ipv6 address
616(define dns:resolve-ip6
617    (case-lambda
618        ((server ip)
619            (dns:resolve-ip6 server ip #f #f default-ipv6 '(PTR)))
620        ((server ip recurse?)
621            (dns:resolve-ip6 server ip recurse? #f default-ipv6 '(PTR)))
622        ((server ip recurse? verbose?)
623            (dns:resolve-ip6 server ip recurse? verbose? default-ipv6 '(PTR)))
624        ((server ip recurse? verbose? zone)
625            (dns:resolve-ip6 server ip recurse? verbose? zone '(PTR)))
626        ((server ip recurse? verbose? zone typelist)
627            (dns:handle-resolver server
628                                 (dns:ipv6->label ip zone)
629                                 recurse? verbose? typelist))
630        (args
631            (dnserr dns:resolve-ip6 "invalid args list - " args))))
632
633
634;; (dns:handle-resolver server qlabel recurse? verbose? typelist)
635;; creates and sends the queries
636(define (dns:handle-resolver server qlabel recurse? verbose? typelist)
637    (let ((ret   (map
638                     (lambda (x)
639                         (let ((q   (dns:create-query qlabel x recurse?)))
640                             (if (< (string-length q) 512)
641                                 (dns:send-udp server q verbose?)
642                                 (dns:send-tcp server q verbose?))))
643                     typelist)))
644        (if verbose?
645            (let loop ((l    ret)
646                       (er   '())
647                       (qd   '())
648                       (an   '())
649                       (ns   '())
650                       (ar   '()))
651               (cond ((null? l)
652                         (if (null? er)
653                             (list (delete-duplicates qd equal?)
654                                   (delete-duplicates an equal?)
655                                   (delete-duplicates ns equal?)
656                                   (delete-duplicates ar equal?))
657                             (list (cons 'ERROR er)
658                                   (delete-duplicates qd equal?)
659                                   (delete-duplicates an equal?)
660                                   (delete-duplicates ns equal?)
661                                   (delete-duplicates ar equal?))))
662                     ((= 1 (length (car l)))
663                         (loop (cdr l) (append er (car l)) qd an ns ar))
664                     (else
665                         (loop (cdr l)
666                               er
667                               (append qd (list-ref (car l) 0))
668                               (append an (list-ref (car l) 1))
669                               (append ns (list-ref (car l) 2))
670                               (append ar (list-ref (car l) 3))))))
671            (apply append ret))))
672
Note: See TracBrowser for help on using the repository browser.