├── arc.rc
├── arc.ico
├── CMakeLists.txt
├── Makefile
├── arcadia.sln
├── arcadia.filters
├── arcadia.cbp
├── arcadia.c
├── .gitignore
├── README.md
├── arc.h
├── arcadia.vcxproj
├── library.h
└── arc.c
/arc.rc:
--------------------------------------------------------------------------------
1 | id ICON "arc.ico"
2 |
--------------------------------------------------------------------------------
/arc.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/kimtg/arcadia/HEAD/arc.ico
--------------------------------------------------------------------------------
/CMakeLists.txt:
--------------------------------------------------------------------------------
1 | # Building with cmake:
2 | # Create and enter a build directory
3 | # If compiling without GNU readline run 'cmake .. && make'
4 | # If compiling with GNU readline run 'cmake -DREADLINE=1 .. && make'
5 |
6 | project(arcadia)
7 | cmake_minimum_required(VERSION 2.8)
8 |
9 | # Source files
10 | set(SOURCES arcadia.c arc.c)
11 |
12 | # The target executable
13 | add_executable(arcadia ${SOURCES})
14 |
15 | # Always link stdmath
16 | target_link_libraries(arcadia m)
17 |
18 | # Only link GNU readline if we're compiling using it
19 | if (READLINE)
20 | target_link_libraries(arcadia m readline)
21 | endif()
22 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | BIN=arcadia
2 | CFLAGS=-Wall -O3 -c
3 | LDFLAGS=-s -lm
4 |
5 | $(BIN): arcadia.o arc.o
6 | $(CC) -o $(BIN) arcadia.o arc.o $(LDFLAGS)
7 |
8 | readline: CFLAGS+=-DREADLINE
9 | readline: LDFLAGS+=-lreadline
10 | readline: $(BIN)
11 |
12 | mingw: CC=mingw32-gcc
13 | mingw: arcadia.o arc.o ico.o
14 | $(CC) -o $(BIN) arcadia.o arc.o ico.o $(LDFLAGS)
15 |
16 | ico.o: arc.rc arc.ico
17 | windres -o ico.o -O coff arc.rc
18 |
19 | arcadia.o: arcadia.c arc.h
20 | $(CC) $(CFLAGS) arcadia.c
21 | arc.o: arc.c arc.h library.h
22 | $(CC) $(CFLAGS) arc.c
23 | run: $(BIN)
24 | ./$(BIN)
25 | clean:
26 | rm -f $(BIN) *.o
27 | tag:
28 | etags *.h *.c
29 |
--------------------------------------------------------------------------------
/arcadia.sln:
--------------------------------------------------------------------------------
1 |
2 | Microsoft Visual Studio Solution File, Format Version 12.00
3 | # Visual Studio Express 2013 for Windows Desktop
4 | VisualStudioVersion = 12.0.30110.0
5 | MinimumVisualStudioVersion = 10.0.40219.1
6 | Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "arcadia", "arcadia.vcxproj", "{4F9809E7-12CF-4193-AD80-64257DDF0028}"
7 | EndProject
8 | Global
9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution
10 | Debug|Win32 = Debug|Win32
11 | Release|Win32 = Release|Win32
12 | EndGlobalSection
13 | GlobalSection(ProjectConfigurationPlatforms) = postSolution
14 | {4F9809E7-12CF-4193-AD80-64257DDF0028}.Debug|Win32.ActiveCfg = Debug|Win32
15 | {4F9809E7-12CF-4193-AD80-64257DDF0028}.Debug|Win32.Build.0 = Debug|Win32
16 | {4F9809E7-12CF-4193-AD80-64257DDF0028}.Release|Win32.ActiveCfg = Release|Win32
17 | {4F9809E7-12CF-4193-AD80-64257DDF0028}.Release|Win32.Build.0 = Release|Win32
18 | EndGlobalSection
19 | GlobalSection(SolutionProperties) = preSolution
20 | HideSolutionNode = FALSE
21 | EndGlobalSection
22 | EndGlobal
23 |
--------------------------------------------------------------------------------
/arcadia.filters:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | {4FC737F1-C7A5-4376-A066-2A32D752A2FF}
6 | cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx
7 |
8 |
9 | {93995380-89BD-4b04-88EB-625FBE52EBFB}
10 | h;hh;hpp;hxx;hm;inl;inc;xsd
11 |
12 |
13 | {67DA6AB6-F800-4c08-8B7A-83BB121AAD01}
14 | rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav;mfcribbon-ms
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 | Source Files
24 |
25 |
26 |
--------------------------------------------------------------------------------
/arcadia.cbp:
--------------------------------------------------------------------------------
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 |
--------------------------------------------------------------------------------
/arcadia.c:
--------------------------------------------------------------------------------
1 | #include "arc.h"
2 | #define VERSION "0.43"
3 |
4 | void print_logo() {
5 | printf("Arcadia %s\n", VERSION);
6 | }
7 |
8 | void repl() {
9 | struct string input;
10 |
11 | while ((input.str = readline("> ")) != NULL) {
12 | input.cap = (input.len = strlen(input.str)) + 1;
13 | read_start:;
14 |
15 | const char *p = input.str;
16 | error err;
17 |
18 | atom expr;
19 | err = read_expr(p, &p, &expr);
20 | if (err == ERROR_FILE) { /* read more lines */
21 | char *line = readline(" ");
22 | if (!line) break;
23 | string_cat(&input, "\n");
24 | string_cat(&input, line);
25 | free(line);
26 | goto read_start;
27 | }
28 |
29 | #ifdef READLINE
30 | add_history(input.str);
31 | #endif
32 |
33 | if (!err) {
34 | while (1) {
35 | atom result;
36 | error err = macex_eval(expr, &result);
37 | if (err) {
38 | print_error(err);
39 | printf("error in expression:\n");
40 | print_expr(expr);
41 | putchar('\n');
42 | break;
43 | }
44 | else {
45 | print_expr(result);
46 | puts("");
47 | }
48 | err = read_expr(p, &p, &expr);
49 | if (err != ERROR_OK) {
50 | break;
51 | }
52 | }
53 | } else {
54 | print_error(err);
55 | }
56 | free(input.str);
57 | }
58 | }
59 |
60 | int main(int argc, char **argv)
61 | {
62 | if (argc == 1) { /* REPL */
63 | print_logo();
64 | arc_init(argv[0]);
65 | repl();
66 | puts("");
67 | return 0;
68 | }
69 | else if (argc == 2) {
70 | char *opt = argv[1];
71 | if (strcmp(opt, "-h") == 0) {
72 | puts("Usage: arcadia [OPTIONS...] [FILES...]");
73 | puts("");
74 | puts("OPTIONS:");
75 | puts(" -h print this screen.");
76 | puts(" -v print version.");
77 | return 0;
78 | }
79 | else if (strcmp(opt, "-v") == 0) {
80 | puts(VERSION);
81 | return 0;
82 | }
83 | }
84 |
85 | /* execute files */
86 | arc_init(argv[0]);
87 | int i;
88 | error err;
89 | for (i = 1; i < argc; i++) {
90 | err = arc_load_file(argv[i]);
91 | if (err) {
92 | fprintf(stderr, "In file %s:\n", argv[i]);
93 | print_error(err);
94 | break;
95 | }
96 | }
97 | return 0;
98 | }
99 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | ## Ignore Visual Studio temporary files, build results, and
2 | ## files generated by popular Visual Studio add-ons.
3 |
4 | # User-specific files
5 | *.suo
6 | *.user
7 | *.sln.docstates
8 |
9 | # Build results
10 |
11 | [Dd]ebug/
12 | [Rr]elease/
13 | x64/
14 | build/
15 | [Bb]in/
16 | [Oo]bj/
17 | *.exe
18 | *.o
19 | *.res
20 | arcadia
21 |
22 | # MSTest test Results
23 | [Tt]est[Rr]esult*/
24 | [Bb]uild[Ll]og.*
25 |
26 | *_i.c
27 | *_p.c
28 | *.ilk
29 | *.meta
30 | *.obj
31 | *.pch
32 | *.pdb
33 | *.pgc
34 | *.pgd
35 | *.rsp
36 | *.sbr
37 | *.tlb
38 | *.tli
39 | *.tlh
40 | *.tmp
41 | *.tmp_proj
42 | *.log
43 | *.vspscc
44 | *.vssscc
45 | .builds
46 | *.pidb
47 | *.log
48 | *.scc
49 |
50 | # Visual C++ cache files
51 | ipch/
52 | *.aps
53 | *.ncb
54 | *.opensdf
55 | *.sdf
56 | *.cachefile
57 | *.VC.opendb
58 | *.VC.db
59 |
60 | # Visual Studio profiler
61 | *.psess
62 | *.vsp
63 | *.vspx
64 |
65 | # Guidance Automation Toolkit
66 | *.gpState
67 |
68 | # ReSharper is a .NET coding add-in
69 | _ReSharper*/
70 | *.[Rr]e[Ss]harper
71 |
72 | # TeamCity is a build add-in
73 | _TeamCity*
74 |
75 | # DotCover is a Code Coverage Tool
76 | *.dotCover
77 |
78 | # NCrunch
79 | *.ncrunch*
80 | .*crunch*.local.xml
81 |
82 | # Installshield output folder
83 | [Ee]xpress/
84 |
85 | # DocProject is a documentation generator add-in
86 | DocProject/buildhelp/
87 | DocProject/Help/*.HxT
88 | DocProject/Help/*.HxC
89 | DocProject/Help/*.hhc
90 | DocProject/Help/*.hhk
91 | DocProject/Help/*.hhp
92 | DocProject/Help/Html2
93 | DocProject/Help/html
94 |
95 | # Click-Once directory
96 | publish/
97 |
98 | # Publish Web Output
99 | *.Publish.xml
100 | *.pubxml
101 |
102 | # NuGet Packages Directory
103 | ## TODO: If you have NuGet Package Restore enabled, uncomment the next line
104 | #packages/
105 |
106 | # Windows Azure Build Output
107 | csx
108 | *.build.csdef
109 |
110 | # Windows Store app package directory
111 | AppPackages/
112 |
113 | # Others
114 | sql/
115 | *.Cache
116 | ClientBin/
117 | [Ss]tyle[Cc]op.*
118 | ~$*
119 | *~
120 | *.dbmdl
121 | *.[Pp]ublish.xml
122 | *.pfx
123 | *.publishsettings
124 |
125 | # RIA/Silverlight projects
126 | Generated_Code/
127 |
128 | # Backup & report files from converting an old project file to a newer
129 | # Visual Studio version. Backup files are not needed, because we have git ;-)
130 | _UpgradeReport_Files/
131 | Backup*/
132 | UpgradeLog*.XML
133 | UpgradeLog*.htm
134 |
135 | # SQL Server files
136 | App_Data/*.mdf
137 | App_Data/*.ldf
138 |
139 | # =========================
140 | # Windows detritus
141 | # =========================
142 |
143 | # Windows image file caches
144 | Thumbs.db
145 | ehthumbs.db
146 |
147 | # Folder config file
148 | Desktop.ini
149 |
150 | # Recycle Bin used on file shares
151 | $RECYCLE.BIN/
152 |
153 | # Mac crap
154 | .DS_Store
155 | *.stackdump
156 |
157 | # etags
158 | TAGS
159 |
160 | # emacs crap
161 | \#*\#
162 |
163 | # Code::Blocks
164 | *.layout
165 | *.depend
166 | bin/
167 | obj/
168 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Arcadia: An implementation of the Arc programming language #
2 |
3 | Arc is a dialect of Lisp.
4 |
5 | ## Build
6 | ```
7 | make
8 | ```
9 |
10 | With [readline](http://cnswww.cns.cwru.edu/php/chet/readline/rltop.html) support,
11 | ```
12 | make readline
13 | ```
14 |
15 | With [MinGW](http://www.mingw.org/),
16 | ```
17 | mingw32-make mingw
18 | ```
19 |
20 | For Visual C++, use .sln file.
21 |
22 | ## Run
23 | ```
24 | Usage: arcadia [OPTIONS...] [FILES...]
25 |
26 | OPTIONS:
27 | -h print this screen.
28 | -v print version.
29 | ```
30 |
31 | ## Special form
32 | `assign do fn if mac quote`
33 |
34 | ## Built-in
35 | `* + - / < > apply bound car ccc cdr close coerce cons cos disp err expt eval flushout infile int is len log macex maptable mod newstring outfile pipe-from quit rand read readline scar scdr sin sqrt sread sref stderr stdin stdout string sym system t table tan trunc type write writeb`
36 |
37 | ## Library
38 | `++ -- <= = >= aand abs accum acons adjoin afn aif alist all alref and andf assoc atend atom avg before best bestn caar cadr carif caris case caselet catch cddr check commonest compare complement compose consif conswhen copy copylist count counts cut dedup def defmemo do1 dotted drain each empty even fill-table find firstn flat for forlen get idfn iflet in insert-sorted insort insortnew intersperse isa isnt iso join keep keys last len< len> let list listtab loop map map1 mappend max med median mem memo memtable merge mergesort min mismatch most multiple n-of nearest no noisy-each nor nthcdr number obj odd on only ontable or orf pair point pop pos positive pr prn pull push pushnew quasiquote rand-choice rand-elt range readfile readfile1 reclist recstring reduce reinsert-sorted rem repeat retrieve rev rfn rotate round roundup rreduce set single some sort split sum summing swap tablist testify tuples trues union uniq unless until vals w/table w/uniq when whenlet while whiler whilet wipe with withs writefile zap`
39 |
40 | ## Features
41 | * Easy-to-understand mark-and-sweep garbage collection
42 | * Tail call optimization
43 | * Implicit indexing
44 | * [Syntax sugar](http://arclanguage.github.io/ref/evaluation.html) (`[]`, `~`, `.`, `!`, `:`)
45 |
46 | ## See also
47 | * [Arc Tutorial](http://www.arclanguage.org/tut.txt), [Arc Tutorial (HTML)](https://arclanguage.github.io/tut-stable.html)
48 | * [Arc Documentation](http://arclanguage.github.io/ref/index.html)
49 | * [Try Arc: Arc REPL In Your Web Browser](http://tryarc.org/)
50 |
51 | ## License ##
52 |
53 | Copyright 2014-2025 Kim, Taegyoon
54 |
55 | Licensed under the Apache License, Version 2.0 (the "License");
56 | you may not use this file except in compliance with the License.
57 | You may obtain a copy of the License at
58 |
59 | [http://www.apache.org/licenses/LICENSE-2.0](http://www.apache.org/licenses/LICENSE-2.0)
60 |
61 | Unless required by applicable law or agreed to in writing, software
62 | distributed under the License is distributed on an "AS IS" BASIS,
63 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
64 | See the License for the specific language governing permissions and
65 | limitations under the License.
66 |
--------------------------------------------------------------------------------
/arc.h:
--------------------------------------------------------------------------------
1 | #pragma once
2 | #ifndef _INC_ARC
3 | #define _INC_ARC
4 |
5 | #ifdef _MSC_VER
6 | #define _CRT_SECURE_NO_WARNINGS
7 | #endif
8 |
9 | #include
10 | #include
11 | #include
12 | #include
13 | #include
14 | #include
15 | #include
16 |
17 | #ifdef READLINE
18 | #include
19 | #include
20 | #endif
21 |
22 | #ifdef _MSC_VER
23 | #define strdup _strdup
24 | #define popen _popen
25 | #define pclose _pclose
26 | #endif
27 |
28 | enum type {
29 | T_NIL,
30 | T_CONS,
31 | T_SYM,
32 | T_NUM,
33 | T_BUILTIN,
34 | T_CLOSURE,
35 | T_MACRO,
36 | T_STRING,
37 | T_INPUT,
38 | T_INPUT_PIPE,
39 | T_OUTPUT,
40 | T_TABLE,
41 | T_CHAR,
42 | T_CONTINUATION
43 | };
44 |
45 | typedef enum {
46 | ERROR_OK = 0, ERROR_SYNTAX, ERROR_UNBOUND, ERROR_ARGS, ERROR_TYPE, ERROR_FILE, ERROR_USER
47 | } error;
48 |
49 | typedef struct atom atom;
50 | struct vector;
51 | typedef error(*builtin)(struct vector *vargs, atom *result);
52 |
53 | struct atom {
54 | enum type type;
55 |
56 | union {
57 | double number;
58 | struct pair *pair;
59 | char *symbol;
60 | struct str *str;
61 | builtin builtin;
62 | FILE *fp;
63 | struct table *table;
64 | char ch;
65 | jmp_buf *jb;
66 | } value;
67 | };
68 |
69 | struct vector {
70 | atom *data;
71 | atom static_data[8]; /* small size optimization */
72 | size_t capacity, size;
73 | };
74 |
75 | struct pair {
76 | struct atom car, cdr;
77 | char mark;
78 | struct pair *next;
79 | };
80 |
81 | struct str {
82 | char *value;
83 | char mark;
84 | struct str *next;
85 | };
86 |
87 | struct table_entry {
88 | struct atom k, v;
89 | struct table_entry *next;
90 | };
91 |
92 | struct table {
93 | size_t capacity;
94 | size_t size;
95 | struct table_entry **data;
96 | char mark;
97 | struct table *next;
98 | };
99 |
100 | /* simple string with length and capacity */
101 | struct string {
102 | char *str;
103 | size_t len, cap;
104 | };
105 |
106 | /* forward declarations */
107 | error apply(atom fn, struct vector *vargs, atom *result);
108 | int listp(atom expr);
109 | char *slurp_fp(FILE *fp);
110 | char *slurp(const char *path);
111 | error eval_expr(atom expr, atom env, atom *result);
112 | void gc_mark(atom root);
113 | void gc();
114 | error macex(atom expr, atom *result);
115 | char *to_string(atom a, int write);
116 | void string_new(struct string* dst);
117 | void string_cat(struct string *dst, char *src);
118 | error macex_eval(atom expr, atom *result);
119 | error arc_load_file(const char *path);
120 | char *get_dir_path(char *file_path);
121 | void arc_init(char *file_path);
122 | #ifndef READLINE
123 | char *readline(char *prompt);
124 | #endif
125 | char *readline_fp(char *prompt, FILE *fp);
126 | error read_expr(const char *input, const char **end, atom *result);
127 | void print_expr(atom a);
128 | void print_error(error e);
129 | int is(atom a, atom b);
130 | int iso(atom a, atom b);
131 | size_t hash_code(atom a);
132 | atom make_table(size_t capacity);
133 | void table_add(struct table *tbl, atom k, atom v);
134 | struct table_entry *table_get(struct table *tbl, atom k);
135 | struct table_entry *table_get_sym(struct table *tbl, char *k);
136 | int table_set(struct table *tbl, atom k, atom v);
137 | int table_set_sym(struct table *tbl, char *k, atom v);
138 | void consider_gc();
139 | atom cons(atom car_val, atom cdr_val);
140 | /* end forward */
141 |
142 | #define car(p) ((p).value.pair->car)
143 | #define cdr(p) ((p).value.pair->cdr)
144 | #define no(atom) ((atom).type == T_NIL)
145 |
146 | extern const atom nil;
147 |
148 | #endif
149 |
--------------------------------------------------------------------------------
/arcadia.vcxproj:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | Debug
6 | Win32
7 |
8 |
9 | Release
10 | Win32
11 |
12 |
13 |
14 | {4F9809E7-12CF-4193-AD80-64257DDF0028}
15 | Win32Proj
16 | arcadia
17 | arcadia
18 | 10.0
19 |
20 |
21 |
22 | Application
23 | true
24 | Unicode
25 | v143
26 |
27 |
28 | Application
29 | false
30 | true
31 | Unicode
32 | v143
33 |
34 |
35 |
36 |
37 |
38 |
39 |
40 |
41 |
42 |
43 |
44 |
45 | true
46 |
47 |
48 | false
49 |
50 |
51 |
52 |
53 |
54 | Level3
55 | Disabled
56 | WIN32;_DEBUG;_CONSOLE;_LIB;%(PreprocessorDefinitions)
57 | true
58 |
59 |
60 | Console
61 | true
62 |
63 |
64 |
65 |
66 |
67 |
68 |
69 |
70 | Level3
71 |
72 |
73 | MaxSpeed
74 | true
75 | true
76 | WIN32;NDEBUG;_CONSOLE;_LIB;%(PreprocessorDefinitions)
77 | true
78 | MultiThreaded
79 |
80 |
81 | Console
82 | true
83 | true
84 | true
85 |
86 |
87 |
88 |
89 |
90 |
91 |
92 |
93 |
94 |
95 |
96 |
97 |
98 |
99 |
100 |
101 |
102 |
103 |
104 |
105 |
106 |
107 |
108 |
--------------------------------------------------------------------------------
/library.h:
--------------------------------------------------------------------------------
1 | const char* stdlib = "(mac = args (cons 'assign args))\n"
2 | "\n"
3 | "(= list (fn args args))\n"
4 | "\n"
5 | "(mac def (name args . body) (list '= name (cons 'fn (cons args body))))\n"
6 | "\n"
7 | "(def rreduce (f xs)\n"
8 | "\"Like [[reduce]] but accumulates elements of 'xs' in reverse order.\"\n"
9 | " (if (cddr xs)\n"
10 | " (f (car xs) (rreduce f (cdr xs)))\n"
11 | " (apply f xs)))\n"
12 | "\n"
13 | "(def no (x) (is x nil))\n"
14 | "\n"
15 | "(def complement (f)\n"
16 | "\"Returns a function that behaves as if the result of calling 'f' was negated.\n"
17 | "For example, this is always true:\n"
18 | " ((complement f) a b) <=> (no (f a b))\"\n"
19 | " (fn args (no (apply f args))))\n"
20 | "\n"
21 | "(def isa (x y)\n"
22 | " (is (type x) y))\n"
23 | "\n"
24 | "(def isnt (x y) (no (is x y)))\n"
25 | "\n"
26 | "(def abs (x) (if (< x 0) (- 0 x) x))\n"
27 | "\n"
28 | "(def reduce (f xs)\n"
29 | "\"Accumulates elements of 'xs' using binary function 'f'.\"\n"
30 | " (if (cddr xs)\n"
31 | " (reduce f (cons (f car.xs cadr.xs)\n"
32 | " cddr.xs))\n"
33 | " (apply f xs)))\n"
34 | "\n"
35 | "(def map1 (f xs)\n"
36 | "\"Returns a list containing the result of function 'f' applied to every element of 'xs'.\"\n"
37 | " (if (no xs)\n"
38 | " nil\n"
39 | " (cons (f (car xs))\n"
40 | " (map1 f (cdr xs)))))\n"
41 | "\n"
42 | "(def caar (x) (car (car x)))\n"
43 | "(def cadr (x) (car (cdr x)))\n"
44 | "(def cddr (x) (cdr (cdr x)))\n"
45 | "\n"
46 | "(mac and2 (a b) (list 'if a b nil))\n"
47 | "(mac or (a b) (list 'if a t b))\n"
48 | "\n"
49 | "(mac quasiquote (x)\n"
50 | " (if (isa x 'cons)\n"
51 | " (if (is (car x) 'unquote)\n"
52 | " (cadr x)\n"
53 | " (if (and2 (isa (car x) 'cons) (is (caar x) 'unquote-splicing))\n"
54 | " (list '+\n"
55 | " (cadr (car x))\n"
56 | " (list 'quasiquote (cdr x)))\n"
57 | " (list 'cons\n"
58 | " (list 'quasiquote (car x))\n"
59 | " (list 'quasiquote (cdr x)))))\n"
60 | " (list 'quote x)))\n"
61 | "\n"
62 | "(mac let (sym def . body)\n"
63 | " `((fn (,sym) ,@body) ,def))\n"
64 | "\n"
65 | "(mac rfn (name parms . body)\n"
66 | "\"Like [[fn]] but permits the created function to call itself recursively as the given 'name'.\"\n"
67 | " `(let ,name nil\n"
68 | " (assign ,name (fn ,parms ,@body))))\n"
69 | "\n"
70 | "(def rev (xs)\n"
71 | "\"Returns a list containing the elements of 'xs' back to front.\"\n"
72 | " ((rfn recur (xs acc)\n"
73 | " (if (no xs)\n"
74 | " acc\n"
75 | " (recur cdr.xs\n"
76 | " (cons car.xs acc)))) xs nil))\n"
77 | "\n"
78 | "(def pair (xs (o f list))\n"
79 | " \"Splits the elements of 'xs' into buckets of two, and optionally applies the\n"
80 | "function 'f' to them.\"\n"
81 | " (if (no xs)\n"
82 | " nil\n"
83 | " (no cdr.xs)\n"
84 | " (list (list car.xs))\n"
85 | " (cons (f car.xs cadr.xs)\n"
86 | " (pair cddr.xs f))))\n"
87 | "\n"
88 | "(mac with (parms . body)\n"
89 | " `((fn ,(map1 car (pair parms))\n"
90 | " ,@body)\n"
91 | " ,@(map1 cadr (pair parms))))\n"
92 | "\n"
93 | "(def join args\n"
94 | " (if (no args)\n"
95 | " nil\n"
96 | " (let a (car args)\n"
97 | " (if (no a)\n"
98 | " (apply join (cdr args))\n"
99 | " (cons (car a) (apply join (cons (cdr a) (cdr args))))))))\n"
100 | "\n"
101 | "(= uniq (let uniq-count 0\n"
102 | " (fn () (sym (string \"_uniq\" (= uniq-count (+ uniq-count 1)))))))\n"
103 | "\n"
104 | "(mac w/uniq (names . body)\n"
105 | " (if (isa names 'cons)\n"
106 | " `(with ,(apply join (map1 (fn (x) (list x '(uniq))) names))\n"
107 | " ,@body)\n"
108 | " `(let ,names (uniq) ,@body)))\n"
109 | "\n"
110 | "(mac when (test . body)\n"
111 | " (list 'if test (cons 'do body)))\n"
112 | "\n"
113 | "(mac while (test . body)\n"
114 | " \"Executes body repeatedly while test is true. The test is evaluated before each execution of body.\"\n"
115 | " (let f (uniq)\n"
116 | " `(let ,f nil\n"
117 | " (assign ,f (fn ()\n"
118 | " (when ,test\n"
119 | " ,@body\n"
120 | " (,f))))\n"
121 | " (,f))))\n"
122 | "\n"
123 | "(mac each (var expr . body)\n"
124 | " (w/uniq (seq i)\n"
125 | " `(let ,seq ,expr\n"
126 | " (if (isa ,seq 'cons) (while ,seq (= ,var (car ,seq)) ,@body (= ,seq (cdr ,seq)))\n"
127 | " (isa ,seq 'table) (maptable (fn ,var ,@body) ,seq)\n"
128 | " 'else (let ,i 0 (while (isnt (,seq ,i) #\\nul) (= ,var (,seq ,i)) ,@body (++ ,i)))))))\n"
129 | "\n"
130 | "(mac and args\n"
131 | "\"Stops at the first argument to fail (return nil). Returns the last argument before stopping.\"\n"
132 | " (if args\n"
133 | " (if (cdr args)\n"
134 | " `(if ,(car args) (and ,@(cdr args)))\n"
135 | " (car args))\n"
136 | " t))\n"
137 | "\n"
138 | "(mac or args\n"
139 | "\"Stops at the first argument to pass, and returns its result.\"\n"
140 | " (and args\n"
141 | " (w/uniq g\n"
142 | " `(let ,g ,(car args)\n"
143 | " (if ,g ,g\n"
144 | " (or ,@(cdr args)))))))\n"
145 | "\n"
146 | "(def iso (x y)\n"
147 | "\"Are 'x' and 'y' equal-looking to each other? Non-atoms like lists and tables can contain\n"
148 | "the same elements (be *isomorphic*) without being identical.\"\n"
149 | " (or (is x y)\n"
150 | " (and (acons x)\n"
151 | " (acons y)\n"
152 | " (iso (car x) (car y))\n"
153 | " (iso (cdr x) (cdr y)))))\n"
154 | "\n"
155 | "(def <= args\n"
156 | "\"Is each element of 'args' lesser than or equal to all following elements?\"\n"
157 | " (or (no args)\n"
158 | " (no (cdr args))\n"
159 | " (and (no (> (car args) (cadr args)))\n"
160 | " (apply <= (cdr args)))))\n"
161 | "\n"
162 | "(def >= args\n"
163 | "\"Is each element of 'args' greater than or equal to all following elements?\"\n"
164 | " (or (no args)\n"
165 | " (no (cdr args))\n"
166 | " (and (no (< (car args) (cadr args)))\n"
167 | " (apply >= (cdr args)))))\n"
168 | "\n"
169 | "(mac ++ (place (o i 1))\n"
170 | " (if (isa place 'cons)\n"
171 | " (w/uniq (a head index default)\n"
172 | " (if (is (car place) 'car) `(let ,a ,(cadr place) (scar ,a (+ (car ,a) ,i)))\n"
173 | " (if (is (car place) 'cdr) `(let ,a ,(cadr place) (scdr ,a (+ (cdr ,a) ,i)))\n"
174 | " (if (cddr place)\n"
175 | " `(with (,head ,(car place)\n"
176 | " ,index ,(cadr place)\n"
177 | " ,default ,(cadr (cdr place)))\n"
178 | " (sref ,head (+ (,head ,index ,default) ,i) ,index))\n"
179 | " 'else\n"
180 | " `(with (,head ,(car place)\n"
181 | " ,index ,(cadr place))\n"
182 | " (sref ,head (+ (,head ,index) ,i) ,index)))\n"
183 | " )))\n"
184 | " `(assign ,place (+ ,place ,i))))\n"
185 | "\n"
186 | "(mac -- (place (o i 1))\n"
187 | " (if (isa place 'cons)\n"
188 | " (w/uniq (a head index default)\n"
189 | " (if (is (car place) 'car) `(let ,a ,(cadr place) (scar ,a (- (car ,a) ,i)))\n"
190 | " (if (is (car place) 'cdr) `(let ,a ,(cadr place) (scdr ,a (- (cdr ,a) ,i)))\n"
191 | " (if (cddr place)\n"
192 | " `(with (,head ,(car place)\n"
193 | " ,index ,(cadr place)\n"
194 | " ,default ,(cadr (cdr place)))\n"
195 | " (sref ,head (- (,head ,index ,default) ,i) ,index))\n"
196 | " 'else\n"
197 | " `(with (,head ,(car place)\n"
198 | " ,index ,(cadr place))\n"
199 | " (sref ,head (- (,head ,index) ,i) ,index)))\n"
200 | " )))\n"
201 | " `(assign ,place (- ,place ,i))))\n"
202 | "\n"
203 | "(def nthcdr (n pair)\n"
204 | " (let i 0\n"
205 | " (while (and (< i n) pair)\n"
206 | " (= pair (cdr pair))\n"
207 | " (++ i)))\n"
208 | " pair)\n"
209 | "\n"
210 | "; = place value ...\n"
211 | "(mac = args\n"
212 | " `(do ,@(map1\n"
213 | " (fn (p)\n"
214 | " (with (place (car p) value (cadr p))\n"
215 | " (if (isa place 'cons)\n"
216 | " (if (is (car place) 'car) `(scar ,(cadr place) ,value)\n"
217 | " (is (car place) 'cdr) `(scdr ,(cadr place) ,value)\n"
218 | " (is (car place) 'caar) `(scar (car ,(cadr place)) ,value)\n"
219 | " (is (car place) 'cadr) `(scar (cdr ,(cadr place)) ,value)\n"
220 | " (is (car place) 'cddr) `(scdr (cdr ,(cadr place)) ,value)\n"
221 | " `(sref ,(car place) ,value ,(cadr place)))\n"
222 | " `(assign ,place ,value))))\n"
223 | " (pair args))))\n"
224 | "\n"
225 | "(mac unless (test . body)\n"
226 | " `(if (no ,test) (do ,@body)))\n"
227 | "\n"
228 | "(mac do1 xs `(let it ,(car xs) ,@(cdr xs) it))\n"
229 | "\n"
230 | "(def pr args\n"
231 | " \"Prints all its 'args' to screen. Returns the first arg.\"\n"
232 | " (map1 disp args)\n"
233 | " (car args))\n"
234 | "\n"
235 | "(def prn xs (do1 (apply pr xs) (writeb 10)))\n"
236 | "\n"
237 | "(mac for (var init max . body)\n"
238 | " (w/uniq g\n"
239 | " `(let ,g ,max (= ,var ,init)\n"
240 | " (while (<= ,var ,g) ,@body (++ ,var)))))\n"
241 | "\n"
242 | "(def idfn (x) x)\n"
243 | "\n"
244 | "(def number (n)\n"
245 | " \"Is 'n' a number?\"\n"
246 | " (is (type n) 'num))\n"
247 | "\n"
248 | "(def positive (x)\n"
249 | " (and (number x) (> x 0)))\n"
250 | "\n"
251 | "(mac withs (parms . body)\n"
252 | " \"Like [[with]], but binding for a variable can refer to earlier variables.\n"
253 | "For example, (withs (x 1 y (+ x 1))\n"
254 | " (+ x y))\n"
255 | " => 3\"\n"
256 | " (if (no parms)\n"
257 | " `(do ,@body)\n"
258 | " `(let ,(car parms) ,(cadr parms)\n"
259 | " (withs ,(cddr parms) ,@body))))\n"
260 | "\n"
261 | "(def even (n)\n"
262 | "\"Is n even?\"\n"
263 | " (is (mod n 2) 0))\n"
264 | "\n"
265 | "(def odd (n)\n"
266 | "\"Is n odd?\"\n"
267 | " (no (even n)))\n"
268 | "\n"
269 | "(def round (n)\n"
270 | "\"Approximates a fractional value to the nearest even integer.\n"
271 | "Negative numbers are always treated exactly like their positive variants\n"
272 | "barring the sign.\"\n"
273 | " (withs (base (trunc n) rem (abs (- n base)))\n"
274 | " (if (> rem 0.5) ((if (> n 0) + -) base 1)\n"
275 | " (< rem 0.5) base\n"
276 | " (odd base) ((if (> n 0) + -) base 1)\n"
277 | " base)))\n"
278 | "\n"
279 | "(def roundup (n)\n"
280 | "\"Like [[round]] but halves are rounded up rather than down.\"\n"
281 | " (withs (base (trunc n) rem (abs (- n base)))\n"
282 | " (if (>= rem 0.5)\n"
283 | " ((if (> n 0) + -) base 1)\n"
284 | " base)))\n"
285 | "\n"
286 | "(def nearest (n quantum)\n"
287 | " \"Like [[round]] but generalized to arbitrary units.\"\n"
288 | " (* (roundup (/ n quantum)) quantum))\n"
289 | "\n"
290 | "(def avg (ns)\n"
291 | " \"Returns the arithmetic mean of a list of numbers 'ns'.\"\n"
292 | " (/ (apply + ns) (len ns)))\n"
293 | "\n"
294 | "(def multiple (x y)\n"
295 | " \"Is 'x' a multiple of 'y'?\"\n"
296 | " (is 0 (mod x y)))\n"
297 | "\n"
298 | "(def carif (x)\n"
299 | " \"Returns the first element of the given list 'x', or just 'x' if it isn't a list.\"\n"
300 | " (if (is (type x) 'cons) (car x) x))\n"
301 | "\n"
302 | "(mac iflet (var expr . branches)\n"
303 | "\"If 'expr' is not nil, binds 'var' to it before running the first branch.\n"
304 | "Can be given multiple alternating test expressions and branches. The first\n"
305 | "passing test expression is bound to 'var' before running its corresponding branch.\n"
306 | "\n"
307 | "For examples, see [[aif]].\"\n"
308 | " (if branches\n"
309 | " (w/uniq gv\n"
310 | " `(let ,gv ,expr\n"
311 | " (if ,gv\n"
312 | " (let ,var ,gv\n"
313 | " ,(car branches))\n"
314 | " ,(if (cdr branches)\n"
315 | " `(iflet ,var ,@(cdr branches))))))\n"
316 | " expr))\n"
317 | "\n"
318 | "(mac whenlet (var expr . body)\n"
319 | " \"Like [[when]] but also puts the value of 'expr' in 'var' so 'body' can access it.\"\n"
320 | " `(iflet ,var ,expr (do ,@body)))\n"
321 | "\n"
322 | "(def best (f seq)\n"
323 | " \"Maximizes comparator function 'f' throughout seq.\"\n"
324 | " (whenlet wins (carif seq)\n"
325 | " (each elt (cdr seq)\n"
326 | " (if (f elt wins)\n"
327 | " (= wins elt)))\n"
328 | " wins))\n"
329 | "\n"
330 | "(def max args\n"
331 | " \"Returns the greatest of 'args'.\"\n"
332 | " (best > args))\n"
333 | "\n"
334 | "(def min args\n"
335 | " \"Returns the least of 'args'.\"\n"
336 | " (best < args))\n"
337 | "\n"
338 | "(def firstn (n xs)\n"
339 | " \"Returns the first 'n' elements of 'xs'.\"\n"
340 | " (if (no n) xs\n"
341 | " (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs)))\n"
342 | " nil))\n"
343 | "\n"
344 | "(mac afn (parms . body)\n"
345 | "\"Like [[fn]] and [[rfn]] but the created function can call itself as 'self'\"\n"
346 | " `(rfn self ,parms ,@body))\n"
347 | "\n"
348 | "(mac compose args\n"
349 | "\"Takes a list of functions and returns a function that behaves as if all its\n"
350 | "'args' were called in sequence.\n"
351 | "For example, this is always true:\n"
352 | " ((compose f g h) a b c) <=> (f (g (h a b c))).\n"
353 | "Be wary of passing macros to compose.\"\n"
354 | " (w/uniq g\n"
355 | " `(fn ,g\n"
356 | " ,((afn (fs)\n"
357 | " (if cdr.fs\n"
358 | " (list car.fs (self cdr.fs))\n"
359 | " `(apply ,(if car.fs car.fs 'idfn) ,g))) args))))\n"
360 | "\n"
361 | "; Destructive stable merge-sort, adapted from slib and improved\n"
362 | "; by Eli Barzilay for MzLib; re-written in Arc.\n"
363 | "\n"
364 | "(def mergesort (less? lst)\n"
365 | " (with (n (len lst))\n"
366 | " (if (<= n 1) lst\n"
367 | " ((rfn recur (n)\n"
368 | " (if (> n 2)\n"
369 | " ; needs to evaluate L->R\n"
370 | " (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round\n"
371 | " a (recur j)\n"
372 | " b (recur (- n j)))\n"
373 | " (merge less? a b))\n"
374 | " ; the following case just inlines the length 2 case,\n"
375 | " ; it can be removed (and use the above case for n>1)\n"
376 | " ; and the code still works, except a little slower\n"
377 | " (is n 2)\n"
378 | " (with (x (car lst) y (cadr lst) p lst)\n"
379 | " (= lst (cddr lst))\n"
380 | " (when (less? y x) (scar p y) (scar (cdr p) x))\n"
381 | " (scdr (cdr p) nil)\n"
382 | " p)\n"
383 | " (is n 1)\n"
384 | " (with (p lst)\n"
385 | " (= lst (cdr lst))\n"
386 | " (scdr p nil)\n"
387 | " p)\n"
388 | " nil)) n))))\n"
389 | "\n"
390 | "; Also by Eli.\n"
391 | "\n"
392 | "(def merge (less? x y)\n"
393 | " (if (no x) y\n"
394 | " (no y) x\n"
395 | " (let lup nil\n"
396 | " (assign lup\n"
397 | " (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?\n"
398 | " (if (less? (car y) (car x))\n"
399 | " (do (if r-x? (scdr r y))\n"
400 | " (if (cdr y) (lup y x (cdr y) nil) (scdr y x)))\n"
401 | " ; (car x) <= (car y)\n"
402 | " (do (if (no r-x?) (scdr r x))\n"
403 | " (if (cdr x) (lup x (cdr x) y t) (scdr x y))))))\n"
404 | " (if (less? (car y) (car x))\n"
405 | " (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))\n"
406 | " y)\n"
407 | " ; (car x) <= (car y)\n"
408 | " (do (if (cdr x) (lup x (cdr x) y t) (scdr x y))\n"
409 | " x)))))\n"
410 | "\n"
411 | "(def acons (x)\n"
412 | "\"Is 'x' a non-nil list?\"\n"
413 | " (is (type x) 'cons))\n"
414 | "\n"
415 | "(def alist (x)\n"
416 | "\"Is 'x' a (possibly empty) list?\"\n"
417 | "(or (no x) (acons x)))\n"
418 | "\n"
419 | "(mac in (x . choices)\n"
420 | "\"Does 'x' match one of the given 'choices'?\"\n"
421 | " (w/uniq g\n"
422 | " `(let ,g ,x\n"
423 | " (or ,@(map1 (fn (c) `(is ,g ,c))\n"
424 | " choices)))))\n"
425 | "\n"
426 | "(def atom (x)\n"
427 | "\"Is 'x' a simple type? (i.e. not list, table or user-defined)\"\n"
428 | " (in (type x) 'int 'num 'sym 'char 'string))\n"
429 | "\n"
430 | "(def copy (x)\n"
431 | "\"Creates a deep copy of 'x'. Future changes to any part of 'x' are guaranteed\n"
432 | "to be isolated from the copy.\"\n"
433 | " (if (atom x)\n"
434 | " x\n"
435 | " (cons (copy (car x))\n"
436 | " (copy (cdr x)))))\n"
437 | "\n"
438 | "; Use mergesort on assumption that mostly sorting mostly sorted lists\n"
439 | "(def sort (test seq)\n"
440 | "\"Orders a list 'seq' by comparing its elements using 'test'.\"\n"
441 | " (if (alist seq)\n"
442 | " (mergesort test (copy seq))\n"
443 | " (coerce (mergesort test (coerce seq 'cons)) (type seq))))\n"
444 | "\n"
445 | "(def med (ns (o test >))\n"
446 | " \"Returns the median of a list of numbers 'ns' according to the comparison 'test'. Takes the later element for an even-length list.\"\n"
447 | " ((sort test ns) (trunc (/ (len ns) 2))))\n"
448 | "\n"
449 | "(def median (ns)\n"
450 | " \"Returns the median of the list (the element at the midpoint of the list when sorted highest-to-lowest). Takes the earlier element for an even-length list.\"\n"
451 | " ((sort < ns) (trunc (/ (len ns) 2))))\n"
452 | "\n"
453 | "(def testify (x)\n"
454 | "\"Turns an arbitrary value 'x' into a predicate function to compare with 'x'.\"\n"
455 | " (if (isa x 'fn) x [iso _ x]))\n"
456 | "\n"
457 | "(def reclist (f xs)\n"
458 | "\"Calls function 'f' with successive [[cdr]]s of 'xs' until one of the calls passes.\"\n"
459 | " (and xs (or (f xs) (if (acons xs) (reclist f (cdr xs))))))\n"
460 | "\n"
461 | "(mac check (x test (o alt))\n"
462 | "\"Returns `x' if it satisfies `test', otherwise returns 'alt' (nil if it's not provided).\"\n"
463 | " (w/uniq gx\n"
464 | " `(let ,gx ,x\n"
465 | " (if (,test ,gx) ,gx ,alt))))\n"
466 | "\n"
467 | "(def find (test seq)\n"
468 | "\"Returns the first element of 'seq' that satisfies `test'.\"\n"
469 | " (let f (testify test)\n"
470 | " (reclist [check (carif _) f] seq)))\n"
471 | "\n"
472 | "(def get (i)\n"
473 | " \"Returns a function to pass 'i' to its input.\n"
474 | "Useful in higher-order functions, or to index into lists, strings, tables, etc.\"\n"
475 | " [_ i])\n"
476 | "\n"
477 | "; Syntax expansion is done by reader.\n"
478 | "(def ssexpand (symbol) symbol)\n"
479 | "\n"
480 | "(def fill-table (table data)\n"
481 | "\"Populates 'table' with alternating keys and values in 'data'.\"\n"
482 | " (do1 table\n"
483 | " (each p pair.data\n"
484 | " (with (k (car p) v (cadr p))\n"
485 | " (= table.k v)))))\n"
486 | "\n"
487 | "(def keys (h)\n"
488 | " \"Returns list of keys in table 'h'.\"\n"
489 | " (let r nil\n"
490 | " (maptable (fn (k v) (= r (cons k r))) h) r))\n"
491 | "\n"
492 | "(def vals (h)\n"
493 | " \"Returns list of values in table 'h'.\"\n"
494 | " (let r nil\n"
495 | " (maptable (fn (k v) (= r (cons v r))) h) r))\n"
496 | "\n"
497 | "(def tablist (h)\n"
498 | " \"Converts table 'h' into an association list of (key value) pairs. Reverse of [[listtab]].\"\n"
499 | " (let r nil\n"
500 | " (maptable (fn p (= r (cons p r))) h) r))\n"
501 | "\n"
502 | "(def listtab (al)\n"
503 | " \"Converts association list 'al' of (key value) pairs into a table. Reverse of [[tablist]].\"\n"
504 | " (let h (table)\n"
505 | " (map1 (fn (p) (with (k (car p) v (cadr p)) (= (h k) v)))\n"
506 | " al)\n"
507 | " h))\n"
508 | "\n"
509 | "(mac obj args\n"
510 | "\"Creates a table out of a list of alternating keys and values.\"\n"
511 | " `(listtab (list ,@(map1 (fn (p) (with (k (car p) v (cadr p))\n"
512 | " `(list ',k ,v)))\n"
513 | " (pair args)))))\n"
514 | "\n"
515 | "(mac caselet (var expr . args)\n"
516 | "\"Like [[case]], but 'expr' is also bound to 'var' and available inside the 'args'.\"\n"
517 | " `(let ,var ,expr\n"
518 | " ,((afn (args)\n"
519 | " (if (no cdr.args)\n"
520 | " car.args\n"
521 | " `(if (is ,var ',car.args)\n"
522 | " ,cadr.args\n"
523 | " ,(self cddr.args)))) args)))\n"
524 | "\n"
525 | "(mac case (expr . args)\n"
526 | "\"Usage: (case expr test1 then1 test2 then2 ...)\n"
527 | "Matches 'expr' to the first satisfying 'test' and runs the corresponding 'then' branch.\"\n"
528 | " `(caselet ,(uniq) ,expr ,@args))\n"
529 | "\n"
530 | "(mac w/table (var . body)\n"
531 | " \"Runs 'body' to add to table 'var' and finally return it.\"\n"
532 | " `(let ,var (table) ,@body ,var))\n"
533 | "\n"
534 | "(def memtable ((o keys nil) (o val t))\n"
535 | " \"Turns a list into a table indicating membership of all elements.\"\n"
536 | " (w/table tbl\n"
537 | " (each key keys\n"
538 | " (= tbl.key val))))\n"
539 | "\n"
540 | "(def pos (test seq (o start 0))\n"
541 | " \"Returns the index of the first element of 'seq' matching 'test', starting\n"
542 | "from index 'start' (0 by default).\"\n"
543 | " (with (f testify.test seq (coerce seq 'cons))\n"
544 | " ((afn (seq n)\n"
545 | " (if (no seq)\n"
546 | " nil\n"
547 | " (f car.seq)\n"
548 | " n\n"
549 | " (self cdr.seq (+ n 1)))) (nthcdr start seq) start)))\n"
550 | "\n"
551 | "(def trues (f xs)\n"
552 | "\"Returns (map1 f xs) dropping any nils.\"\n"
553 | " (and xs\n"
554 | " (iflet fx (f car.xs)\n"
555 | " (cons fx (trues f cdr.xs))\n"
556 | " (trues f cdr.xs))))\n"
557 | "\n"
558 | "(def rem (test seq)\n"
559 | " \"Returns all elements of 'seq' except those satisfying 'test'.\"\n"
560 | " (with (f (testify test) type* (type seq))\n"
561 | " (coerce\n"
562 | " ((afn (s)\n"
563 | " (if (no s) nil\n"
564 | " (f car.s) (self cdr.s)\n"
565 | " 'else (cons car.s (self cdr.s)))) (coerce seq 'cons)) type*)))\n"
566 | "\n"
567 | "(def keep (test seq)\n"
568 | " \"Returns all elements of 'seq' for which 'test' passes.\"\n"
569 | " (rem (complement (testify test)) seq))\n"
570 | "\n"
571 | "(def assoc (key al)\n"
572 | " \"Finds a (key value) pair in an association list 'al' of such pairs.\"\n"
573 | " (if (no acons.al) nil\n"
574 | " (and (acons (car al)) (is (caar al) key)) (car al)\n"
575 | " (assoc key (cdr al))))\n"
576 | "\n"
577 | "(def alref (al key)\n"
578 | " \"Returns the value of 'key' in an association list 'al' of (key value) pairs\"\n"
579 | " (cadr (assoc key al)))\n"
580 | "\n"
581 | "(mac wipe args\n"
582 | "\"Sets each place in 'args' to nil.\"\n"
583 | " `(do ,@(map1 (fn (a) `(= ,a nil)) args)))\n"
584 | "\n"
585 | "(mac set args\n"
586 | " \"Sets each place in 'args' to t.\"\n"
587 | " `(do ,@(map1 (fn (a) `(= ,a t)) args)))\n"
588 | "\n"
589 | "(mac aif (expr . branches)\n"
590 | "\"Like [[if]], but also puts the value of 'expr' in variable 'it'.\"\n"
591 | " `(iflet it ,expr ,@branches))\n"
592 | "\n"
593 | "(mac swap (place1 place2)\n"
594 | " \"Exchanges the values of 'place1' and 'place2'.\"\n"
595 | " (w/uniq g\n"
596 | " `(let ,g ,place1 (= ,place1 ,place2) (= ,place2 ,g))))\n"
597 | "\n"
598 | "(mac rotate places\n"
599 | " \"Like [[swap]] but for more than two places.\n"
600 | "For example, after (rotate place1 place2 place3), place3 is moved to place2,\n"
601 | "place2 to place1, and place1 to place3.\"\n"
602 | " (if (no places) nil\n"
603 | " (w/uniq g\n"
604 | " (let binds* nil\n"
605 | " ((afn (x) (when x (push (list = (car x) (aif (cdr x) (car it) g)) binds*) (self (cdr x)))) places)\n"
606 | " `(let ,g ,(car places) ,@(rev binds*))))))\n"
607 | "\n"
608 | "(mac zap (op place . args)\n"
609 | " \"Replaces 'place' with (op place args...)\"\n"
610 | " `(= ,place (,op ,place ,@args)))\n"
611 | "\n"
612 | "(mac push (x place)\n"
613 | " \"Adds 'x' to the start of the sequence at 'place'.\"\n"
614 | " `(= ,place (cons ,x ,place)))\n"
615 | "\n"
616 | "(mac pop (place)\n"
617 | " \"Opposite of [[push]]: removes the first element of the sequence at 'place' and returns it.\"\n"
618 | " `(= ,place (cdr ,place)))\n"
619 | "\n"
620 | "(mac pull (test place)\n"
621 | " \"Removes all elements from 'place' that satisfy 'test'.\"\n"
622 | " `(= ,place (rem ,test ,place)))\n"
623 | "\n"
624 | "(def recstring (test s (o start 0))\n"
625 | "\"Calls function 'test' with successive characters in string 's' until one of the calls passes.\"\n"
626 | " ((afn ((o i start))\n"
627 | " (and (< i len.s)\n"
628 | " (or test.i\n"
629 | " (self (+ i 1)))))))\n"
630 | "\n"
631 | "(def some (test seq)\n"
632 | " \"Does at least one element of 'seq' satisfy 'test'?\"\n"
633 | " (let f testify.test\n"
634 | " (if (isa seq 'string)\n"
635 | " (recstring f:seq seq)\n"
636 | " (reclist f:carif seq))))\n"
637 | "\n"
638 | "(def all (test seq)\n"
639 | " \"Does every element of 'seq' satisfy 'test'?\"\n"
640 | " (~some (complement (testify test)) seq))\n"
641 | "\n"
642 | "(def adjoin (x xs)\n"
643 | " (if (some x xs)\n"
644 | " xs\n"
645 | " (cons x xs)))\n"
646 | "\n"
647 | "(mac pushnew (x place)\n"
648 | " \"Like [[push]] but first checks if 'x' is already present in 'place'.\"\n"
649 | " `(= ,place (adjoin ,x ,place)))\n"
650 | "\n"
651 | "(mac nor args\n"
652 | " \"Computes args until one of them passes, then returns nil.\n"
653 | "Returns t if none of the args passes.\"\n"
654 | " `(no (or ,@args)))\n"
655 | "\n"
656 | "(mac until (test . body)\n"
657 | "\"Like [[while]], but negates 'test'; loops through 'body' as long as 'test' fails.\"\n"
658 | " `(while (no ,test) ,@body))\n"
659 | "\n"
660 | "(mac whilet (var test . body)\n"
661 | " \"Like [[while]], but successive values of 'test' are bound to 'var'.\"\n"
662 | " `(let ,var nil\n"
663 | " (while (= ,var ,test) ,@body)))\n"
664 | "\n"
665 | "(mac whiler (var expr end . body)\n"
666 | "\"Repeatedly binds 'var' to 'expr' and runs 'body' until 'var' matches 'end'.\"\n"
667 | " (w/uniq gendf\n"
668 | " `(withs (,var nil ,gendf (testify ,end))\n"
669 | " (while (no (,gendf (= ,var ,expr)))\n"
670 | " ,@body))))\n"
671 | "\n"
672 | "(mac loop (start test update . body)\n"
673 | " \"Executes start, then executes body repeatedly, checking test before each iteration and executing update afterward.\"\n"
674 | " `(do ,start\n"
675 | " (while ,test ,@body ,update)))\n"
676 | "\n"
677 | "(mac accum (accfn . body)\n"
678 | "\"Runs 'body' (usually containing a loop) and then returns in order all the\n"
679 | "values that were called with 'accfn' in the process.\n"
680 | "Can be cleaner than map for complex anonymous functions.\"\n"
681 | " (w/uniq gacc\n"
682 | " `(withs (,gacc nil ,accfn [push _ ,gacc])\n"
683 | " ,@body\n"
684 | " (rev ,gacc))))\n"
685 | "\n"
686 | "(mac drain (expr (o eos nil))\n"
687 | "\"Repeatedly evaluates 'expr' until it returns 'eos' (nil by default). Returns\n"
688 | "a list of the results.\"\n"
689 | " (w/uniq (gacc gres)\n"
690 | " `(accum ,gacc\n"
691 | " (whiler ,gres ,expr ,eos\n"
692 | " (,gacc ,gres)))))\n"
693 | "\n"
694 | "(mac repeat (n . body)\n"
695 | " \"Runs 'body' expression by expression 'n' times.\"\n"
696 | " (w/uniq g\n"
697 | " `(for ,g 1 ,n ,@body)))\n"
698 | "\n"
699 | "(mac forlen (var s . body)\n"
700 | " \"Loops through the length of sequence 's', binding each element to 'var'.\"\n"
701 | " `(for ,var 0 (- (len ,s) 1) ,@body))\n"
702 | "\n"
703 | "(mac noisy-each (n var val . body)\n"
704 | "\"Like [[each]] but print a progress indicator every 'n' iterations.\"\n"
705 | " (w/uniq (gn gc)\n"
706 | " `(with (,gn ,n ,gc 0)\n"
707 | " (each ,var ,val\n"
708 | " (when (multiple (++ ,gc) ,gn)\n"
709 | " (pr \".\")\n"
710 | " (flushout)\n"
711 | " )\n"
712 | " ,@body)\n"
713 | " (prn)\n"
714 | " (flushout))))\n"
715 | "\n"
716 | "(mac on (var s . body)\n"
717 | "\"Like [[each]], but also maintains a variable calles 'index' counting the iterations.\"\n"
718 | " (if (is var 'index)\n"
719 | " (err \"Can't use index as first arg to on.\")\n"
720 | " (w/uniq gs\n"
721 | " `(let ,gs ,s\n"
722 | " (forlen index ,gs\n"
723 | " (let ,var (,gs index)\n"
724 | " ,@body))))))\n"
725 | "\n"
726 | "(mac ontable (k v tab . body)\n"
727 | " \"Iterates over the table tab, assigning k and v each key and value.\"\n"
728 | " `(maptable (fn (,k ,v) ,@body) ,tab))\n"
729 | "\n"
730 | "(def empty (seq)\n"
731 | " \"Is 'seq' an empty container? Usually checks 'seq's [[len]].\"\n"
732 | " (iso 0 len.seq))\n"
733 | "\n"
734 | "(def orf fns\n"
735 | "\"Returns a function which calls all the functions in 'fns' on its args, and\n"
736 | "[[or]]s the results. ((orf f g) x y) <=> (or (f x y) (g x y))\"\n"
737 | " (fn args\n"
738 | " ((afn ((o fs fns))\n"
739 | " (and fs\n"
740 | " (or (apply car.fs args)\n"
741 | " (self cdr.fs)))))))\n"
742 | "\n"
743 | "(def andf fns\n"
744 | "\"Returns a function which calls all the functions in 'fns' on its args, and\n"
745 | "[[and]]s the results. For example, ((andf f g) x y) <=> (and (f x y) (g x y)).\n"
746 | "Simple syntax: f&g <=> (andf f g)\"\n"
747 | " (fn args\n"
748 | " ((afn ((o fs fns))\n"
749 | " (if no.fs t\n"
750 | " (no cdr.fs) (apply car.fs args)\n"
751 | " 'else (and (apply car.fs args)\n"
752 | " (self cdr.fs)))))))\n"
753 | "\n"
754 | "(def atend (i s)\n"
755 | "\"Is index 'i' at or past the end of sequence 's'?\"\n"
756 | " (>= i (- len.s 1)))\n"
757 | "\n"
758 | "(mac aand args\n"
759 | "\"Like [[and]], but each expression in 'args' can access the result of the\n"
760 | "previous one in variable 'it'.\"\n"
761 | " (if (no args)\n"
762 | " t\n"
763 | " (no (cdr args))\n"
764 | " (car args)\n"
765 | " `(let it ,(car args) (and it (aand ,@(cdr args))))))\n"
766 | "\n"
767 | "(def dotted (x)\n"
768 | "\"Is 'x' an _improper_ list terminating in something other than nil?\n"
769 | "Name comes from (cons 1 2) being printed with a dot: (1 . 1).\"\n"
770 | " (aand acons.x\n"
771 | " cdr.x\n"
772 | " ((orf ~acons dotted) it)))\n"
773 | "\n"
774 | "(mac conswhen (f x y)\n"
775 | "\"Adds 'x' to the front of 'y' if 'x' satisfies test 'f'.\"\n"
776 | " (w/uniq (gf gx)\n"
777 | " `(with (,gf ,f ,gx ,x)\n"
778 | " (if (,gf ,gx) (cons ,gx ,y) ,y))))\n"
779 | "\n"
780 | "(def consif (x xs)\n"
781 | " \"Like [[cons]] on 'x' and 'xs' unless 'x' is nil.\"\n"
782 | " (if x (cons x xs) xs))\n"
783 | "\n"
784 | "(def last (xs)\n"
785 | " \"Returns the last element of 'xs'.\"\n"
786 | " (if (cdr xs)\n"
787 | " (last (cdr xs))\n"
788 | " (car xs)))\n"
789 | "\n"
790 | "(def flat x\n"
791 | " \"Flattens a list of lists.\"\n"
792 | " ((afn ((o x x) (o acc nil))\n"
793 | " (if no.x acc\n"
794 | " (~acons x) (cons x acc)\n"
795 | " 'else (self car.x (self cdr.x acc))))))\n"
796 | "\n"
797 | "(def caris (x val)\n"
798 | " (and (acons x) (is (car x) val)))\n"
799 | "\n"
800 | "; common uses of map\n"
801 | "(def mappend (f . args)\n"
802 | "\"Like [[map]] followed by append.\"\n"
803 | " (apply + (apply + (map1 [map f _] args))))\n"
804 | "\n"
805 | "(def range-bounce (i max)\n"
806 | "\"Munges index 'i' in slices of a sequence of length 'max'. First element starts\n"
807 | " at index 0. Negative indices count from the end. A nil index denotes the end.\"\n"
808 | " (if (no i) max\n"
809 | " (< i 0) (+ max i)\n"
810 | " (>= i max) max\n"
811 | " 'else i))\n"
812 | "\n"
813 | "(def cut (seq start (o end))\n"
814 | "\"Extract a chunk of 'seq' from index 'start' (inclusive) to 'end' (exclusive). 'end'\n"
815 | "can be left out or nil to indicate everything from 'start', and can be\n"
816 | "negative to count backwards from the end.\"\n"
817 | " (firstn (- (range-bounce end len.seq)\n"
818 | " start)\n"
819 | " (nthcdr start seq)))\n"
820 | "\n"
821 | "(def split (seq pos)\n"
822 | " \"Partitions 'seq' at index 'pos'.\"\n"
823 | " (list (cut seq 0 pos) (cut seq pos)))\n"
824 | "\n"
825 | "; Generalization of pair: (tuples x) = (pair x)\n"
826 | "(def tuples (xs (o n 2))\n"
827 | "\"Splits 'xs' up into lists of size 'n'. Generalization of [[pair]].\"\n"
828 | " (if (no xs)\n"
829 | " nil\n"
830 | " (cons (firstn n xs)\n"
831 | " (tuples (nthcdr n xs) n))))\n"
832 | "\n"
833 | "(def copylist (x) x)\n"
834 | "\n"
835 | "(def inc (x (o n 1))\n"
836 | " (coerce (+ (coerce x 'int) n) (type x)))\n"
837 | "\n"
838 | "(def range (start end)\n"
839 | "\"Returns the list of integers from 'start' to 'end' (both inclusive).\"\n"
840 | " (with (r nil i end)\n"
841 | " (while (>= i start)\n"
842 | " (= r (cons i r)) (-- i))\n"
843 | " r))"
844 | "\n"
845 | "(mac n-of (n expr)\n"
846 | " \"Runs 'expr' 'n' times, and returns a list of the results.\"\n"
847 | " (w/uniq ga\n"
848 | " `(let ,ga nil\n"
849 | " (repeat ,n (push ,expr ,ga))\n"
850 | " (rev ,ga))))\n"
851 | "\n"
852 | "(def counts (seq (o tbl (table)))\n"
853 | "\"Returns a table with counts of each unique element in 'seq'.\"\n"
854 | " (let ans tbl\n"
855 | " (each x seq\n"
856 | " (++ (ans x 0)))\n"
857 | " ans))\n"
858 | "\n"
859 | "(def compare (comparer scorer)\n"
860 | " \"Creates a function to score two args using 'scorer' and compare them using\n"
861 | "'comparer'. Often passed to [[sort]].\"\n"
862 | " (fn (x y) (comparer scorer.x scorer.y)))\n"
863 | "\n"
864 | "(def commonest (seq)\n"
865 | " \"Returns the most common element of 'seq' and the number of times it occurred\n"
866 | "in 'seq'.\"\n"
867 | " (withs (counts* (counts seq)\n"
868 | " best* (best (compare > counts*) seq)) \n"
869 | " (list best* (counts* best* 0))))\n"
870 | "\n"
871 | "(def retrieve (n f xs)\n"
872 | "\"Returns the first 'n' elements of 'xs' that satisfy 'f'.\"\n"
873 | " (if (no n) (keep f xs)\n"
874 | " (or no.xs (<= n 0)) nil\n"
875 | " (f car.xs) (cons car.xs (retrieve (- n 1) f cdr.xs))\n"
876 | " (retrieve n f cdr.xs)))\n"
877 | "(def most (f seq)\n"
878 | "\"Like [[best]], but function 'f' is a scorer for each element rather than a\n"
879 | "comparator between elements.\"\n"
880 | " (if seq\n"
881 | " (withs (wins (car seq) topscore (f wins))\n"
882 | " (each elt (cdr seq)\n"
883 | " (let score (f elt)\n"
884 | " (if (> score topscore) (= wins elt topscore score))))\n"
885 | " wins)))\n"
886 | "\n"
887 | "(def mem (test seq)\n"
888 | "\"Returns suffix of 'seq' after the first element to satisfy 'test'.\n"
889 | "This is the most reliable way to check for presence, even when searching for nil.\"\n"
890 | " (let f (testify test)\n"
891 | " (reclist [if (f:carif _) _] seq)))\n"
892 | "\n"
893 | "(def insert-sorted (test elt seq)\n"
894 | "\"Inserts 'elt' into a sequence 'seq' that is assumed to be sorted by 'test'.\"\n"
895 | " (if (no seq)\n"
896 | " (list elt)\n"
897 | " (test elt car.seq)\n"
898 | " (cons elt seq)\n"
899 | " 'else\n"
900 | " (cons car.seq (insert-sorted test elt cdr.seq))))\n"
901 | "\n"
902 | "(mac insort (test elt seq)\n"
903 | " \"Like [[insert-sorted]] but modifies 'seq' in place'.\"\n"
904 | " `(zap [insert-sorted ,test ,elt _] ,seq))\n"
905 | "\n"
906 | "(def reinsert-sorted (test elt seq)\n"
907 | " (if (no seq)\n"
908 | " (list elt)\n"
909 | " (is elt car.seq)\n"
910 | " (reinsert-sorted test elt cdr.seq)\n"
911 | " (test elt car.seq)\n"
912 | " (cons elt (rem elt seq))\n"
913 | " 'else\n"
914 | " (cons car.seq (reinsert-sorted test elt cdr.seq))))\n"
915 | "\n"
916 | "(mac insortnew (test elt seq)\n"
917 | " \"Like [[insort]], but only inserts 'elt' if it doesn't exist.\"\n"
918 | " `(zap [reinsert-sorted ,test ,elt _] ,seq))\n"
919 | "\n"
920 | "(def bestn (n f seq)\n"
921 | " \"Returns a list of the top 'n' elements of 'seq' ordered by 'f'.\"\n"
922 | " (firstn n (sort f seq)))\n"
923 | "\n"
924 | "(def count (test x)\n"
925 | "\"Returns the number of elements of 'x' that pass 'test'.\"\n"
926 | " (with (n 0 testf testify.test)\n"
927 | " (each elt x\n"
928 | " (if testf.elt ++.n))\n"
929 | " n))\n"
930 | "\n"
931 | "(def union (f xs ys)\n"
932 | "\"Merges 'xs' and 'ys', while filtering out duplicates using 'f'. Ordering is\n"
933 | "not preserved.\"\n"
934 | " (+ xs (rem (fn (y) (some [f _ y] xs))\n"
935 | " ys)))\n"
936 | "\n"
937 | "(def len< (x n)\n"
938 | " \"Is [[len]] of 'x' less than 'n'?\"\n"
939 | " (< len.x n))\n"
940 | "\n"
941 | "(def len> (x n)\n"
942 | " \"Is [[len]] of 'x' greater than 'n'?\"\n"
943 | " (> len.x n))\n"
944 | "\n"
945 | "(def dedup (xs)\n"
946 | "\"Returns list of elements in 'xs' with duplicates dropped.\"\n"
947 | " (let h (table)\n"
948 | " (accum yield\n"
949 | " (each x xs\n"
950 | " (unless h.x\n"
951 | " (yield x)\n"
952 | " (set h.x))))))\n"
953 | "\n"
954 | "(def single (x)\n"
955 | "\"Is 'x' a list with just one element?\"\n"
956 | " (and acons.x (no cdr.x)))\n"
957 | "\n"
958 | "(def before (x y seq (o i 0))\n"
959 | "\"Does 'x' lie before 'y' in 'seq' (optionally starting from index 'i')?\"\n"
960 | " (aand (pos (orf testify.x testify.y) seq i)\n"
961 | " (iso x seq.it)))\n"
962 | "\n"
963 | "(def rand-elt (seq)\n"
964 | "\"Returns a random element of 'seq'. See also [[rand-choice]].\"\n"
965 | " (seq (rand (len seq))))\n"
966 | "\n"
967 | "(mac point (name . body)\n"
968 | "\"Like [[do]], but may be exited by calling 'name' from within 'body'.\"\n"
969 | " `(ccc (fn (,name) ,@body)))\n"
970 | "\n"
971 | "(mac catch body\n"
972 | "\"Runs 'body', but any call to (throw x) immediately returns x.\"\n"
973 | " `(point throw ,@body))\n"
974 | "\n"
975 | "(def mismatch (s1 s2)\n"
976 | "\"Returns the first index where 's1' and 's2' do not match.\"\n"
977 | " (catch\n"
978 | " (on c s1\n"
979 | " (when (isnt c (s2 index))\n"
980 | " (throw index)))))\n"
981 | "\n"
982 | "(def sum (f xs)\n"
983 | "\"Returns total of all elements in (map1 f xs).\"\n"
984 | " (let n 0\n"
985 | " (each x xs\n"
986 | " (++ n f.x))\n"
987 | " n))\n"
988 | "\n"
989 | "(mac rand-choice exprs\n"
990 | "\"Runs one of the given 'exprs' at random and returns the result.\"\n"
991 | " `(case (rand ,(len exprs))\n"
992 | " ,@(let key -1\n"
993 | " (mappend [list (++ key) _]\n"
994 | " exprs))))\n"
995 | "\n"
996 | "(def only (f)\n"
997 | "\"Transforms a function 'f' info a variant that runs only if its first arg is\n"
998 | "non-nil.\"\n"
999 | " (fn args (if (car args) (apply f args))))\n"
1000 | "\n"
1001 | "(mac summing (sumfn . body)\n"
1002 | " \"Sums the number of times sumfn is called with a true argument in body. The sum is returned. The sumfn argument specifies the name under which the summing function is available to the body.\"\n"
1003 | " (w/uniq gacc\n"
1004 | " `(withs (,gacc 0 ,sumfn [if _ (++ ,gacc)])\n"
1005 | " ,@body\n"
1006 | " ,gacc)))\n"
1007 | "\n"
1008 | "(def map (proc . arg-lists)\n"
1009 | " (if (car arg-lists)\n"
1010 | " (cons (apply proc (map1 car arg-lists))\n"
1011 | " (apply map (cons proc\n"
1012 | " (map1 cdr arg-lists))))\n"
1013 | " nil))\n"
1014 | "\n"
1015 | "(def intersperse(x ys)\n"
1016 | " \"Inserts 'x' between the elements of 'ys'.\"\n"
1017 | " (and ys(cons(car ys)\n"
1018 | " (mappend[list x _](cdr ys)))))\n"
1019 | "(def memo (f)\n"
1020 | "\"Turns function 'f' into a _memoized_ version that also stores results returned\n"
1021 | "by args passed in, so that future calls with the same inputs can save work.\"\n"
1022 | " (let cache (table)\n"
1023 | " (fn args (aif (cache args) it (= (cache args) (apply f args))))))\n"
1024 | "\n"
1025 | "(mac defmemo (name parms . body)\n"
1026 | "\"Like [[def]] but defines a memoized function. See [[memo]].\"\n"
1027 | " `(assign ,name (memo (fn ,parms ,@body))))\n"
1028 | "(def readfile (filename)\n"
1029 | " (with (p (infile filename 'text)\n"
1030 | " r nil)\n"
1031 | " (whiler e (read p '_eof) '_eof (= r (cons e r)))\n"
1032 | " (rev r)))\n"
1033 | " \n"
1034 | "(def readfile1 (filename)\n"
1035 | " (let p (infile filename 'text)\n"
1036 | " (read p)))\n"
1037 | "\n"
1038 | "(def writefile (e filename)\n"
1039 | " (let p (outfile filename)\n"
1040 | " (write e p)\n"
1041 | " (close p)))\n";
1042 |
--------------------------------------------------------------------------------
/arc.c:
--------------------------------------------------------------------------------
1 | #include "arc.h"
2 | #include
3 |
4 | char *error_string[] = { "", "Syntax error", "Symbol not bound", "Wrong number of arguments", "Wrong type", "File error", "" };
5 | size_t stack_capacity = 0;
6 | size_t stack_size = 0;
7 | atom *stack = NULL;
8 | struct pair *pair_head = NULL;
9 | struct str *str_head = NULL;
10 | struct table *table_head = NULL;
11 | size_t alloc_count = 0;
12 | size_t alloc_count_old = 0;
13 | char **symbol_table = NULL;
14 | size_t symbol_size = 0;
15 | size_t symbol_capacity = 0;
16 | const atom nil = { T_NIL };
17 | atom env; /* the global environment */
18 | /* symbols for faster execution */
19 | atom sym_t, sym_quote, sym_quasiquote, sym_unquote, sym_unquote_splicing, sym_assign, sym_fn, sym_if, sym_mac, sym_apply, sym_cons, sym_sym, sym_string, sym_num, sym__, sym_o, sym_table, sym_int, sym_char, sym_do;
20 | atom err_expr;
21 | atom thrown;
22 |
23 | /* Be sure to free after use */
24 | void vector_new(struct vector *a) {
25 | a->capacity = sizeof(a->static_data) / sizeof(a->static_data[0]);
26 | a->size = 0;
27 | a->data = a->static_data;
28 | }
29 |
30 | void vector_add(struct vector *a, atom item) {
31 | if (a->size + 1 > a->capacity) {
32 | a->capacity *= 2;
33 | if (a->data == a->static_data) {
34 | a->data = malloc(a->capacity * sizeof(atom));
35 | memcpy(a->data, a->static_data, a->size * sizeof(atom));
36 | }
37 | else {
38 | a->data = realloc(a->data, a->capacity * sizeof(atom));
39 | }
40 | }
41 | a->data[a->size] = item;
42 | a->size++;
43 | }
44 |
45 | void vector_clear(struct vector *a) {
46 | a->size = 0;
47 | }
48 |
49 | void vector_free(struct vector *a) {
50 | if (a->data != a->static_data) free(a->data);
51 | }
52 |
53 | atom vector_to_atom(struct vector *a, int start) {
54 | atom r = nil;
55 | int i;
56 | for (i = a->size - 1; i >= start; i--) {
57 | r = cons(a->data[i], r);
58 | }
59 | return r;
60 | }
61 |
62 | /* Be sure to free after use */
63 | void atom_to_vector(atom a, struct vector *v) {
64 | vector_new(v);
65 | for (; !no(a); a = cdr(a)) {
66 | vector_add(v, car(a));
67 | }
68 | }
69 |
70 | void stack_add(atom a) {
71 | switch (a.type) {
72 | case T_CONS:
73 | case T_CLOSURE:
74 | case T_MACRO:
75 | case T_STRING:
76 | case T_TABLE:
77 | break;
78 | default:
79 | return;
80 | }
81 | stack_size++;
82 | if (stack_size > stack_capacity) {
83 | stack_capacity = stack_size * 2;
84 | stack = realloc(stack, stack_capacity * sizeof(atom));
85 | }
86 | stack[stack_size - 1] = a;
87 | }
88 |
89 | void stack_restore(int saved_size) {
90 | stack_size = saved_size;
91 | /* if there is waste of memory, realloc */
92 | if (stack_size < stack_capacity / 4) {
93 | stack_capacity = stack_size * 2;
94 | stack = realloc(stack, stack_capacity * sizeof(atom));
95 | }
96 | }
97 |
98 | void stack_restore_add(int saved_size, atom a) {
99 | stack_size = saved_size;
100 | /* if there is waste of memory, realloc */
101 | if (stack_size < stack_capacity / 4) {
102 | stack_capacity = stack_size * 2;
103 | stack = realloc(stack, stack_capacity * sizeof(atom));
104 | }
105 | stack_add(a);
106 | }
107 |
108 | void consider_gc() {
109 | if (alloc_count > 2 * alloc_count_old)
110 | gc();
111 | }
112 |
113 | atom cons(atom car_val, atom cdr_val)
114 | {
115 | struct pair *a;
116 | atom p;
117 |
118 | alloc_count++;
119 |
120 | a = malloc(sizeof(struct pair));
121 | a->mark = 0;
122 | a->next = pair_head;
123 | pair_head = a;
124 |
125 | p.type = T_CONS;
126 | p.value.pair = a;
127 |
128 | car(p) = car_val;
129 | cdr(p) = cdr_val;
130 |
131 | stack_add(p);
132 |
133 | return p;
134 | }
135 |
136 | void gc_mark(atom root)
137 | {
138 | struct pair *a;
139 | struct str *as;
140 | struct table *at;
141 | start:
142 | switch (root.type) {
143 | case T_CONS:
144 | case T_CLOSURE:
145 | case T_MACRO:
146 | a = root.value.pair;
147 | if (a->mark) return;
148 | a->mark = 1;
149 | gc_mark(car(root));
150 | /* reduce recursion */
151 | root = cdr(root);
152 | goto start;
153 | break;
154 | case T_STRING:
155 | as = root.value.str;
156 | if (as->mark) return;
157 | as->mark = 1;
158 | break;
159 | case T_TABLE: {
160 | at = root.value.table;
161 | if (at->mark) return;
162 | at->mark = 1;
163 | size_t i;
164 | for (i = 0; i < at->capacity; i++) {
165 | struct table_entry *e = at->data[i];
166 | while (e) {
167 | gc_mark(e->k);
168 | gc_mark(e->v);
169 | e = e->next;
170 | }
171 | }
172 | break; }
173 | default:
174 | return;
175 | }
176 | }
177 |
178 | void gc()
179 | {
180 | struct pair *a, **p;
181 | struct str *as, **ps;
182 | struct table *at, **pt;
183 |
184 | /* mark atoms in the stack */
185 | size_t i;
186 | for (i = 0; i < stack_size; i++) {
187 | gc_mark(stack[i]);
188 | }
189 |
190 | alloc_count_old = 0;
191 | /* Free unmarked "cons" allocations */
192 | p = &pair_head;
193 | while (*p != NULL) {
194 | a = *p;
195 | if (!a->mark) {
196 | *p = a->next;
197 | free(a);
198 | }
199 | else {
200 | p = &a->next;
201 | a->mark = 0; /* clear mark */
202 | alloc_count_old++;
203 | }
204 | }
205 |
206 | /* Free unmarked "string" allocations */
207 | ps = &str_head;
208 | while (*ps != NULL) {
209 | as = *ps;
210 | if (!as->mark) {
211 | *ps = as->next;
212 | free(as->value);
213 | free(as);
214 | }
215 | else {
216 | ps = &as->next;
217 | as->mark = 0; /* clear mark */
218 | alloc_count_old++;
219 | }
220 | }
221 |
222 | /* Free unmarked "table" allocations */
223 | pt = &table_head;
224 | while (*pt != NULL) {
225 | at = *pt;
226 | if (!at->mark) {
227 | *pt = at->next;
228 | size_t i;
229 | for (i = 0; i < at->capacity; i++) {
230 | struct table_entry *e = at->data[i];
231 | while (e) {
232 | struct table_entry *next = e->next;
233 | free(e);
234 | e = next;
235 | }
236 | }
237 | free(at->data);
238 | free(at);
239 | }
240 | else {
241 | pt = &at->next;
242 | at->mark = 0; /* clear mark */
243 | alloc_count_old++;
244 | }
245 | }
246 | alloc_count = alloc_count_old;
247 | }
248 |
249 |
250 | atom make_number(double x)
251 | {
252 | atom a;
253 | a.type = T_NUM;
254 | a.value.number = x;
255 | return a;
256 | }
257 |
258 | atom make_sym(const char *s)
259 | {
260 | atom a;
261 |
262 | int i;
263 | for (i = symbol_size - 1; i >= 0; i--) { /* compare recent symbol first */
264 | char *s2 = symbol_table[i];
265 | if (strcmp(s2, s) == 0) {
266 | a.type = T_SYM;
267 | a.value.symbol = s2;
268 | return a;
269 | }
270 | }
271 |
272 | a.type = T_SYM;
273 | a.value.symbol = (char*)strdup(s);
274 | if (symbol_size >= symbol_capacity) {
275 | symbol_capacity *= 2;
276 | symbol_table = realloc(symbol_table, symbol_capacity * sizeof(char *));
277 | }
278 | symbol_table[symbol_size] = a.value.symbol;
279 | symbol_size++;
280 | return a;
281 | }
282 |
283 | atom make_builtin(builtin fn)
284 | {
285 | atom a;
286 | a.type = T_BUILTIN;
287 | a.value.builtin = fn;
288 | return a;
289 | }
290 |
291 | error make_closure(atom env, atom args, atom body, atom *result)
292 | {
293 | atom p;
294 |
295 | if (!listp(body))
296 | return ERROR_SYNTAX;
297 |
298 | /* Check argument names are all symbols or conses */
299 | p = args;
300 | while (!no(p)) {
301 | if (p.type == T_SYM)
302 | break;
303 | else if (p.type != T_CONS || (car(p).type != T_SYM && car(p).type != T_CONS))
304 | return ERROR_TYPE;
305 | p = cdr(p);
306 | }
307 |
308 | if (no(body)) { /* no body */
309 | p = nil;
310 | }
311 |
312 | else if (no(cdr(body))) { /* 1 form only: do form not required */
313 | p = car(body);
314 | }
315 | else {
316 | p = cons(sym_do, body);
317 | }
318 | *result = cons(env, cons(args, p));
319 | result->type = T_CLOSURE;
320 |
321 | return ERROR_OK;
322 | }
323 |
324 | atom make_string(char *x)
325 | {
326 | atom a;
327 | struct str *s;
328 | alloc_count++;
329 | s = a.value.str = malloc(sizeof(struct str));
330 | s->value = x;
331 | s->mark = 0;
332 | s->next = str_head;
333 | str_head = s;
334 |
335 | a.type = T_STRING;
336 | stack_add(a);
337 | return a;
338 | }
339 |
340 | atom make_input(FILE *fp) {
341 | atom a;
342 | a.type = T_INPUT;
343 | a.value.fp = fp;
344 | return a;
345 | }
346 |
347 | atom make_input_pipe(FILE *fp) {
348 | atom a;
349 | a.type = T_INPUT_PIPE;
350 | a.value.fp = fp;
351 | return a;
352 | }
353 |
354 | atom make_output(FILE *fp) {
355 | atom a;
356 | a.type = T_OUTPUT;
357 | a.value.fp = fp;
358 | return a;
359 | }
360 |
361 | atom make_char(char c) {
362 | atom a;
363 | a.type = T_CHAR;
364 | a.value.ch = c;
365 | return a;
366 | }
367 |
368 | void print_expr(atom a)
369 | {
370 | char *s = to_string(a, 1);
371 | printf("%s", s);
372 | free(s);
373 | }
374 |
375 | void pr(atom a)
376 | {
377 | char *s = to_string(a, 0);
378 | printf("%s", s);
379 | free(s);
380 | }
381 |
382 | error lex(const char *str, const char **start, const char **end)
383 | {
384 | const char *ws = " \t\r\n";
385 | const char *delim = "()[] \t\r\n;";
386 | const char *prefix = "()[]'`";
387 | start:
388 | str += strspn(str, ws);
389 |
390 | if (str[0] == '\0') {
391 | *start = *end = NULL;
392 | return ERROR_FILE;
393 | }
394 |
395 | *start = str;
396 |
397 | if (strchr(prefix, str[0]) != NULL)
398 | *end = str + 1;
399 | else if (str[0] == ',')
400 | *end = str + (str[1] == '@' ? 2 : 1);
401 | else if (str[0] == '"') {
402 | str++;
403 | while (1) {
404 | if (*str == 0) return ERROR_FILE; /* string not terminated */
405 | if (*str == '\\') str++;
406 | else if (*str == '"') {
407 | break;
408 | }
409 | str++;
410 | }
411 | *end = str + 1;
412 | }
413 | else if (str[0] == ';') { /* end-of-line comment */
414 | str += strcspn(str, "\n");
415 | goto start;
416 | }
417 | else
418 | *end = str + strcspn(str, delim);
419 |
420 | return ERROR_OK;
421 | }
422 |
423 | error parse_simple(const char *start, const char *end, atom *result)
424 | {
425 | char *p;
426 |
427 | /* Is it a number? */
428 | double val = strtod(start, &p);
429 | if (p == end) {
430 | result->type = T_NUM;
431 | result->value.number = val;
432 | return ERROR_OK;
433 | }
434 | else if (start[0] == '"') { /* "string" */
435 | result->type = T_STRING;
436 | size_t length = end - start - 2;
437 | char *buf = (char*)malloc(length + 1);
438 | const char *ps = start + 1;
439 | char *pt = buf;
440 | while (ps < end - 1) {
441 | if (*ps == '\\') {
442 | char c_next = *(ps + 1);
443 | switch (c_next) {
444 | case 'r':
445 | *pt = '\r';
446 | break;
447 | case 'n':
448 | *pt = '\n';
449 | break;
450 | case 't':
451 | *pt = '\t';
452 | break;
453 | default:
454 | *pt = c_next;
455 | }
456 | ps++;
457 | }
458 | else {
459 | *pt = *ps;
460 | }
461 | ps++;
462 | pt++;
463 | }
464 | *pt = 0;
465 | buf = realloc(buf, pt - buf + 1);
466 | *result = make_string(buf);
467 | return ERROR_OK;
468 | }
469 | else if (start[0] == '#') { /* #\char */
470 | char *buf = malloc(end - start + 1);
471 | memcpy(buf, start, end - start);
472 | buf[end - start] = 0;
473 | size_t length = end - start;
474 | if (length == 3 && buf[1] == '\\') { /* plain character e.g. #\a */
475 | *result = make_char(buf[2]);
476 | free(buf);
477 | return ERROR_OK;
478 | }
479 | else {
480 | char c;
481 | if (strcmp(buf, "#\\nul") == 0)
482 | c = '\0';
483 | else if (strcmp(buf, "#\\return") == 0)
484 | c = '\r';
485 | else if (strcmp(buf, "#\\newline") == 0)
486 | c = '\n';
487 | else if (strcmp(buf, "#\\tab") == 0)
488 | c = '\t';
489 | else if (strcmp(buf, "#\\space") == 0)
490 | c = ' ';
491 | else {
492 | free(buf);
493 | return ERROR_SYNTAX;
494 | }
495 | free(buf);
496 | *result = make_char(c);
497 | return ERROR_OK;
498 | }
499 | }
500 |
501 | /* NIL or symbol */
502 | char *buf = malloc(end - start + 1);
503 | memcpy(buf, start, end - start);
504 | buf[end - start] = 0;
505 |
506 | if (strcmp(buf, "nil") == 0)
507 | *result = nil;
508 | else if (strcmp(buf, ".") == 0)
509 | *result = make_sym(buf);
510 | else {
511 | atom a1, a2;
512 | long length = end - start, i;
513 | for (i = length - 1; i >= 0; i--) { /* left-associative */
514 | if (buf[i] == '.') { /* a.b => (a b) */
515 | if (i == 0 || i == length - 1) {
516 | free(buf);
517 | return ERROR_SYNTAX;
518 | }
519 | error err;
520 | err = parse_simple(buf, buf + i, &a1);
521 | if (err) {
522 | free(buf);
523 | return ERROR_SYNTAX;
524 | }
525 | err = parse_simple(buf + i + 1, buf + length, &a2);
526 | if (err) {
527 | free(buf);
528 | return ERROR_SYNTAX;
529 | }
530 | free(buf);
531 | *result = cons(a1, cons(a2, nil));
532 | return ERROR_OK;
533 | }
534 | else if (buf[i] == '!') { /* a!b => (a 'b) */
535 | if (i == 0 || i == length - 1) {
536 | free(buf);
537 | return ERROR_SYNTAX;
538 | }
539 | error err;
540 | err = parse_simple(buf, buf + i, &a1);
541 | if (err) {
542 | free(buf);
543 | return ERROR_SYNTAX;
544 | }
545 | err = parse_simple(buf + i + 1, buf + length, &a2);
546 | if (err) {
547 | free(buf);
548 | return ERROR_SYNTAX;
549 | }
550 | free(buf);
551 | *result = cons(a1, cons(cons(sym_quote, cons(a2, nil)), nil));
552 | return ERROR_OK;
553 | }
554 | else if (buf[i] == ':') { /* a:b => (compose a b) */
555 | if (i == 0 || i == length - 1) {
556 | free(buf);
557 | return ERROR_SYNTAX;
558 | }
559 | error err;
560 | err = parse_simple(buf, buf + i, &a1);
561 | if (err) {
562 | free(buf);
563 | return ERROR_SYNTAX;
564 | }
565 | err = parse_simple(buf + i + 1, buf + length, &a2);
566 | if (err) {
567 | free(buf);
568 | return ERROR_SYNTAX;
569 | }
570 | free(buf);
571 | *result = cons(make_sym("compose"), cons(a1, cons(a2, nil)));
572 | return ERROR_OK;
573 | }
574 | }
575 | if (length >= 2 && buf[0] == '~') { /* ~a => (complement a) */
576 | atom a1;
577 | error err = parse_simple(buf + 1, buf + length, &a1);
578 | free(buf);
579 | if (err) {
580 | return ERROR_SYNTAX;
581 | }
582 | *result = cons(make_sym("complement"), cons(a1, nil));
583 | return ERROR_OK;
584 | }
585 | *result = make_sym(buf);
586 | }
587 |
588 | free(buf);
589 | return ERROR_OK;
590 | }
591 |
592 | error read_list(const char *start, const char **end, atom *result)
593 | {
594 | atom p;
595 |
596 | *end = start;
597 | p = *result = nil;
598 |
599 | for (;;) {
600 | const char *token;
601 | atom item;
602 | error err;
603 |
604 | err = lex(*end, &token, end);
605 | if (err)
606 | return err;
607 |
608 | if (token[0] == ')') {
609 | return ERROR_OK;
610 | }
611 |
612 | if (!no(p) && token[0] == '.' && *end - token == 1) {
613 | /* Improper list */
614 | if (no(p)) return ERROR_SYNTAX;
615 |
616 | err = read_expr(*end, end, &item);
617 | if (err) return err;
618 |
619 | cdr(p) = item;
620 |
621 | /* Read the closing ')' */
622 | err = lex(*end, &token, end);
623 | if (!err && token[0] != ')') {
624 | err = ERROR_SYNTAX;
625 | }
626 | return err;
627 | }
628 |
629 | err = read_expr(token, end, &item);
630 | if (err)
631 | return err;
632 |
633 | if (no(p)) {
634 | /* First item */
635 | *result = cons(item, nil);
636 | p = *result;
637 | }
638 | else {
639 | cdr(p) = cons(item, nil);
640 | p = cdr(p);
641 | }
642 | }
643 | }
644 |
645 | /* [...] => (fn (_) (...)) */
646 | error read_bracket(const char *start, const char **end, atom *result)
647 | {
648 | atom p;
649 |
650 | *end = start;
651 | p = *result = nil;
652 |
653 | /* First item */
654 | *result = cons(sym_fn, nil);
655 | p = *result;
656 |
657 | cdr(p) = cons(cons(sym__, nil), nil);
658 | p = cdr(p);
659 |
660 | atom body = nil;
661 |
662 | for (;;) {
663 | const char *token;
664 | atom item;
665 | error err;
666 |
667 | err = lex(*end, &token, end);
668 | if (err) return err;
669 | if (token[0] == ']') {
670 | return ERROR_OK;
671 | }
672 |
673 | err = read_expr(token, end, &item);
674 | if (err) return err;
675 |
676 | if (no(body)) {
677 | body = cons(item, nil);
678 | cdr(p) = cons(body, nil);
679 | p = body;
680 | }
681 | else {
682 | cdr(p) = cons(item, nil);
683 | p = cdr(p);
684 | }
685 | }
686 | }
687 |
688 | error read_expr(const char *input, const char **end, atom *result)
689 | {
690 | const char *token;
691 | error err;
692 |
693 | err = lex(input, &token, end);
694 | if (err)
695 | return err;
696 |
697 | if (token[0] == '(') {
698 | return read_list(*end, end, result);
699 | }
700 | else if (token[0] == ')')
701 | return ERROR_SYNTAX;
702 | else if (token[0] == '[') {
703 | return read_bracket(*end, end, result);
704 | }
705 | else if (token[0] == ']')
706 | return ERROR_SYNTAX;
707 | else if (token[0] == '\'') {
708 | *result = cons(sym_quote, cons(nil, nil));
709 | return read_expr(*end, end, &car(cdr(*result)));
710 | }
711 | else if (token[0] == '`') {
712 | *result = cons(sym_quasiquote, cons(nil, nil));
713 | return read_expr(*end, end, &car(cdr(*result)));
714 | }
715 | else if (token[0] == ',') {
716 | *result = cons(
717 | token[1] == '@' ? sym_unquote_splicing : sym_unquote,
718 | cons(nil, nil));
719 | return read_expr(*end, end, &car(cdr(*result)));
720 | }
721 | else
722 | return parse_simple(token, *end, result);
723 | }
724 |
725 | #ifndef READLINE
726 | char *readline(char *prompt) {
727 | return readline_fp(prompt, stdin);
728 | }
729 | #endif /* READLINE */
730 |
731 | char *readline_fp(char *prompt, FILE *fp) {
732 | size_t size = 80;
733 | /* The size is extended by the input with the value of the provisional */
734 | char *str;
735 | int ch;
736 | size_t len = 0;
737 | printf("%s", prompt);
738 | str = malloc(sizeof(char)* size); /* size is start size */
739 | if (!str) return NULL;
740 | while (EOF != (ch = fgetc(fp)) && ch != '\n') {
741 | str[len++] = ch;
742 | if (len == size) {
743 | void *p = realloc(str, sizeof(char)*(size *= 2));
744 | if (!p) {
745 | free(str);
746 | return NULL;
747 | }
748 | str = p;
749 | }
750 | }
751 | if (ch == EOF && len == 0) {
752 | free(str);
753 | return NULL;
754 | }
755 | str[len++] = '\0';
756 |
757 | return realloc(str, sizeof(char)*len);
758 | }
759 |
760 | atom env_create(atom parent)
761 | {
762 | return cons(parent, make_table(4));
763 | }
764 |
765 | atom env_create_cap(atom parent, size_t capacity)
766 | {
767 | return cons(parent, make_table(capacity));
768 | }
769 |
770 | error env_get(atom env, char *symbol, atom *result)
771 | {
772 | while (1) {
773 | struct table *ptbl = cdr(env).value.table;
774 | struct table_entry *a = table_get_sym(ptbl, symbol);
775 | if (a) {
776 | *result = a->v;
777 | return ERROR_OK;
778 | }
779 | if (no(car(env))) {
780 | /* printf("%s: ", symbol); */
781 | return ERROR_UNBOUND;
782 | }
783 | env = car(env);
784 | }
785 | }
786 |
787 | error env_assign(atom env, char *symbol, atom value) {
788 | struct table *ptbl = cdr(env).value.table;
789 | table_set_sym(ptbl, symbol, value);
790 | return ERROR_OK;
791 | }
792 |
793 | error env_assign_eq(atom env, char *symbol, atom value) {
794 | while (1) {
795 | atom parent = car(env);
796 | struct table *ptbl = cdr(env).value.table;
797 | struct table_entry *a = table_get_sym(ptbl, symbol);
798 | if (a) {
799 | a->v = value;
800 | return ERROR_OK;
801 | }
802 | if (no(parent)) {
803 | return env_assign(env, symbol, value);
804 | }
805 | env = parent;
806 | }
807 | }
808 |
809 | int listp(atom expr)
810 | {
811 | atom *p = &expr;
812 | while (!no(*p)) {
813 | if (p->type != T_CONS)
814 | return 0;
815 | p = &cdr(*p);
816 | }
817 | return 1;
818 | }
819 |
820 | size_t len(atom xs) {
821 | atom *p = &xs;
822 | size_t ret = 0;
823 | while (!no(*p)) {
824 | if (p->type != T_CONS)
825 | return ret + 1;
826 | p = &cdr(*p);
827 | ret++;
828 | }
829 | return ret;
830 | }
831 |
832 | atom copy_list(atom list)
833 | {
834 | atom a, p;
835 |
836 | if (no(list))
837 | return nil;
838 |
839 | a = cons(car(list), nil);
840 | p = a;
841 | list = cdr(list);
842 |
843 | while (!no(list)) {
844 | cdr(p) = cons(car(list), nil);
845 | p = cdr(p);
846 | list = cdr(list);
847 | if (list.type != T_CONS) { /* improper list */
848 | p = list;
849 | break;
850 | }
851 | }
852 |
853 | return a;
854 | }
855 |
856 | error destructuring_bind(atom arg_name, atom val, int val_unspecified, atom env) {
857 | switch (arg_name.type) {
858 | case T_SYM:
859 | return env_assign(env, arg_name.value.symbol, val);
860 | case T_CONS:
861 | if (is(car(arg_name), sym_o)) { /* (o ARG [DEFAULT]) */
862 | if (val_unspecified) { /* missing argument */
863 | if (!no(cdr(cdr(arg_name)))) {
864 | error err = eval_expr(car(cdr(cdr(arg_name))), env, &val);
865 | if (err) return err;
866 | }
867 | }
868 | return env_assign(env, car(cdr(arg_name)).value.symbol, val);
869 | }
870 | else {
871 | if (val.type != T_CONS) {
872 | return ERROR_ARGS;
873 | }
874 | error err = destructuring_bind(car(arg_name), car(val), 0, env);
875 | if (err) return err;
876 | return destructuring_bind(cdr(arg_name), cdr(val), no(cdr(val)), env);
877 | }
878 | case T_NIL:
879 | if (no(val))
880 | return ERROR_OK;
881 | else
882 | return ERROR_ARGS;
883 | default:
884 | return ERROR_ARGS;
885 | }
886 | }
887 |
888 | error env_bind(atom env, atom arg_names, struct vector *vargs) {
889 | /* Bind the arguments */
890 | size_t i = 0;
891 | while (!no(arg_names)) {
892 | if (arg_names.type == T_SYM) {
893 | env_assign(env, arg_names.value.symbol, vector_to_atom(vargs, i));
894 | i = vargs->size;
895 | break;
896 | }
897 | atom arg_name = car(arg_names);
898 | atom val;
899 | int val_unspecified = 0;
900 | if (i < vargs->size) {
901 | val = vargs->data[i];
902 | }
903 | else {
904 | val = nil;
905 | val_unspecified = 1;
906 | }
907 | error err = destructuring_bind(arg_name, val, val_unspecified, env);
908 | if (err) {
909 | return err;
910 | }
911 | arg_names = cdr(arg_names);
912 | i++;
913 | }
914 | if (i < vargs->size) {
915 | return ERROR_ARGS;
916 | }
917 | return ERROR_OK;
918 | }
919 |
920 | error apply(atom fn, struct vector *vargs, atom *result)
921 | {
922 | if (fn.type == T_BUILTIN)
923 | return (*fn.value.builtin)(vargs, result);
924 | else if (fn.type == T_CLOSURE) {
925 | atom arg_names = car(cdr(fn));
926 | atom env = env_create(car(fn));
927 | atom body = cdr(cdr(fn));
928 |
929 | error err = env_bind(env, arg_names, vargs);
930 | if (err) {
931 | return err;
932 | }
933 |
934 | /* Evaluate the body */
935 | err = eval_expr(body, env, result);
936 | if (err) {
937 | return err;
938 | }
939 | return ERROR_OK;
940 | }
941 | else if (fn.type == T_CONTINUATION) {
942 | if (vargs->size != 1) return ERROR_ARGS;
943 | thrown = vargs->data[0];
944 | longjmp(*fn.value.jb, 1);
945 | }
946 | else if (fn.type == T_STRING) { /* implicit indexing for string */
947 | if (vargs->size != 1) return ERROR_ARGS;
948 | size_t index = (size_t)(vargs->data[0]).value.number;
949 | *result = make_char(fn.value.str->value[index]);
950 | return ERROR_OK;
951 | }
952 | else if (fn.type == T_CONS && listp(fn)) { /* implicit indexing for list */
953 | if (vargs->size != 1) return ERROR_ARGS;
954 | size_t index = (size_t)(vargs->data[0]).value.number;
955 | atom a = fn;
956 | size_t i;
957 | for (i = 0; i < index; i++) {
958 | a = cdr(a);
959 | if (no(a)) {
960 | *result = nil;
961 | return ERROR_OK;
962 | }
963 | }
964 | *result = car(a);
965 | return ERROR_OK;
966 | }
967 | else if (fn.type == T_TABLE) { /* implicit indexing for table */
968 | long len1 = vargs->size;
969 | if (len1 != 1 && len1 != 2) return ERROR_ARGS;
970 | struct table_entry *pair = table_get(fn.value.table, vargs->data[0]);
971 | if (pair) {
972 | *result = pair->v;
973 | }
974 | else {
975 | if (len1 == 2) /* default value is specified */
976 | *result = vargs->data[1];
977 | else
978 | *result = nil;
979 | }
980 | return ERROR_OK;
981 | }
982 | else {
983 | return ERROR_TYPE;
984 | }
985 | }
986 |
987 | error builtin_car(struct vector *vargs, atom *result)
988 | {
989 | if (vargs->size != 1)
990 | return ERROR_ARGS;
991 |
992 | atom a = vargs->data[0];
993 | if (no(a))
994 | *result = nil;
995 | else if (a.type != T_CONS)
996 | return ERROR_TYPE;
997 | else
998 | *result = car(a);
999 |
1000 | return ERROR_OK;
1001 | }
1002 |
1003 | error builtin_cdr(struct vector *vargs, atom *result)
1004 | {
1005 | if (vargs->size != 1)
1006 | return ERROR_ARGS;
1007 |
1008 | atom a = vargs->data[0];
1009 | if (no(a))
1010 | *result = nil;
1011 | else if (a.type != T_CONS)
1012 | return ERROR_TYPE;
1013 | else
1014 | *result = cdr(a);
1015 |
1016 | return ERROR_OK;
1017 | }
1018 |
1019 | error builtin_cons(struct vector *vargs, atom *result)
1020 | {
1021 | if (vargs->size != 2)
1022 | return ERROR_ARGS;
1023 |
1024 | *result = cons(vargs->data[0], vargs->data[1]);
1025 |
1026 | return ERROR_OK;
1027 | }
1028 |
1029 | /* appends two lists */
1030 | atom append(atom a, atom b) {
1031 | atom a1 = copy_list(a),
1032 | b1 = copy_list(b);
1033 | atom p = a1;
1034 | if (no(p)) return b1;
1035 | while (1) {
1036 | if (no(cdr(p))) {
1037 | cdr(p) = b1;
1038 | return a1;
1039 | }
1040 | p = cdr(p);
1041 | }
1042 | return nil;
1043 | }
1044 |
1045 | /*
1046 | + args
1047 | Addition. This operator also performs string and list concatenation.
1048 | */
1049 | error builtin_add(struct vector *vargs, atom *result)
1050 | {
1051 | if (vargs->size == 0) {
1052 | *result = make_number(0);
1053 | }
1054 | else {
1055 | if (vargs->data[0].type == T_NUM) {
1056 | double r = vargs->data[0].value.number;
1057 | size_t i;
1058 | for (i = 1; i < vargs->size; i++) {
1059 | if (vargs->data[i].type != T_NUM) return ERROR_TYPE;
1060 | r += vargs->data[i].value.number;
1061 | }
1062 | *result = make_number(r);
1063 | }
1064 | else if (vargs->data[0].type == T_STRING) {
1065 | struct string buf;
1066 | string_new(&buf);
1067 | size_t i;
1068 | for (i = 0; i < vargs->size; i++) {
1069 | char *s = to_string(vargs->data[i], 0);
1070 | string_cat(&buf, s);
1071 | free(s);
1072 | }
1073 | *result = make_string(buf.str);
1074 | }
1075 | else if (vargs->data[0].type == T_CONS || vargs->data[0].type == T_NIL) {
1076 | atom acc = nil;
1077 | size_t i;
1078 | for (i = 0; i < vargs->size; i++) {
1079 | acc = append(acc, vargs->data[i]);
1080 | }
1081 | *result = acc;
1082 | }
1083 | }
1084 | return ERROR_OK;
1085 | }
1086 |
1087 | error builtin_subtract(struct vector *vargs, atom *result)
1088 | {
1089 | if (vargs->size == 0) { /* 0 argument */
1090 | *result = make_number(0);
1091 | return ERROR_OK;
1092 | }
1093 | if (vargs->data[0].type != T_NUM) return ERROR_TYPE;
1094 | if (vargs->size == 1) { /* 1 argument */
1095 | *result = make_number(-vargs->data[0].value.number);
1096 | return ERROR_OK;
1097 | }
1098 | double r = vargs->data[0].value.number;
1099 | size_t i;
1100 | for (i = 1; i < vargs->size; i++) {
1101 | if (vargs->data[i].type != T_NUM) return ERROR_TYPE;
1102 | r -= vargs->data[i].value.number;
1103 | }
1104 | *result = make_number(r);
1105 | return ERROR_OK;
1106 | }
1107 |
1108 | error builtin_multiply(struct vector *vargs, atom *result)
1109 | {
1110 | double r = 1;
1111 | size_t i;
1112 | for (i = 0; i < vargs->size; i++) {
1113 | if (vargs->data[i].type != T_NUM) return ERROR_TYPE;
1114 | r *= vargs->data[i].value.number;
1115 | }
1116 | *result = make_number(r);
1117 | return ERROR_OK;
1118 | }
1119 |
1120 | error builtin_divide(struct vector *vargs, atom *result)
1121 | {
1122 | if (vargs->size == 0) { /* 0 argument */
1123 | *result = make_number(1);
1124 | return ERROR_OK;
1125 | }
1126 | if (vargs->data[0].type != T_NUM) return ERROR_TYPE;
1127 | if (vargs->size == 1) { /* 1 argument */
1128 | *result = make_number(1.0 / vargs->data[0].value.number);
1129 | return ERROR_OK;
1130 | }
1131 | double r = vargs->data[0].value.number;
1132 | size_t i;
1133 | for (i = 1; i < vargs->size; i++) {
1134 | if (vargs->data[i].type != T_NUM) return ERROR_TYPE;
1135 | r /= vargs->data[i].value.number;
1136 | }
1137 | *result = make_number(r);
1138 | return ERROR_OK;
1139 | }
1140 |
1141 | error builtin_less(struct vector *vargs, atom *result)
1142 | {
1143 | if (vargs->size <= 1) {
1144 | *result = sym_t;
1145 | return ERROR_OK;
1146 | }
1147 | size_t i;
1148 | switch (vargs->data[0].type) {
1149 | case T_NUM:
1150 | for (i = 0; i < vargs->size - 1; i++) {
1151 | if (vargs->data[i].value.number >= vargs->data[i + 1].value.number) {
1152 | *result = nil;
1153 | return ERROR_OK;
1154 | }
1155 | }
1156 | *result = sym_t;
1157 | return ERROR_OK;
1158 | case T_STRING:
1159 | for (i = 0; i < vargs->size - 1; i++) {
1160 | if (strcmp(vargs->data[i].value.str->value, vargs->data[i + 1].value.str->value) >= 0) {
1161 | *result = nil;
1162 | return ERROR_OK;
1163 | }
1164 | }
1165 | *result = sym_t;
1166 | return ERROR_OK;
1167 | default:
1168 | return ERROR_TYPE;
1169 | }
1170 | }
1171 |
1172 | error builtin_greater(struct vector *vargs, atom *result)
1173 | {
1174 | if (vargs->size <= 1) {
1175 | *result = sym_t;
1176 | return ERROR_OK;
1177 | }
1178 | size_t i;
1179 | switch (vargs->data[0].type) {
1180 | case T_NUM:
1181 | for (i = 0; i < vargs->size - 1; i++) {
1182 | if (vargs->data[i].value.number <= vargs->data[i + 1].value.number) {
1183 | *result = nil;
1184 | return ERROR_OK;
1185 | }
1186 | }
1187 | *result = sym_t;
1188 | return ERROR_OK;
1189 | case T_STRING:
1190 | for (i = 0; i < vargs->size - 1; i++) {
1191 | if (strcmp(vargs->data[i].value.str->value, vargs->data[i + 1].value.str->value) <= 0) {
1192 | *result = nil;
1193 | return ERROR_OK;
1194 | }
1195 | }
1196 | *result = sym_t;
1197 | return ERROR_OK;
1198 | default:
1199 | return ERROR_TYPE;
1200 | }
1201 | }
1202 |
1203 | error builtin_apply(struct vector *vargs, atom *result)
1204 | {
1205 | atom fn;
1206 |
1207 | if (vargs->size != 2)
1208 | return ERROR_ARGS;
1209 |
1210 | fn = vargs->data[0];
1211 | struct vector v;
1212 | atom_to_vector(vargs->data[1], &v);
1213 | error err = apply(fn, &v, result);
1214 | vector_free(&v);
1215 | return err;
1216 | }
1217 |
1218 | int is(atom a, atom b) {
1219 | if (a.type == b.type) {
1220 | switch (a.type) {
1221 | case T_NIL:
1222 | return 1;
1223 | case T_CONS:
1224 | case T_CLOSURE:
1225 | case T_MACRO:
1226 | return (a.value.pair == b.value.pair);
1227 | case T_SYM:
1228 | return (a.value.symbol == b.value.symbol);
1229 | case T_NUM:
1230 | return (a.value.number == b.value.number);
1231 | case T_BUILTIN:
1232 | return (a.value.builtin == b.value.builtin);
1233 | case T_STRING:
1234 | return strcmp(a.value.str->value, b.value.str->value) == 0;
1235 | case T_CHAR:
1236 | return (a.value.ch == b.value.ch);
1237 | case T_TABLE:
1238 | return a.value.table == b.value.table;
1239 | case T_INPUT:
1240 | case T_INPUT_PIPE:
1241 | case T_OUTPUT:
1242 | return a.value.fp == b.value.fp;
1243 | case T_CONTINUATION:
1244 | return a.value.jb == b.value.jb;
1245 | }
1246 | }
1247 | return 0;
1248 | }
1249 |
1250 | int iso(atom a, atom b) {
1251 | if (a.type == b.type) {
1252 | switch (a.type) {
1253 | case T_CONS:
1254 | case T_CLOSURE:
1255 | case T_MACRO:
1256 | return iso(a.value.pair->car, b.value.pair->car) && iso(a.value.pair->cdr, b.value.pair->cdr);
1257 | default:
1258 | return is(a, b);
1259 | }
1260 | }
1261 | return 0;
1262 | }
1263 |
1264 | error builtin_is(struct vector *vargs, atom *result)
1265 | {
1266 | atom a, b;
1267 | if (vargs->size <= 1) {
1268 | *result = sym_t;
1269 | return ERROR_OK;
1270 | }
1271 | size_t i;
1272 | for (i = 0; i < vargs->size - 1; i++) {
1273 | a = vargs->data[i];
1274 | b = vargs->data[i + 1];
1275 | if (!is(a, b)) {
1276 | *result = nil;
1277 | return ERROR_OK;
1278 | }
1279 | }
1280 | *result = sym_t;
1281 | return ERROR_OK;
1282 | }
1283 |
1284 | error builtin_scar(struct vector *vargs, atom *result) {
1285 | if (vargs->size != 2) return ERROR_ARGS;
1286 | atom place = vargs->data[0], value;
1287 | if (place.type != T_CONS) return ERROR_TYPE;
1288 | value = vargs->data[1];
1289 | place.value.pair->car = value;
1290 | *result = value;
1291 | return ERROR_OK;
1292 | }
1293 |
1294 | error builtin_scdr(struct vector *vargs, atom *result) {
1295 | if (vargs->size != 2) return ERROR_ARGS;
1296 | atom place = vargs->data[0], value;
1297 | if (place.type != T_CONS) return ERROR_TYPE;
1298 | value = vargs->data[1];
1299 | place.value.pair->cdr = value;
1300 | *result = value;
1301 | return ERROR_OK;
1302 | }
1303 |
1304 | error builtin_mod(struct vector *vargs, atom *result) {
1305 | if (vargs->size != 2) return ERROR_ARGS;
1306 | atom dividend = vargs->data[0];
1307 | atom divisor = vargs->data[1];
1308 | double r = fmod(dividend.value.number, divisor.value.number);
1309 | if (dividend.value.number * divisor.value.number < 0 && r != 0) r += divisor.value.number;
1310 | *result = make_number(r);
1311 | return ERROR_OK;
1312 | }
1313 |
1314 | error builtin_type(struct vector *vargs, atom *result) {
1315 | if (vargs->size != 1) return ERROR_ARGS;
1316 | atom x = vargs->data[0];
1317 | switch (x.type) {
1318 | case T_CONS: *result = sym_cons; break;
1319 | case T_SYM:
1320 | case T_NIL: *result = sym_sym; break;
1321 | case T_BUILTIN:
1322 | case T_CLOSURE:
1323 | case T_CONTINUATION:
1324 | *result = sym_fn; break;
1325 | case T_STRING: *result = sym_string; break;
1326 | case T_NUM: *result = sym_num; break;
1327 | case T_MACRO: *result = sym_mac; break;
1328 | case T_TABLE: *result = sym_table; break;
1329 | case T_CHAR: *result = sym_char; break;
1330 | case T_INPUT: *result = make_sym("input"); break;
1331 | case T_INPUT_PIPE: *result = make_sym("input-pipe"); break;
1332 | case T_OUTPUT: *result = make_sym("output"); break;
1333 | default: *result = nil; break; /* impossible */
1334 | }
1335 | return ERROR_OK;
1336 | }
1337 |
1338 | /* sref obj value index
1339 | obj: cons, string, table
1340 | */
1341 | error builtin_sref(struct vector *vargs, atom *result) {
1342 | atom index, obj, value;
1343 | size_t i;
1344 | if (vargs->size != 3) return ERROR_ARGS;
1345 | obj = vargs->data[0];
1346 | value = vargs->data[1];
1347 | index = vargs->data[2];
1348 | switch (obj.type) {
1349 | case T_CONS:
1350 | for (i=0; i<(size_t)index.value.number; i++) {
1351 | obj = cdr(obj);
1352 | }
1353 | car(obj) = value;
1354 | *result = value;
1355 | return ERROR_OK;
1356 | case T_STRING:
1357 | obj.value.str->value[(long)index.value.number] = (char)value.value.ch;
1358 | *result = value;
1359 | return ERROR_OK;
1360 | case T_TABLE:
1361 | table_set(obj.value.table, index, value);
1362 | *result = value;
1363 | return ERROR_OK;
1364 | default:
1365 | return ERROR_TYPE;
1366 | }
1367 | }
1368 |
1369 | /* disp [arg [output-port]] */
1370 | error builtin_disp(struct vector *vargs, atom *result) {
1371 | long l = vargs->size;
1372 | FILE *fp;
1373 | switch (l) {
1374 | case 0:
1375 | *result = nil;
1376 | return ERROR_OK;
1377 | case 1:
1378 | fp = stdout;
1379 | break;
1380 | case 2:
1381 | fp = vargs->data[1].value.fp;
1382 | break;
1383 | default:
1384 | return ERROR_ARGS;
1385 | }
1386 | char *s = to_string(vargs->data[0], 0);
1387 | fprintf(fp, "%s", s);
1388 | free(s);
1389 | *result = nil;
1390 | return ERROR_OK;
1391 | }
1392 |
1393 | error builtin_writeb(struct vector *vargs, atom *result) {
1394 | long l = vargs->size;
1395 | FILE *fp;
1396 | switch (l) {
1397 | case 0: return ERROR_ARGS;
1398 | case 1:
1399 | fp = stdout;
1400 | break;
1401 | case 2:
1402 | fp = vargs->data[1].value.fp;
1403 | break;
1404 | default: return ERROR_ARGS;
1405 | }
1406 | fputc((int)vargs->data[0].value.number, fp);
1407 | *result = nil;
1408 | return ERROR_OK;
1409 | }
1410 |
1411 | error builtin_expt(struct vector *vargs, atom *result) {
1412 | atom a, b;
1413 | if (vargs->size != 2) return ERROR_ARGS;
1414 | a = vargs->data[0];
1415 | b = vargs->data[1];
1416 | *result = make_number(pow(a.value.number, b.value.number));
1417 | return ERROR_OK;
1418 | }
1419 |
1420 | error builtin_log(struct vector *vargs, atom *result) {
1421 | atom a;
1422 | if (vargs->size != 1) return ERROR_ARGS;
1423 | a = vargs->data[0];
1424 | *result = make_number(log(a.value.number));
1425 | return ERROR_OK;
1426 | }
1427 |
1428 | error builtin_sqrt(struct vector *vargs, atom *result) {
1429 | atom a;
1430 | if (vargs->size != 1) return ERROR_ARGS;
1431 | a = vargs->data[0];
1432 | *result = make_number(sqrt(a.value.number));
1433 | return ERROR_OK;
1434 | }
1435 |
1436 | error builtin_readline(struct vector *vargs, atom *result) {
1437 | long l = vargs->size;
1438 | char *str;
1439 | if (l == 0) {
1440 | str = readline("");
1441 | }
1442 | else if (l == 1) {
1443 | if (vargs->data[0].type != T_INPUT && vargs->data[0].type != T_INPUT_PIPE) return ERROR_TYPE;
1444 | str = readline_fp("", vargs->data[0].value.fp);
1445 | }
1446 | else {
1447 | return ERROR_ARGS;
1448 | }
1449 | if (str == NULL) *result = nil; else *result = make_string(str);
1450 | return ERROR_OK;
1451 | }
1452 |
1453 | error builtin_quit(struct vector *vargs, atom *result) {
1454 | if (vargs->size != 0) return ERROR_ARGS;
1455 | exit(0);
1456 | }
1457 |
1458 | double rand_double() {
1459 | return (double)rand() / ((double)RAND_MAX + 1.0);
1460 | }
1461 |
1462 | error builtin_rand(struct vector *vargs, atom *result) {
1463 | long alen = vargs->size;
1464 | if (alen == 0) *result = make_number(rand_double());
1465 | else if (alen == 1) *result = make_number(floor(rand_double() * vargs->data[0].value.number));
1466 | else return ERROR_ARGS;
1467 | return ERROR_OK;
1468 | }
1469 |
1470 | error read_fp(FILE *fp, atom *result) {
1471 | char *s = readline_fp("", fp);
1472 | if (s == NULL) return ERROR_FILE;
1473 | const char *buf = s;
1474 | error err = read_expr(buf, &buf, result);
1475 |
1476 | /* bring back remaining expressions so that "(read) (read)" works */
1477 | if (buf) {
1478 | if (*buf) ungetc('\n', fp);
1479 | const char *b0 = buf;
1480 | for (; *buf; buf++) {
1481 | }
1482 | for (buf--; buf >= b0; buf--) {
1483 | ungetc(*buf, fp);
1484 | }
1485 | }
1486 | free(s);
1487 | return err;
1488 | }
1489 |
1490 | /* read [input-source [eof]]
1491 | Reads a S-expression from the input-source, which can be either a string or an input-port. If the end of file is reached, nil is returned or the specified eof value. */
1492 | error builtin_read(struct vector *vargs, atom *result) {
1493 | size_t alen = vargs->size;
1494 | error err;
1495 | if (alen == 0) {
1496 | err = read_fp(stdin, result);
1497 | }
1498 | else if (alen <= 2) {
1499 | atom src = vargs->data[0];
1500 | if (src.type == T_STRING) {
1501 | char *s = vargs->data[0].value.str->value;
1502 | const char *buf = s;
1503 | err = read_expr(buf, &buf, result);
1504 | }
1505 | else if (src.type == T_INPUT || src.type == T_INPUT_PIPE) {
1506 | err = read_fp(src.value.fp, result);
1507 | }
1508 | else {
1509 | return ERROR_TYPE;
1510 | }
1511 | }
1512 | else {
1513 | return ERROR_ARGS;
1514 | }
1515 |
1516 | if (err == ERROR_FILE) {
1517 | atom eof = nil; /* default value when EOF */
1518 | if (alen == 2) { /* specified return value when EOF */
1519 | eof = vargs->data[1];
1520 | }
1521 |
1522 | *result = eof;
1523 | return ERROR_OK;
1524 | }
1525 | else {
1526 | return err;
1527 | }
1528 | }
1529 |
1530 | error builtin_macex(struct vector *vargs, atom *result) {
1531 | long alen = vargs->size;
1532 | if (alen == 1) {
1533 | error err = macex(vargs->data[0], result);
1534 | return err;
1535 | }
1536 | else return ERROR_ARGS;
1537 | return ERROR_OK;
1538 | }
1539 |
1540 | /*
1541 | * From Arc tutorial:
1542 | * Every argument will appear as it would look if printed out by pr,
1543 | * except nil, which is ignored.
1544 | */
1545 | error builtin_string(struct vector *vargs, atom *result) {
1546 | struct string s;
1547 | string_new(&s);
1548 | size_t i;
1549 | for (i = 0; i < vargs->size; i++) {
1550 | if (!no(vargs->data[i])) {
1551 | char *a = to_string(vargs->data[i], 0);
1552 | string_cat(&s, a);
1553 | free(a);
1554 | }
1555 | }
1556 | *result = make_string(s.str);
1557 | return ERROR_OK;
1558 | }
1559 |
1560 | error builtin_sym(struct vector *vargs, atom *result) {
1561 | long alen = vargs->size;
1562 | if (alen == 1) {
1563 | char *s = to_string(vargs->data[0], 0);
1564 | *result = make_sym(s);
1565 | free(s);
1566 | return ERROR_OK;
1567 | }
1568 | else return ERROR_ARGS;
1569 | }
1570 |
1571 | error builtin_system(struct vector *vargs, atom *result) {
1572 | long alen = vargs->size;
1573 | if (alen == 1) {
1574 | atom a = vargs->data[0];
1575 | if (a.type != T_STRING) return ERROR_TYPE;
1576 | *result = make_number(system(vargs->data[0].value.str->value));
1577 | return ERROR_OK;
1578 | }
1579 | else return ERROR_ARGS;
1580 | }
1581 |
1582 | error builtin_eval(struct vector *vargs, atom *result) {
1583 | if (vargs->size == 1) return macex_eval(vargs->data[0], result);
1584 | else return ERROR_ARGS;
1585 | }
1586 |
1587 | error builtin_load(struct vector *vargs, atom *result) {
1588 | if (vargs->size == 1) {
1589 | atom a = vargs->data[0];
1590 | if (a.type != T_STRING) return ERROR_TYPE;
1591 | *result = nil;
1592 | return arc_load_file(a.value.str->value);
1593 | }
1594 | else return ERROR_ARGS;
1595 | }
1596 |
1597 | error builtin_int(struct vector *vargs, atom *result) {
1598 | if (vargs->size == 1) {
1599 | atom a = vargs->data[0];
1600 | switch (a.type) {
1601 | case T_STRING:
1602 | *result = make_number(atol(a.value.str->value));
1603 | break;
1604 | case T_SYM:
1605 | *result = make_number(atol(a.value.symbol));
1606 | break;
1607 | case T_NUM:
1608 | *result = make_number((long)a.value.number);
1609 | break;
1610 | case T_CHAR:
1611 | *result = make_number(a.value.ch);
1612 | break;
1613 | default:
1614 | return ERROR_TYPE;
1615 | }
1616 | return ERROR_OK;
1617 | }
1618 | else return ERROR_ARGS;
1619 | }
1620 |
1621 | error builtin_trunc(struct vector *vargs, atom *result) {
1622 | if (vargs->size == 1) {
1623 | atom a = vargs->data[0];
1624 | if (a.type != T_NUM) return ERROR_TYPE;
1625 | *result = make_number(trunc(a.value.number));
1626 | return ERROR_OK;
1627 | }
1628 | else return ERROR_ARGS;
1629 | }
1630 |
1631 | error builtin_sin(struct vector *vargs, atom *result) {
1632 | if (vargs->size == 1) {
1633 | atom a = vargs->data[0];
1634 | if (a.type != T_NUM) return ERROR_TYPE;
1635 | *result = make_number(sin(a.value.number));
1636 | return ERROR_OK;
1637 | }
1638 | else return ERROR_ARGS;
1639 | }
1640 |
1641 | error builtin_cos(struct vector *vargs, atom *result) {
1642 | if (vargs->size == 1) {
1643 | atom a = vargs->data[0];
1644 | if (a.type != T_NUM) return ERROR_TYPE;
1645 | *result = make_number(cos(a.value.number));
1646 | return ERROR_OK;
1647 | }
1648 | else return ERROR_ARGS;
1649 | }
1650 |
1651 | error builtin_tan(struct vector *vargs, atom *result) {
1652 | if (vargs->size == 1) {
1653 | atom a = vargs->data[0];
1654 | if (a.type != T_NUM) return ERROR_TYPE;
1655 | *result = make_number(tan(a.value.number));
1656 | return ERROR_OK;
1657 | }
1658 | else return ERROR_ARGS;
1659 | }
1660 |
1661 | error builtin_bound(struct vector *vargs, atom *result) {
1662 | if (vargs->size == 1) {
1663 | atom a = vargs->data[0];
1664 | if (a.type != T_SYM) return ERROR_TYPE;
1665 | error err = env_get(env, a.value.symbol, result);
1666 | *result = (err ? nil : sym_t);
1667 | return ERROR_OK;
1668 | }
1669 | else return ERROR_ARGS;
1670 | }
1671 |
1672 | error builtin_infile(struct vector *vargs, atom *result) {
1673 | char* mode = "rb";
1674 | if (vargs->size == 2) {
1675 | if (vargs->data[1].type != T_SYM) return ERROR_TYPE;
1676 | if (strcmp(vargs->data[1].value.symbol, "text") == 0) {
1677 | mode = "r";
1678 | }
1679 | } else if (vargs->size == 1) {
1680 | } else return ERROR_ARGS;
1681 | atom a = vargs->data[0];
1682 | if (a.type != T_STRING) return ERROR_TYPE;
1683 | FILE* fp = fopen(a.value.str->value, mode);
1684 | if (!fp) return ERROR_FILE;
1685 | *result = make_input(fp);
1686 | return ERROR_OK;
1687 | }
1688 |
1689 | /* outfile filename ['append]
1690 | Opens the specified path for writing. By default, the file is truncated if it already exists. Returns an output - port. Arc supports only 'text mode for outfile. */
1691 | error builtin_outfile(struct vector *vargs, atom *result) {
1692 | char* mode = "w";
1693 | if (vargs->size == 2) {
1694 | mode = "a";
1695 | } else if (vargs->size == 1) {
1696 | } else return ERROR_ARGS;
1697 | atom a = vargs->data[0];
1698 | if (a.type != T_STRING) return ERROR_TYPE;
1699 | FILE* fp = fopen(a.value.str->value, mode);
1700 | *result = make_output(fp);
1701 | return ERROR_OK;
1702 | }
1703 |
1704 | /* close port ... */
1705 | error builtin_close(struct vector *vargs, atom *result) {
1706 | if (vargs->size >= 1) {
1707 | size_t i;
1708 | for (i = 0; i < vargs->size; i++) {
1709 | atom a = vargs->data[i];
1710 | if (a.type != T_INPUT && a.type != T_INPUT_PIPE && a.type != T_OUTPUT) return ERROR_TYPE;
1711 | if (a.type == T_INPUT_PIPE)
1712 | pclose(a.value.fp);
1713 | else
1714 | fclose(a.value.fp);
1715 | }
1716 | *result = nil;
1717 | return ERROR_OK;
1718 | }
1719 | else return ERROR_ARGS;
1720 | }
1721 |
1722 | error builtin_readb(struct vector *vargs, atom *result) {
1723 | long l = vargs->size;
1724 | FILE *fp;
1725 | switch (l) {
1726 | case 0:
1727 | fp = stdin;
1728 | break;
1729 | case 1:
1730 | fp = vargs->data[0].value.fp;
1731 | break;
1732 | default:
1733 | return ERROR_ARGS;
1734 | }
1735 | *result = make_number(fgetc(fp));
1736 | return ERROR_OK;
1737 | }
1738 |
1739 | /* sread input-port eof */
1740 | error builtin_sread(struct vector *vargs, atom *result) {
1741 | if (vargs->size != 2) return ERROR_ARGS;
1742 | FILE *fp = vargs->data[0].value.fp;
1743 | atom eof = vargs->data[1];
1744 | error err;
1745 | if (feof(fp)) {
1746 | *result = eof;
1747 | return ERROR_OK;
1748 | }
1749 | char *s = slurp_fp(fp);
1750 | const char *p = s;
1751 | err = read_expr(p, &p, result);
1752 | return err;
1753 | }
1754 |
1755 | /* write [arg [output-port]] */
1756 | error builtin_write(struct vector *vargs, atom *result) {
1757 | long l = vargs->size;
1758 | FILE *fp;
1759 | switch (l) {
1760 | case 0:
1761 | *result = nil;
1762 | return ERROR_OK;
1763 | case 1:
1764 | fp = stdout;
1765 | break;
1766 | case 2:
1767 | fp = vargs->data[1].value.fp;
1768 | break;
1769 | default:
1770 | return ERROR_ARGS;
1771 | }
1772 | atom a = vargs->data[0];
1773 | char *s = to_string(a, 1);
1774 | fprintf(fp, "%s", s);
1775 | free(s);
1776 | *result = nil;
1777 | return ERROR_OK;
1778 | }
1779 |
1780 | /* newstring length [char] */
1781 | error builtin_newstring(struct vector *vargs, atom *result) {
1782 | long arg_len = vargs->size;
1783 | long length = (long)vargs->data[0].value.number;
1784 | char c = 0;
1785 | char *s;
1786 | switch (arg_len) {
1787 | case 1: break;
1788 | case 2:
1789 | c = vargs->data[1].value.ch;
1790 | break;
1791 | default:
1792 | return ERROR_ARGS;
1793 | }
1794 | s = malloc((length + 1) * sizeof(char));
1795 | int i;
1796 | for (i = 0; i < length; i++)
1797 | s[i] = c;
1798 | s[length] = 0; /* end of string */
1799 | *result = make_string(s);
1800 | return ERROR_OK;
1801 | }
1802 |
1803 | error builtin_table(struct vector *vargs, atom *result) {
1804 | long arg_len = vargs->size;
1805 | if (arg_len != 0) return ERROR_ARGS;
1806 | *result = make_table(8);
1807 | return ERROR_OK;
1808 | }
1809 |
1810 | /* maptable proc table */
1811 | error builtin_maptable(struct vector *vargs, atom *result) {
1812 | long arg_len = vargs->size;
1813 | if (arg_len != 2) return ERROR_ARGS;
1814 | atom proc = vargs->data[0];
1815 | atom tbl = vargs->data[1];
1816 | if (tbl.type != T_TABLE) return ERROR_TYPE;
1817 | size_t i;
1818 | for (i = 0; i < tbl.value.table->capacity; i++) {
1819 | struct table_entry *p = tbl.value.table->data[i];
1820 | while (p) {
1821 | vector_clear(vargs);
1822 | vector_add(vargs, p->k);
1823 | vector_add(vargs, p->v);
1824 | error err = apply(proc, vargs, result);
1825 | if (err) return err;
1826 | p = p->next;
1827 | }
1828 | }
1829 | *result = tbl;
1830 | return ERROR_OK;
1831 | }
1832 |
1833 | /* coerce obj type */
1834 | /*
1835 | Coerces object to a new type.
1836 | A char can be coerced to int, num, string, or sym.
1837 | A number can be coerced to int, char, or string.
1838 | A string can be coerced to sym, cons (char list), num, or int.
1839 | A list of characters can be coerced to a string.
1840 | A symbol can be coerced to a string.
1841 | */
1842 | error builtin_coerce(struct vector *vargs, atom *result) {
1843 | atom obj, type;
1844 | if (vargs->size != 2) return ERROR_ARGS;
1845 | obj = vargs->data[0];
1846 | type = vargs->data[1];
1847 | switch (obj.type) {
1848 | case T_CHAR:
1849 | if (is(type, sym_int) || is(type, sym_num)) *result = make_number(obj.value.ch);
1850 | else if (is(type, sym_string)) {
1851 | char *buf = malloc(2);
1852 | buf[0] = obj.value.ch;
1853 | buf[1] = '\0';
1854 | *result = make_string(buf);
1855 | }
1856 | else if (is(type, sym_sym)) {
1857 | char buf[2];
1858 | buf[0] = obj.value.ch;
1859 | buf[1] = '\0';
1860 | *result = make_sym(buf);
1861 | }
1862 | else if (is(type, sym_char))
1863 | *result = obj;
1864 | else
1865 | return ERROR_TYPE;
1866 | break;
1867 | case T_NUM:
1868 | if (is(type, sym_int)) *result = make_number(floor(obj.value.number));
1869 | else if (is(type, sym_char)) *result = make_char((char)obj.value.number);
1870 | else if (is(type, sym_string)) {
1871 | *result = make_string(to_string(obj, 0));
1872 | }
1873 | else if (is(type, sym_num))
1874 | *result = obj;
1875 | else
1876 | return ERROR_TYPE;
1877 | break;
1878 | case T_STRING:
1879 | if (is(type, sym_sym)) *result = make_sym(obj.value.str->value);
1880 | else if (is(type, sym_cons)) {
1881 | *result = nil;
1882 | int i;
1883 | for (i = strlen(obj.value.str->value) - 1; i >= 0; i--) {
1884 | *result = cons(make_char(obj.value.str->value[i]), *result);
1885 | }
1886 | }
1887 | else if (is(type, sym_num)) *result = make_number(atof(obj.value.str->value));
1888 | else if (is(type, sym_int)) *result = make_number(atoi(obj.value.str->value));
1889 | else if (is(type, sym_string))
1890 | *result = obj;
1891 | else
1892 | return ERROR_TYPE;
1893 | break;
1894 | case T_CONS:
1895 | if (is(type, sym_string)) {
1896 | struct string s;
1897 | string_new(&s);
1898 | atom p;
1899 | for (p = obj; !no(p); p = cdr(p)) {
1900 | atom x;
1901 | struct vector v; /* (car(p) string) */
1902 | vector_new(&v);
1903 | vector_add(&v, car(p));
1904 | vector_add(&v, sym_string);
1905 | error err = builtin_coerce(&v, &x);
1906 | vector_free(&v);
1907 | if (err) return err;
1908 | string_cat(&s, x.value.str->value);
1909 | }
1910 | *result = make_string(s.str);
1911 | }
1912 | else if (is(type, sym_cons))
1913 | *result = obj;
1914 | else
1915 | return ERROR_TYPE;
1916 | break;
1917 | case T_SYM:
1918 | if (is(type, sym_string)) {
1919 | *result = make_string(strdup(obj.value.symbol));
1920 | }
1921 | else if (is(type, sym_sym))
1922 | *result = obj;
1923 | else
1924 | return ERROR_TYPE;
1925 | break;
1926 | default:
1927 | *result = obj;
1928 | }
1929 | return ERROR_OK;
1930 | }
1931 |
1932 | error builtin_flushout(struct vector *vargs, atom *result) {
1933 | if (vargs->size != 0) return ERROR_ARGS;
1934 | fflush(stdout);
1935 | *result = sym_t;
1936 | return ERROR_OK;
1937 | }
1938 |
1939 | error builtin_err(struct vector *vargs, atom *result) {
1940 | if (vargs->size == 0) return ERROR_ARGS;
1941 | err_expr = nil;
1942 | size_t i;
1943 | for (i = 0; i < vargs->size; i++) {
1944 | char *s = to_string(vargs->data[i], 0);
1945 | puts(s);
1946 | free(s);
1947 | }
1948 | return ERROR_USER;
1949 | }
1950 |
1951 | error builtin_len(struct vector *vargs, atom *result) {
1952 | if (vargs->size != 1) return ERROR_ARGS;
1953 | atom a = vargs->data[0];
1954 | if (a.type == T_STRING) {
1955 | *result = make_number(strlen(a.value.str->value));
1956 | }
1957 | else if (a.type == T_TABLE) {
1958 | *result = make_number(a.value.table->size);
1959 | }
1960 | else {
1961 | *result = make_number(len(a));
1962 | }
1963 | return ERROR_OK;
1964 | }
1965 |
1966 | atom make_continuation(jmp_buf *jb) {
1967 | atom a;
1968 | a.type = T_CONTINUATION;
1969 | a.value.jb = jb;
1970 | return a;
1971 | }
1972 |
1973 | error builtin_ccc(struct vector *vargs, atom *result) {
1974 | if (vargs->size != 1) return ERROR_ARGS;
1975 | atom a = vargs->data[0];
1976 | if (a.type != T_BUILTIN && a.type != T_CLOSURE) return ERROR_TYPE;
1977 | jmp_buf jb;
1978 | int val = setjmp(jb);
1979 | if (val) {
1980 | *result = thrown;
1981 | return ERROR_OK;
1982 | }
1983 | vector_clear(vargs);
1984 | vector_add(vargs, make_continuation(&jb));
1985 | return apply(a, vargs, result);
1986 | }
1987 |
1988 | /* pipe-from command
1989 | * Executes command in the underlying OS. Then opens an input-port to the results.
1990 | */
1991 | error builtin_pipe_from(struct vector* vargs, atom* result) {
1992 | if (vargs->size != 1) return ERROR_ARGS;
1993 | atom a = vargs->data[0];
1994 | if (a.type != T_STRING) return ERROR_TYPE;
1995 | FILE *fp = popen(vargs->data[0].value.str->value, "r");
1996 | if (fp == NULL) return ERROR_FILE;
1997 | *result = make_input_pipe(fp);
1998 | return ERROR_OK;
1999 | }
2000 |
2001 | /* end builtin */
2002 |
2003 | void string_new(struct string *dst) {
2004 | dst->len = 0;
2005 | dst->cap = 2;
2006 | dst->str = malloc(dst->cap * sizeof(char));
2007 | dst->str[0] = 0;
2008 | }
2009 |
2010 | void string_cat(struct string* dst, char* src) {
2011 | size_t len = dst->len + strlen(src);
2012 |
2013 | if (len + 1 > dst->cap) {
2014 | while (len + 1 > dst->cap) {
2015 | dst->cap *= 2;
2016 | }
2017 | dst->str = realloc(dst->str, dst->cap * sizeof(char));
2018 | }
2019 |
2020 | strcpy(dst->str + dst->len, src);
2021 | dst->len = len;
2022 | }
2023 |
2024 | char *to_string(atom a, int write) {
2025 | struct string s;
2026 | string_new(&s);
2027 |
2028 | char buf[80];
2029 | switch (a.type) {
2030 | case T_NIL:
2031 | string_cat(&s, "nil");
2032 | break;
2033 | case T_CONS:
2034 | if (listp(a) && len(a) == 2 && is(car(a), sym_quote)) {
2035 | string_cat(&s, "'");
2036 | char *s2 = to_string(car(cdr(a)), write);
2037 | string_cat(&s, s2);
2038 | free(s2);
2039 | }
2040 | else if (listp(a) && len(a) == 2 && is(car(a), sym_quasiquote)) {
2041 | string_cat(&s, "`");
2042 | char *s2 = to_string(car(cdr(a)), write);
2043 | string_cat(&s, s2);
2044 | free(s2);
2045 | }
2046 | else if (listp(a) && len(a) == 2 && is(car(a), sym_unquote)) {
2047 | string_cat(&s, ",");
2048 | char *s2 = to_string(car(cdr(a)), write);
2049 | string_cat(&s, s2);
2050 | free(s2);
2051 | }
2052 | else if (listp(a) && len(a) == 2 && is(car(a), sym_unquote_splicing)) {
2053 | string_cat(&s, ",@");
2054 | char *s2 = to_string(car(cdr(a)), write);
2055 | string_cat(&s, s2);
2056 | free(s2);
2057 | }
2058 | else {
2059 | string_cat(&s, "(");
2060 | char *s2 = to_string(car(a), write);
2061 | string_cat(&s, s2);
2062 | free(s2);
2063 | a = cdr(a);
2064 | while (!no(a)) {
2065 | if (a.type == T_CONS) {
2066 | string_cat(&s, " ");
2067 | s2 = to_string(car(a), write);
2068 | string_cat(&s, s2);
2069 | free(s2);
2070 | a = cdr(a);
2071 | }
2072 | else {
2073 | string_cat(&s, " . ");
2074 | s2 = to_string(a, write);
2075 | string_cat(&s, s2);
2076 | free(s2);
2077 | break;
2078 | }
2079 | }
2080 | string_cat(&s, ")");
2081 | }
2082 | break;
2083 | case T_SYM:
2084 | string_cat(&s, a.value.symbol);
2085 | break;
2086 | case T_STRING:
2087 | if (write) string_cat(&s, "\"");
2088 | string_cat(&s, a.value.str->value);
2089 | if (write) string_cat(&s, "\"");
2090 | break;
2091 | case T_NUM:
2092 | sprintf(buf, "%.16g", a.value.number);
2093 | string_cat(&s, buf);
2094 | break;
2095 | case T_BUILTIN:
2096 | sprintf(buf, "#", a.value.builtin);
2097 | string_cat(&s, buf);
2098 | break;
2099 | case T_CLOSURE:
2100 | {
2101 | atom a2 = cons(sym_fn, cdr(a));
2102 | char *s2 = to_string(a2, write);
2103 | string_cat(&s, s2);
2104 | free(s2);
2105 | break;
2106 | }
2107 | case T_MACRO:
2108 | string_cat(&s, "#");
2113 | break;
2114 | case T_INPUT:
2115 | string_cat(&s, "#");
2116 | break;
2117 | case T_INPUT_PIPE:
2118 | string_cat(&s, "#");
2119 | break;
2120 | case T_OUTPUT:
2121 | string_cat(&s, "#