summaryrefslogtreecommitdiffstats
path: root/gencadr.txr
blob: 2e242653a46e3eb59cdd1a6dfe37e8872dbb9293 (plain)
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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
@(bind ad @(append-each* ((i (range 2 5))) (rperm "ad" i)))
@(do
   (defun compile-ad (string arg)
     (casequal string
       ("" arg)
       (t `c@[string 0]r(@(compile-ad [string 1..:] arg))`))))
@(next "lib.c")
@(collect)
@{c-copyright}
@(until)

@(end)
@(next "share/txr/stdlib/place.tl")
@(collect)
@{tl-copyright}
@(until)

@(end)
@(output "cadr.c")
/* This file is generated by gencadr.txr */

@{c-copyright "\n"}

#include <stdio.h>
#include <stdarg.h>
#include <stdlib.h>
#include <limits.h>
#include "config.h"
#include "lib.h"
#include "eval.h"
#include "stream.h"
#include "lisplib.h"
#include "txr.h"
#include "cadr.h"
@  (repeat)

val c@{ad}r(val cons)
{
  return @(compile-ad ad 'cons);
}
@  (end)

static val cadr_register(val set_fun)
{
  funcall1(set_fun, nil);
@  (repeat)
  reg_fun(intern(lit("c@{ad}r"), user_package), func_n1(c@{ad}r));
@  (end)
  load(scat2(stdlib_path, lit("cadr")));
  return nil;
}

static val cadr_set_entries(val dlt, val fun)
{
  val name[] = {
@  (repeat)
    lit("c@{ad}r"),
@  (end)
    nil
  };

  set_dlt_entries(dlt, name, fun);
  return nil;
}

void cadr_init(void)
{
  dlt_register(dl_table, cadr_register, cadr_set_entries);
}
@(end)
@(output "cadr.h")
/* This file is generated by gencadr.txr */

@{c-copyright "\n"}

@  (repeat)
val c@{ad}r(val);
@  (end)

void cadr_init(void);
@(end)
@(output "share/txr/stdlib/cadr.tl")
;; This file is generated by gencadr.txr

@{tl-copyright "\n"}
@  (repeat)

(defplace (c@{ad}r cell) body
  (getter setter
    (with-gensyms (cell-sym)
      ^(let ((,cell-sym (c@{ad [1..:]}r ,cell)))
         (macrolet ((,getter () ^(c@{ad [0]}r ,',cell-sym))
                    (,setter (val) ^(sys:rplac@{ad [0]} ,',cell-sym ,val)))
           ,body))))
  (ssetter
    ^(macrolet ((,ssetter (val) ^(sys:rplac@{ad [0]} (c@{ad [1..:]}r ,',cell) ,val)))
      ,body))
  (deleter
    ^(macrolet ((,deleter ()
                  (with-gensyms (tmp)
                    (with-update-expander (cgetter csetter) '(c@{ad [1..:]}r ,cell) nil
                      ^(let ((,tmp (,cgetter)))
                         @(if (equal [ad 0] #\a)
                            `(prog1 (car ,tmp) (,csetter (cdr ,tmp)))`
                            `(prog1 (cdr ,tmp) (,csetter (car ,tmp)))`))))))
       ,body)))
@  (end)
@(end)