diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index ce0fdb37..5813c692 100644 --- a/lib/chibi/ast.scm +++ b/lib/chibi/ast.scm @@ -356,11 +356,11 @@ ;;> Returns the first string cursor of @var{pat} in @var{str}, ;;> of @scheme{#f} if it's not found. -;;> @subsubsubsection{@scheme{(atomically @var{expr})}} +;;> @subsubsubsection{@scheme{(atomically expr)}} -;;> Run @var{expr} atomically, disabling yields. Ideally should only -;;> be used for brief, deterministic expressions. If used incorrectly -;;> (e.g. running an infinite loop) can render the system unusable. +;;> Run @var{expr} atomically, disabling yields. Ideally should only be +;;> used for brief, deterministic expressions. If used incorrectly (e.g. +;;> running an infinite loop) can render the system unusable. ;;> Never expose to a sandbox. (cond-expand diff --git a/lib/chibi/generic.scm b/lib/chibi/generic.scm index ea914de9..e52fc4c4 100644 --- a/lib/chibi/generic.scm +++ b/lib/chibi/generic.scm @@ -24,8 +24,8 @@ (define-syntax define-method (er-macro-transformer (lambda (e r c) - (let ((name (caadr e)) - (params (cdadr e)) + (let ((name (car (cadr e))) + (params (cdr (cadr e))) (body (cddr e))) `(,(r 'generic-add!) ,name (,(r 'list) ,@(map cadr params)) diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm index 320246d3..96b1b91b 100644 --- a/lib/chibi/loop/loop.scm +++ b/lib/chibi/loop/loop.scm @@ -44,7 +44,7 @@ ((pair? posns) (lp (cdr ls) (cdr posns) (cons (car posns) args))) (else - (lp (cdr ls) posns (cons (cadar ls) args)))))))))))) + (lp (cdr ls) posns (cons (car (cdar ls)) args)))))))))))) . body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm index d1d9643b..78a82392 100644 --- a/lib/chibi/mime.scm +++ b/lib/chibi/mime.scm @@ -170,7 +170,7 @@ (define (mime-header-fold kons knil . o) (let ((src (and (pair? o) (car o))) (limit (and (pair? o) (pair? (cdr o)) (car (cdr o)))) - (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (caddr o) kons))) + (kons-from (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) (car (cddr o)) kons))) ((if (string? src) mime-header-fold-string mime-header-fold-port) kons knil (or src (current-input-port)) limit kons-from))) diff --git a/lib/chibi/net.scm b/lib/chibi/net.scm index ced9882e..0cbc8d88 100644 --- a/lib/chibi/net.scm +++ b/lib/chibi/net.scm @@ -56,9 +56,9 @@ (let ((io (open-net-io host service))) (if (not (pair? io)) (error "couldn't find address" host service) - (let ((res (proc (cadr io) (caddr io)))) + (let ((res (proc (cadr io) (car (cddr io))))) (close-input-port (cadr io)) - (close-output-port (caddr io)) + (close-output-port (car (cddr io))) (close-file-descriptor (car io)) res)))) diff --git a/lib/chibi/net/http.scm b/lib/chibi/net/http.scm index 37cac5e6..49ec4326 100644 --- a/lib/chibi/net/http.scm +++ b/lib/chibi/net/http.scm @@ -164,13 +164,13 @@ ((and (pair? (car ls)) (eq? 'mime (caar ls)) (pair? (cdar ls)) - (pair? (cadar ls)) - (memq (caadar ls) '(^ @))) - (let* ((disp0 (mime-ref (cdadar ls) "content-disposition" "")) + (pair? (car (cdar ls))) + (memq (caar (cdar ls)) '(^ @))) + (let* ((disp0 (mime-ref (cdar (cdar ls)) "content-disposition" "")) (disp (mime-parse-content-type disp0)) (name (mime-ref disp "name"))) (if name - (lp (cdr ls) (cons (cons name (caddar ls)) res)) + (lp (cdr ls) (cons (cons name (cadr (cdar ls))) res)) (lp (cdr ls) res)))) (else (lp (cdr ls) res)))) diff --git a/lib/chibi/optimize/rest.scm b/lib/chibi/optimize/rest.scm index d9be556b..e59e1d05 100644 --- a/lib/chibi/optimize/rest.scm +++ b/lib/chibi/optimize/rest.scm @@ -22,7 +22,7 @@ (let ((x (find (lambda (r) (and (eq? name (car r)) (eq? lam (cadr r)))) cdrs))) - (and x (list p f (+ (caddr x) 1))))) + (and x (list p f (+ (car (cddr x)) 1))))) (($ Cnd ((? (lambda (op) (eq? op pair?))) ($ Ref name (_ . (? lambda? lam)))) ((? (lambda (op) (eq? op cdr))) ($ Ref name (_ . (? lambda? lam)))) @@ -30,7 +30,7 @@ (let ((x (find (lambda (r) (and (eq? name (car r)) (eq? lam (cadr r)))) cdrs))) - (and x (list p f (+ (caddr x) 1.0))))) + (and x (list p f (+ (car (cddr x)) 1.0))))) (else #f))) params args)) @@ -86,13 +86,13 @@ ((not r) x) ((eq? op car) - `(,local-ref ,(+ 1 (inexact->exact (caddr r))))) + `(,local-ref ,(+ 1 (inexact->exact (car (cddr r)))))) ((eq? op cdr) (make-lit '())) ((eq? op pair?) - `(,> (,num-parameters) ,(+ base (inexact->exact (caddr r))))) + `(,> (,num-parameters) ,(+ base (inexact->exact (car (cddr r)))))) ((eq? op null?) - `(,<= (,num-parameters) ,(+ base (inexact->exact (caddr r))))) + `(,<= (,num-parameters) ,(+ base (inexact->exact (car (cddr r)))))) (else x)))) (($ Set ref value) diff --git a/lib/chibi/quoted-printable.scm b/lib/chibi/quoted-printable.scm index 80709026..dc445010 100644 --- a/lib/chibi/quoted-printable.scm +++ b/lib/chibi/quoted-printable.scm @@ -73,7 +73,7 @@ (let ((src (if (pair? o) (car o) (current-input-port))) (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) - (caddr o) + (car (cddr o)) *default-max-col*))) (qp-encode (if (string? src) src (read-string #f src)) start-col max-col "=\r\n"))) @@ -85,10 +85,10 @@ (let ((src (if (pair? o) (car o) (current-input-port))) (start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0)) (max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o))) - (caddr o) + (car (cddr o)) *default-max-col*)) - (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdddr o))) - (cadddr o) + (nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdr (cddr o)))) + (cadr (cddr o)) "\r\n"))) (let* ((prefix (string-append "=?" encoding "?Q?")) (prefix-length (+ 2 (string-length prefix))) diff --git a/lib/chibi/stty.scm b/lib/chibi/stty.scm index b4e36669..5a02be67 100644 --- a/lib/chibi/stty.scm +++ b/lib/chibi/stty.scm @@ -11,7 +11,7 @@ (for-each (lambda (c) (let ((type (cadr c)) - (value (caddr c))) + (value (car (cddr c)))) (hash-table-set! stty-lookup (car c) (cdr c)))) ;; ripped from the stty man page, then trimmed down to what seemed diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index 5aa4b7fd..c55cc55a 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -248,7 +248,7 @@ ((and (pair? x) (eq? 'call-with-values (car x))) (string-append "..." - (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (caadr x))) + (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x)))) (car (reverse (cadr x))) (cadr x)) (- width 3) diff --git a/lib/chibi/type-inference.scm b/lib/chibi/type-inference.scm index e18ccce4..b87088bb 100644 --- a/lib/chibi/type-inference.scm +++ b/lib/chibi/type-inference.scm @@ -35,7 +35,7 @@ ((and (pair? a) (eq? (car a) 'param-type)) (and (pair? b) (eq? (car b) 'param-type) (eq? (cadr a) (cadr b)) - (eq? (caddr a) (caddr b)))) + (eq? (car (cddr a)) (car (cddr b))))) ((and (pair? a) (eq? (car a) 'return-type)) (and (pair? b) (eq? (car b) 'return-type) (eq? (cadr a) (cadr b)))) diff --git a/lib/init-7.scm b/lib/init-7.scm index 089781b9..1f1ad157 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -2,36 +2,10 @@ ;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt -;; provide c[ad]{2,4}r - (define (caar x) (car (car x))) (define (cadr x) (car (cdr x))) (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (car (cdr x)))) -(define (cadar x) (car (cdr (car x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (car (cdr x)))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) -(define (caaaar x) (car (car (car (car x))))) -(define (caaadr x) (car (car (car (cdr x))))) -(define (caadar x) (car (car (cdr (car x))))) -(define (caaddr x) (car (car (cdr (cdr x))))) -(define (cadaar x) (car (cdr (car (car x))))) -(define (cadadr x) (car (cdr (car (cdr x))))) -(define (caddar x) (car (cdr (cdr (car x))))) -(define (cadddr x) (car (cdr (cdr (cdr x))))) -(define (cdaaar x) (cdr (car (car (car x))))) -(define (cdaadr x) (cdr (car (car (cdr x))))) -(define (cdadar x) (cdr (car (cdr (car x))))) -(define (cdaddr x) (cdr (car (cdr (cdr x))))) -(define (cddaar x) (cdr (cdr (car (car x))))) -(define (cddadr x) (cdr (cdr (car (cdr x))))) -(define (cdddar x) (cdr (cdr (cdr (car x))))) -(define (cddddr x) (cdr (cdr (cdr (cdr x))))) ;; basic utils @@ -155,7 +129,7 @@ (list (rename 'if) (rename 'tmp) (if (null? (cdr cl)) (rename 'tmp) - (list (caddr cl) (rename 'tmp))) + (list (car (cddr cl)) (rename 'tmp))) (cons (rename 'cond) (cddr expr)))) (car cl)) (list (rename 'if) @@ -207,8 +181,8 @@ ((and (<= d 0) (pair? (car x)) (compare (rename 'unquote-splicing) (caar x))) (if (null? (cdr x)) - (cadar x) - (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (cadr (car x)) + (list (rename 'append) (cadr (car x)) (qq (cdr x) d)))) (else (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) @@ -238,14 +212,14 @@ `((,(rename 'lambda) ,vars (,(rename 'letrec) ((,(cadr expr) (,(rename 'lambda) ,vars - ,@(cdddr expr)))) + ,@(cdr (cddr expr))))) (,(cadr expr) ,@vars))) ,@vals) `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) (map car bindings) (map cadr bindings)) (error "bad let syntax" expr))) - (if (identifier? (cadr expr)) (caddr expr) (cadr expr)))))) + (if (identifier? (cadr expr)) (car (cddr expr)) (cadr expr)))))) (define-syntax let* (er-macro-transformer @@ -260,8 +234,8 @@ (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) (cadr expr)) #f) - `(,(rename 'let) (,(caadr expr)) - (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))) + `(,(rename 'let) (,(caar (cdr expr))) + (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr))) (error "bad let* syntax")))))) (define-syntax case @@ -282,7 +256,7 @@ (body (cdar ls))) ((and (pair? (car (car ls))) (null? (cdr (car (car ls))))) `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) - (,(rename 'quote) ,(caaar ls))) + (,(rename 'quote) ,(car (caar ls)))) ,(body (cdar ls)) ,(clause (cdr ls)))) (else @@ -298,11 +272,11 @@ (lambda (expr rename compare) (let* ((body `(,(rename 'begin) - ,@(cdddr expr) + ,@(cdr (cddr expr)) (,(rename 'lp) - ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + ,@(map (lambda (x) (if (pair? (cddr x)) (car (cddr x)) (car x))) (cadr expr))))) - (check (caddr expr)) + (check (car (cddr expr))) (wrap (if (null? (cdr check)) `(,(rename 'let) ((,(rename 'tmp) ,(car check))) @@ -637,8 +611,8 @@ (_vector->list (rename 'vector->list)) (_list->vector (rename 'list->vector))) (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...))) - (define lits (if ellipsis-specified? (caddr expr) (cadr expr))) - (define forms (if ellipsis-specified? (cdddr expr) (cddr expr))) + (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) + (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))) (define (next-symbol s) (set! count (+ count 1)) (rename (string->symbol (string-append s (number->string count))))) diff --git a/lib/meta.scm b/lib/meta.scm index 32263b48..c26558b5 100644 --- a/lib/meta.scm +++ b/lib/meta.scm @@ -91,14 +91,14 @@ ((not (and (pair? x) (list? x))) (error "invalid module syntax" x)) ((and (memq (car x) '(prefix drop-prefix)) - (symbol? (caddr x)) (list? (cadr x))) + (symbol? (car (cddr x))) (list? (cadr x))) (let ((mod-name+imports (resolve-import (cadr x)))) (cons (car mod-name+imports) (map (lambda (i) (cons ((if (eq? (car x) 'drop-prefix) symbol-drop symbol-append) - (caddr x) + (car (cddr x)) (to-id i)) (from-id i))) (cdr mod-name+imports))))) @@ -204,7 +204,7 @@ (if (pair? x) (if (and (= 3 (length x)) (eq? 'rename (identifier->symbol (car x)))) - (cons (caddr x) (cadr x)) + (cons (car (cddr x)) (cadr x)) (error "invalid module export" x)) x)) (set! ,this-module '()) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index d1128bc6..37771445 100644 --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -16,9 +16,7 @@ bytevector-copy-partial bytevector-copy-partial! bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr call-with-current-continuation call-with-port call-with-values - call/cc car case cdr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar - cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar - cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr ceiling char->integer + call/cc car case cdr cdar cddr ceiling char->integer char-ready? char<=? char=? char>? char? close-input-port close-output-port close-port complex? cond cond-expand cons current-error-port current-input-port current-output-port define diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm index ab67b63c..ce360dc8 100644 --- a/lib/srfi/1/misc.scm +++ b/lib/srfi/1/misc.scm @@ -34,14 +34,14 @@ (define (zip . lists) (apply map list lists)) -(define (unzip1 ls) (map car ls)) -(define (unzip2 ls) (values (map car ls) (map cadr ls))) -(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls))) +(define (unzip1 ls) (map first ls)) +(define (unzip2 ls) (values (map first ls) (map second ls))) +(define (unzip3 ls) (values (map first ls) (map second ls) (map third ls))) (define (unzip4 ls) - (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls))) + (values (map first ls) (map second ls) (map third ls) (map fourth ls))) (define (unzip5 ls) - (values (map car ls) (map cadr ls) (map caddr ls) - (map cadddr ls) (map (lambda (x) (car (cddddr x))) ls))) + (values (map first ls) (map second ls) (map third ls) (map fourth ls) + (map fifth ls))) (define (count pred ls . lists) (if (null? lists) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm index 74ef7119..66dca43c 100644 --- a/lib/srfi/1/selectors.scm +++ b/lib/srfi/1/selectors.scm @@ -4,8 +4,8 @@ (define first car) (define second cadr) -(define third caddr) -(define fourth cadddr) +(define (third ls) (car (cdr (cdr ls)))) +(define (fourth ls) (car (cdr (cdr (cdr ls))))) (define (fifth ls) (car (cdr (cdr (cdr (cdr ls)))))) (define (sixth ls) (car (cdr (cdr (cdr (cdr (cdr ls))))))) (define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))) diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm index 9fb1aeca..76f5ed70 100644 --- a/lib/srfi/9.scm +++ b/lib/srfi/9.scm @@ -2,13 +2,15 @@ (define-syntax define-record-type (er-macro-transformer (lambda (expr rename compare) - (let* ((name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) - (parent (and (pair? (cadr expr)) (cadadr expr))) + (let* ((name+parent (cadr expr)) + (name (if (pair? name+parent) (car name+parent) name+parent)) + (parent (and (pair? name+parent) (cadr name+parent))) (name-str (symbol->string (identifier->symbol name))) - (make (caaddr expr)) - (make-fields (cdaddr expr)) - (pred (cadddr expr)) - (fields (cddddr expr)) + (procs (cddr expr)) + (make (caar procs)) + (make-fields (cdar procs)) + (pred (cadr procs)) + (fields (cddr procs)) (_define (rename 'define)) (_lambda (rename 'lambda)) (_let (rename 'let)) @@ -34,10 +36,10 @@ fields) ,@(map (lambda (f) (and (pair? f) (pair? (cdr f)) (pair? (cddr f)) - `(,_define ,(caddr f) + `(,_define ,(car (cddr f)) (,(rename 'make-setter) ,(symbol->string - (identifier->symbol (caddr f))) + (identifier->symbol (car (cddr f)))) ,name (,_type_slot_offset ,name ',(car f)))))) fields) @@ -60,7 +62,7 @@ (error "unknown record field in constructor" (car ls))) ((pair? (cddr field)) (lp (cdr ls) - (cons `(,(caddr field) res ,(car ls)) sets))) + (cons `(,(car (cddr field)) res ,(car ls)) sets))) (else (lp (cdr ls) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) diff --git a/lib/srfi/99/records/inspection.scm b/lib/srfi/99/records/inspection.scm index 15994f39..dfcb55dc 100644 --- a/lib/srfi/99/records/inspection.scm +++ b/lib/srfi/99/records/inspection.scm @@ -29,6 +29,6 @@ (rtd-field-mutable? p x) (error "unknown field" rtd x)))) ((eq? x (car ls))) - ((and (pair? (car ls)) (eq? x (cadar ls))) + ((and (pair? (car ls)) (eq? x (cadr (car ls)))) (not (eq? 'immutable (caar ls)))) (else (lp (cdr ls)))))) diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm index 87849c2d..301e5e6d 100644 --- a/lib/srfi/99/records/procedural.scm +++ b/lib/srfi/99/records/procedural.scm @@ -26,7 +26,7 @@ (let lp ((i 0) (ls ls)) (cond ((null? ls ) #f) ((if (pair? (car ls)) - (eq? field (cadar ls)) + (eq? field (car (cdar ls))) (eq? field (car ls))) i) (else (lp (+ i 1) (cdr ls)))))) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm index c5cf90f7..5af92995 100644 --- a/lib/srfi/99/records/syntactic.scm +++ b/lib/srfi/99/records/syntactic.scm @@ -3,18 +3,20 @@ (er-macro-transformer (lambda (expr rename compare) (let* ((id->string (lambda (x) (symbol->string (identifier->symbol x)))) - (name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) - (parent (and (pair? (cadr expr)) (cadadr expr))) + (name+parent (cadr expr)) + (name (if (pair? name+parent) (car name+parent) name+parent)) + (parent (and (pair? name+parent) (cadr name+parent))) (name-str (id->string name)) - (make (caddr expr)) + (procs (cddr expr)) + (make (car procs)) (make-name (if (eq? make #t) (string->symbol (string-append "make-" name-str)) (if (pair? make) (car make) make))) - (pred (cadddr expr)) + (pred (cadr procs)) (pred-name (if (eq? pred #t) (string->symbol (string-append name-str "?")) pred)) - (fields (cddddr expr)) + (fields (cddr procs)) (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields)) (make-fields (if (pair? make) (cdr make) (and (not parent) field-names))) (_define (rename 'define)) @@ -51,7 +53,7 @@ fields) ,@(map (lambda (f) (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) - (caddr f) + (car (cddr f)) (and (identifier? f) (string->symbol (string-append name-str "-" (id->string f) "-set!")))))) @@ -82,7 +84,7 @@ ;; (error "unknown record field in constructor" (car ls))) ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) (lp (cdr ls) - (cons (list (caddr field) 'res (car ls)) sets))) + (cons (list (car (cddr field)) 'res (car ls)) sets))) (else (lp (cdr ls) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm index c60a6bca..c69f2b37 100644 --- a/tests/basic/test10-unhygiene.scm +++ b/tests/basic/test10-unhygiene.scm @@ -5,9 +5,9 @@ (let ((condition (make-syntactic-closure environment '() (cadr form))) (consequent - (make-syntactic-closure environment '(it) (caddr form))) + (make-syntactic-closure environment '(it) (car (cddr form)))) (alternative - (make-syntactic-closure environment '() (cadddr form)))) + (make-syntactic-closure environment '() (cadr (cddr form))))) `(let ((it ,condition)) (if it ,consequent diff --git a/tools/chibi-doc b/tools/chibi-doc index 355ae137..216cec10 100755 --- a/tools/chibi-doc +++ b/tools/chibi-doc @@ -90,7 +90,7 @@ (define (sxml-body x) (cond ((not (and (pair? x) (pair? (cdr x)))) '()) - ((and (pair? (cadr x)) (eq? '^ (caadr x))) (cddr x)) + ((and (pair? (cadr x)) (eq? '^ (car (cadr x)))) (cddr x)) (else (cdr x)))) (define (env-ref env name . o) @@ -165,9 +165,9 @@ (error "section must not be empty" sxml) (let* ((name (and (eq? 'tag: (cadr sxml)) (pair? (cddr sxml)) - (sxml-strip (caddr sxml)))) + (sxml-strip (car (cddr sxml))))) (body (map (lambda (x) (expand x env)) - (if name (cdddr sxml) (cdr sxml)))) + (if name (cdr (cddr sxml)) (cdr sxml)))) (name (or name (sxml-strip (cons tag body))))) `(div (a (^ (name . ,(section-name tag name)))) (,tag ,@body)))))) @@ -195,10 +195,10 @@ (define (expand-code sxml env) (let* ((hl (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml))) - (highlighter-for (caddr sxml)) + (highlighter-for (car (cddr sxml))) highlight)) (body (if (and (pair? (cdr sxml)) (eq? 'language: (cadr sxml))) - (cdddr sxml) + (cdr (cddr sxml)) (cdr sxml)))) `(code ,@(map-sxml (lambda (x) (if (string? x) (hl x) x)) (normalize-sxml @@ -274,7 +274,7 @@ (if (null? x) '() (let ((d (caar x))) - (let lp ((ls (cdr x)) (parent (cadar x)) (kids '()) (res '())) + (let lp ((ls (cdr x)) (parent (car (cdar x))) (kids '()) (res '())) (define (collect) (cons `(li ,parent ,(get-contents (reverse kids))) res)) (cond @@ -283,7 +283,7 @@ ((> (caar ls) d) (lp (cdr ls) parent (cons (car ls) kids) res)) (else - (lp (cdr ls) (cadar ls) '() (collect)))))))) + (lp (cdr ls) (car (cdar ls)) '() (collect)))))))) (define (fix-header x) `(html (head ,@(cond ((assq 'title x) => (lambda (x) (list x))) @@ -351,7 +351,7 @@ div#footer {padding-bottom: 50px} (skip-whitespace in)))) (define (external-clause? x) - (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (caadr x))))) + (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x)))))) (define (get-signature proc source form) (match form @@ -388,10 +388,10 @@ div#footer {padding-bottom: 50px} (cons (if (pair? (cadr ls)) (cadr ls) (list (cadr ls))) res))) ((pair? (car ls)) (lp (cdr ls) - (append (if (pair? (cdddar ls)) - (list (list (car (cdddar ls)) name (caar ls))) + (append (if (pair? (cddr (cdar ls))) + (list (list (car (cddr (cdar ls))) name (caar ls))) '()) - (list (list (caddar ls) name)) + (list (list (cadr (cdar ls)) name)) res))) ((symbol? (car ls)) (lp (cddr ls) res)) @@ -433,7 +433,7 @@ div#footer {padding-bottom: 50px} orig-ls) (else (let ((name - (or name (if (eq? 'const: (caar sig)) (caddar sig) (caar sig))))) + (or name (if (eq? 'const: (caar sig)) (cadr (cdar sig)) (caar sig))))) (let lp ((ls orig-ls) (rev-pre '())) (cond ((or (null? ls) @@ -448,8 +448,8 @@ div#footer {padding-bottom: 50px} tag: ,(write-to-string name) (rawcode ,@(if (eq? 'const: (caar sig)) - `((i ,(write-to-string (cadar sig)) ": ") - ,(write-to-string (caddar sig))) + `((i ,(write-to-string (car (cdar sig))) ": ") + ,(write-to-string (cadr (cdar sig)))) (intersperse (map write-to-string sig) '(br))))))) ,@ls)) (else @@ -459,10 +459,10 @@ div#footer {padding-bottom: 50px} (call-with-input-file file (lambda (in) (let* ((lang (or (and (pair? o) (car o)) 'scheme)) - (defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdaddr x))) + (defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cdar (cddr x)))) (filter (lambda (x) - (and (pair? (caddr x)) (equal? file (caaddr x)))) + (and (pair? (third x)) (equal? file (car (third x))))) defs)))) (let lp ((lines '()) (cur '()) (res '())) (define (collect) @@ -503,14 +503,14 @@ div#footer {padding-bottom: 50px} (line1 (port-line in)) (x (read in)) (line2 (port-line in)) - (procs (filter (lambda (x) (<= line1 (caddr x) line2)) - (filter caddr defs)))) + (procs (filter (lambda (x) (<= line1 (third x) line2)) + (filter third defs)))) (cond ((and (eq? lang 'ffi) (get-ffi-signatures x)) => (lambda (sigs) (let ((sigs (filter (lambda (x) - (memq (if (eq? 'const: (car x)) (caddr x) (car x)) exports)) + (memq (if (eq? 'const: (car x)) (third x) (car x)) exports)) sigs))) (lp '() '() (append (insert-signature cur #f sigs) res))))) ((and (eq? lang 'scheme) (= 1 (length procs))) diff --git a/tools/chibi-ffi b/tools/chibi-ffi index ac6953cf..2e9ad897 100755 --- a/tools/chibi-ffi +++ b/tools/chibi-ffi @@ -72,7 +72,7 @@ ((result) (lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template)) ((array) - (lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default? template)) + (lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (car (cddr type)) #t) value default? template)) ((value) (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template)) ((default) @@ -123,7 +123,7 @@ (let lp ((ls (struct-fields (cdr x)))) (cond ((null? ls) #f) - ((eq? field (caar ls)) (cadar ls)) + ((eq? field (caar ls)) (car (cdar ls))) (else (lp (cdr ls))))))) (else #f))) @@ -190,18 +190,18 @@ (<= 1 (length (cadr func)) 3) (every (lambda (x) (or (identifier? x) (not x) (string? x))) (cadr func)))) - (list? (caddr func)))) + (list? (car (cddr func))))) (error "bad function definition" func)) (let* ((method? (and (pair? o) (car o))) (ret-type (parse-type (car func))) - (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func))) + (scheme-name (if (pair? (cadr func)) (car (cadr func)) (cadr func))) (c-name (if (pair? (cadr func)) - (cadadr func) + (cadr (cadr func)) (mangle scheme-name))) - (stub-name (if (and (pair? (cadr func)) (pair? (cddadr func))) - (car (cddadr func)) + (stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func)))) + (car (cddr (cadr func))) (generate-stub-name scheme-name)))) - (let lp ((ls (if (equal? (caddr func) '(void)) '() (caddr func))) + (let lp ((ls (if (equal? (car (cddr func)) '(void)) '() (car (cddr func)))) (i 0) (results '()) (c-args '()) @@ -428,7 +428,7 @@ (er-macro-transformer (lambda (expr rename compare) (let ((type (parse-type (cadr expr))) - (name (caddr expr))) + (name (car (cddr expr)))) (set! *typedefs* `((,name ,@type) ,@*typedefs*)) `(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n"))))) @@ -469,11 +469,11 @@ (lambda (expr rename compare) (ensure-c++ 'define-c++-method) (let* ((class (cadr expr)) - (ret-type (caddr expr)) - (name (cadddr expr)) + (ret-type (car (cddr expr))) + (name (cadr (cddr expr))) (meths (map (lambda (x) (parse-func `(,ret-type ,name (,class ,@x)) #t)) - (cddddr expr)))) + (cddr (cddr expr))))) (set! *methods* (cons (cons name meths) *methods*)))))) ;; (define-syntax define-c++-constructor @@ -1405,7 +1405,8 @@ ((type-struct? (car field)) ;; assign to a nested struct - copy field-by-field (let ((field-type - (cond ((lookup-type (type-name (car field))) => cdddr) + (cond ((lookup-type (type-name (car field))) + => (lambda (x) (cddr (cdr x)))) (else (cdr field))))) (lambda () (for-each @@ -1456,8 +1457,8 @@ (cond ((memq 'constructor: type) => (lambda (x) - (let ((make (caadr x)) - (args (cdadr x))) + (let ((make (car (cadr x))) + (args (cdr (cadr x)))) (cat "static sexp " (generate-stub-name make) " (sexp ctx, sexp self, sexp_sint_t n" (lambda () @@ -1524,25 +1525,25 @@ (cond ((and (pair? field) (pair? (cdr field))) (cond - ((and (pair? (cddr field)) (caddr field)) + ((and (pair? (cddr field)) (car (cddr field))) (write-type-getter type name field) (set! *funcs* (cons (parse-func `(,(car field) - (,(caddr field) + (,(car (cddr field)) #f ,(type-getter-name type name field)) (,name))) *funcs*)))) (cond ((and (pair? (cddr field)) - (pair? (cdddr field)) - (car (cdddr field))) + (pair? (cdr (cddr field))) + (cadr (cddr field))) (write-type-setter type name field) (set! *funcs* (cons (parse-func `(,(car field) - (,(car (cdddr field)) + (,(cadr (cddr field)) #f ,(type-setter-name type name field)) (,name ,(car field)))) @@ -1550,8 +1551,8 @@ (struct-fields type)))) (define (write-const const) - (let ((scheme-name (if (pair? (cadr const)) (caadr const) (cadr const))) - (c-name (if (pair? (cadr const)) (cadadr const) (mangle (cadr const))))) + (let ((scheme-name (if (pair? (cadr const)) (car (cadr const)) (cadr const))) + (c-name (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const))))) (cat " name = sexp_intern(ctx, \"" scheme-name "\", " (string-length (x->string scheme-name)) ");\n" " sexp_env_define(ctx, env, name, tmp="