├── static
├── robots.txt
├── s.gif
├── arc.png
├── grayarrow.gif
└── graydown.gif
├── copyright
├── libs.arc
├── as.scm
├── README.md
├── how-to-run-news
├── brackets.scm
├── code.arc
├── blog.arc
├── pprint.arc
├── prompt.arc
├── strings.arc
├── html.arc
├── srv.arc
├── app.arc
├── ac.scm
└── arc.arc
/static/robots.txt:
--------------------------------------------------------------------------------
1 |
--------------------------------------------------------------------------------
/static/s.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wting/hackernews/HEAD/static/s.gif
--------------------------------------------------------------------------------
/static/arc.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wting/hackernews/HEAD/static/arc.png
--------------------------------------------------------------------------------
/static/grayarrow.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wting/hackernews/HEAD/static/grayarrow.gif
--------------------------------------------------------------------------------
/static/graydown.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/wting/hackernews/HEAD/static/graydown.gif
--------------------------------------------------------------------------------
/copyright:
--------------------------------------------------------------------------------
1 | This software is copyright (c) Paul Graham and Robert Morris. Permission
2 | to use it is granted under the Perl Foundations' Artistic License 2.0.
3 |
--------------------------------------------------------------------------------
/libs.arc:
--------------------------------------------------------------------------------
1 | (map load '("strings.arc"
2 | "pprint.arc"
3 | "code.arc"
4 | "html.arc"
5 | "srv.arc"
6 | "app.arc"
7 | "prompt.arc"))
8 |
--------------------------------------------------------------------------------
/as.scm:
--------------------------------------------------------------------------------
1 | ; mzscheme -m -f as.scm
2 | ; (tl)
3 | ; (asv)
4 | ; http://localhost:8080
5 |
6 | (require mzscheme) ; promise we won't redefine mzscheme bindings
7 |
8 | (require "ac.scm")
9 | (require "brackets.scm")
10 | (use-bracket-readtable)
11 |
12 | (aload "arc.arc")
13 | (aload "libs.arc")
14 |
15 | (tl)
16 |
17 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | ## Note
2 |
3 | - Instructions copied from the original download [site][arc-ins].
4 | - The files from the tarball in step 2 have been copied into this repository.
5 |
6 | ## Original Instructions
7 |
8 | 1. Install version 372 of MzScheme. (Don't use the latest version. Versions after 372 made lists immutable.)
9 | 2. Get http://ycombinator.com/arc/arc3.tar and untar it.
10 | 3. Type mzscheme -m -f as.scm and you should get an Arc prompt.
11 | 4. If you ^C an Arc program, you'll get the Scheme REPL. Use (tl) to get back to the Arc REPL.
12 | 5. If you have questions or suggestions, post them on the [forum][arc-forum].
13 |
14 | [arc-ins]: http://arclanguage.org/install
15 | [arc-forum]: http://arclanguage.org/forum
16 |
--------------------------------------------------------------------------------
/how-to-run-news:
--------------------------------------------------------------------------------
1 | To run News:
2 |
3 | tar xvf arc3.tar
4 |
5 | cd arc3
6 |
7 | mkdir arc
8 |
9 | echo "myname" > arc/admins
10 |
11 | mzscheme -f as.scm
12 |
13 | at the arc prompt:
14 |
15 | (load "news.arc")
16 |
17 | (nsv)
18 |
19 | go to http://localhost:8080
20 |
21 | click on login, and create an account called myname
22 |
23 | you should now be logged in as an admin
24 |
25 | manually give at least 10 karma to your initial set of users
26 |
27 | don't worry about "user break" messages when restarting News
28 |
29 |
30 |
31 | To customize News:
32 |
33 | change the variables at the top of news.arc
34 |
35 |
36 |
37 | To improve performance:
38 |
39 | (= static-max-age* 7200) ; browsers can cache static files for 7200 sec
40 |
41 | (declare 'direct-calls t) ; you promise not to redefine fns as tables
42 |
43 | (declare 'explicit-flush t) ; you take responsibility for flushing output
44 | ; (all existing news code already does)
45 |
--------------------------------------------------------------------------------
/brackets.scm:
--------------------------------------------------------------------------------
1 | ; From Eli Barzilay, eli@barzilay.org
2 |
3 | ;> (require "brackets.scm")
4 | ;> (use-bracket-readtable)
5 | ;> ([+ _ 1] 10)
6 | ;11
7 |
8 | (module brackets mzscheme
9 |
10 | ; main reader function for []s
11 | ; recursive read starts with default readtable's [ parser,
12 | ; but nested reads still use the curent readtable:
13 |
14 | (define (read-square-brackets ch port src line col pos)
15 | `(fn (_)
16 | ,(read/recursive port #\[ #f)))
17 |
18 | ; a readtable that is just like the builtin except for []s
19 |
20 | (define bracket-readtable
21 | (make-readtable #f #\[ 'terminating-macro read-square-brackets))
22 |
23 | ; call this to set the global readtable
24 |
25 | (provide use-bracket-readtable)
26 |
27 | (define (use-bracket-readtable)
28 | (current-readtable bracket-readtable))
29 |
30 | ; these two implement the required functionality for #reader
31 |
32 | ;(define (*read inp)
33 | ; (parameterize ((current-readtable bracket-readtable))
34 | ; (read inp)))
35 |
36 | (define (*read . args)
37 | (parameterize ((current-readtable bracket-readtable))
38 | (read (if (null? args) (current-input-port) (car args)))))
39 |
40 | (define (*read-syntax src port)
41 | (parameterize ((current-readtable bracket-readtable))
42 | (read-syntax src port)))
43 |
44 | ; and the need to be provided as `read' and `read-syntax'
45 |
46 | (provide (rename *read read) (rename *read-syntax read-syntax))
47 |
48 | )
49 |
--------------------------------------------------------------------------------
/code.arc:
--------------------------------------------------------------------------------
1 | ; Code analysis. Spun off 21 Dec 07.
2 |
3 | ; Ought to do more of this in Arc. One of the biggest advantages
4 | ; of Lisp is messing with code.
5 |
6 | (def codelines (file)
7 | (w/infile in file
8 | (summing test
9 | (whilet line (readline in)
10 | (test (aand (find nonwhite line) (isnt it #\;)))))))
11 |
12 | (def codeflat (file)
13 | (len (flat (readall (infile file)))))
14 |
15 | (def codetree (file)
16 | (treewise + (fn (x) 1) (readall (infile file))))
17 |
18 | (def code-density (file)
19 | (/ (codetree file) (codelines file)))
20 |
21 | (def tokcount (files)
22 | (let counts (table)
23 | (each f files
24 | (each token (flat (readall (infile f)))
25 | (++ (counts token 0))))
26 | counts))
27 |
28 | (def common-tokens (files)
29 | (let counts (tokcount files)
30 | (let ranking nil
31 | (maptable (fn (k v)
32 | (unless (nonop k)
33 | (insort (compare > cadr) (list k v) ranking)))
34 | counts)
35 | ranking)))
36 |
37 | (def nonop (x)
38 | (in x 'quote 'unquote 'quasiquote 'unquote-splicing))
39 |
40 | (def common-operators (files)
41 | (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))
42 |
43 | (def top40 (xs)
44 | (map prn (firstn 40 xs))
45 | t)
46 |
47 | (def space-eaters (files)
48 | (let counts (tokcount files)
49 | (let ranking nil
50 | (maptable (fn (k v)
51 | (when (and (isa k 'sym) (bound k))
52 | (insort (compare > [* (len (string (car _)))
53 | (cadr _)])
54 | (list k v (* (len (string k)) v))
55 | ranking)))
56 | counts)
57 | ranking)))
58 |
59 | ;(top40 (space-eaters allfiles*))
60 |
61 | (mac flatlen args `(len (flat ',args)))
62 |
--------------------------------------------------------------------------------
/blog.arc:
--------------------------------------------------------------------------------
1 | ; Blog tool example. 20 Jan 08, rev 21 May 09.
2 |
3 | ; To run:
4 | ; arc> (load "blog.arc")
5 | ; arc> (bsv)
6 | ; go to http://localhost:8080/blog
7 |
8 | (= postdir* "arc/posts/" maxid* 0 posts* (table))
9 |
10 | (= blogtitle* "A Blog")
11 |
12 | (deftem post id nil title nil text nil)
13 |
14 | (def load-posts ()
15 | (each id (map int (dir postdir*))
16 | (= maxid* (max maxid* id)
17 | (posts* id) (temload 'post (string postdir* id)))))
18 |
19 | (def save-post (p) (save-table p (string postdir* p!id)))
20 |
21 | (def post (id) (posts* (errsafe:int id)))
22 |
23 | (mac blogpage body
24 | `(whitepage
25 | (center
26 | (widtable 600
27 | (tag b (link blogtitle* "blog"))
28 | (br 3)
29 | ,@body
30 | (br 3)
31 | (w/bars (link "archive")
32 | (link "new post" "newpost"))))))
33 |
34 | (defop viewpost req (blogop post-page req))
35 |
36 | (def blogop (f req)
37 | (aif (post (arg req "id"))
38 | (f (get-user req) it)
39 | (blogpage (pr "No such post."))))
40 |
41 | (def permalink (p) (string "viewpost?id=" p!id))
42 |
43 | (def post-page (user p) (blogpage (display-post user p)))
44 |
45 | (def display-post (user p)
46 | (tag b (link p!title (permalink p)))
47 | (when user
48 | (sp)
49 | (link "[edit]" (string "editpost?id=" p!id)))
50 | (br2)
51 | (pr p!text))
52 |
53 | (defopl newpost req
54 | (whitepage
55 | (aform [let u (get-user _)
56 | (post-page u (addpost u (arg _ "t") (arg _ "b")))]
57 | (tab (row "title" (input "t" "" 60))
58 | (row "text" (textarea "b" 10 80))
59 | (row "" (submit))))))
60 |
61 | (def addpost (user title text)
62 | (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
63 | (save-post p)
64 | (= (posts* p!id) p)))
65 |
66 | (defopl editpost req (blogop edit-page req))
67 |
68 | (def edit-page (user p)
69 | (whitepage
70 | (vars-form user
71 | `((string title ,p!title t t) (text text ,p!text t t))
72 | (fn (name val) (= (p name) val))
73 | (fn () (save-post p)
74 | (post-page user p)))))
75 |
76 | (defop archive req
77 | (blogpage
78 | (tag ul
79 | (each p (map post (rev (range 1 maxid*)))
80 | (tag li (link p!title (permalink p)))))))
81 |
82 | (defop blog req
83 | (let user (get-user req)
84 | (blogpage
85 | (for i 0 4
86 | (awhen (posts* (- maxid* i))
87 | (display-post user it)
88 | (br 3))))))
89 |
90 | (def bsv ()
91 | (ensure-dir postdir*)
92 | (load-posts)
93 | (asv))
94 |
95 |
96 |
--------------------------------------------------------------------------------
/pprint.arc:
--------------------------------------------------------------------------------
1 | ; Pretty-Printing. Spun off 4 Aug 06.
2 |
3 | ; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
4 |
5 | (= bodops* (fill-table (table)
6 | '(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
7 | when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
8 | whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
9 | )))
10 |
11 | (= oneline* 35) ; print exprs less than this long on one line
12 |
13 | ; If returns nil, can assume it didn't have to break expr.
14 |
15 | (def ppr (expr (o col 0) (o noindent nil))
16 | (if (or (atom expr) (dotted expr))
17 | (do (unless noindent (sp col))
18 | (write expr)
19 | nil)
20 | (is (car expr) 'quote)
21 | (do (unless noindent (sp col))
22 | (pr "'")
23 | (ppr (cadr expr) (+ col 1) t))
24 | (bodops* (car expr))
25 | (do (unless noindent (sp col))
26 | (let whole (tostring (write expr))
27 | (if (< (len whole) oneline*)
28 | (do (pr whole) nil)
29 | (ppr-progn expr col noindent))))
30 | (do (unless noindent (sp col))
31 | (let whole (tostring (write expr))
32 | (if (< (len whole) oneline*)
33 | (do (pr whole) nil)
34 | (ppr-call expr col noindent))))))
35 |
36 | (def ppr-progn (expr col noindent)
37 | (lpar)
38 | (let n (bodops* (car expr))
39 | (let str (tostring (write-spaced (firstn n expr)))
40 | (unless (is n 0) (pr str) (sp))
41 | (ppr (expr n) (+ col (len str) 2) t))
42 | (map (fn (e) (prn) (ppr e (+ col 2)))
43 | (nthcdr (+ n 1) expr)))
44 | (rpar)
45 | t)
46 |
47 | (def ppr-call (expr col noindent)
48 | (lpar)
49 | (let carstr (tostring (write (car expr)))
50 | (pr carstr)
51 | (if (cdr expr)
52 | (do (sp)
53 | (let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
54 | (pprest (cddr expr)
55 | (+ col (len carstr) 2)
56 | (no broke)))
57 | t)
58 | (do (rpar) t))))
59 |
60 | (def pprest (exprs col (o oneline t))
61 | (if (and oneline
62 | (all (fn (e)
63 | (or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
64 | exprs))
65 | (do (map (fn (e) (pr " ") (write e))
66 | exprs)
67 | (rpar))
68 | (do (when exprs
69 | (each e exprs (prn) (ppr e col)))
70 | (rpar))))
71 |
72 | (def write-spaced (xs)
73 | (when xs
74 | (write (car xs))
75 | (each x (cdr xs) (pr " ") (write x))))
76 |
77 | (def sp ((o n 1)) (repeat n (pr " ")))
78 | (def lpar () (pr "("))
79 | (def rpar () (pr ")"))
80 |
81 |
--------------------------------------------------------------------------------
/prompt.arc:
--------------------------------------------------------------------------------
1 | ; Prompt: Web-based programming application. 4 Aug 06.
2 |
3 | (= appdir* "arc/apps/")
4 |
5 | (defop prompt req
6 | (let user (get-user req)
7 | (if (admin user)
8 | (prompt-page user)
9 | (pr "Sorry."))))
10 |
11 | (def prompt-page (user . msg)
12 | (ensure-dir appdir*)
13 | (ensure-dir (string appdir* user))
14 | (whitepage
15 | (prbold "Prompt")
16 | (hspace 20)
17 | (pr user " | ")
18 | (link "logout")
19 | (when msg (hspace 10) (apply pr msg))
20 | (br2)
21 | (tag (table border 0 cellspacing 10)
22 | (each app (dir (+ appdir* user))
23 | (tr (td app)
24 | (td (ulink user 'edit (edit-app user app)))
25 | (td (ulink user 'run (run-app user app)))
26 | (td (hspace 40)
27 | (ulink user 'delete (rem-app user app))))))
28 | (br2)
29 | (aform (fn (req)
30 | (when-umatch user req
31 | (aif (goodname (arg req "app"))
32 | (edit-app user it)
33 | (prompt-page user "Bad name."))))
34 | (tab (row "name:" (input "app") (submit "create app"))))))
35 |
36 | (def app-path (user app)
37 | (and user app (+ appdir* user "/" app)))
38 |
39 | (def read-app (user app)
40 | (aand (app-path user app)
41 | (file-exists it)
42 | (readfile it)))
43 |
44 | (def write-app (user app exprs)
45 | (awhen (app-path user app)
46 | (w/outfile o it
47 | (each e exprs (write e o)))))
48 |
49 | (def rem-app (user app)
50 | (let file (app-path user app)
51 | (if (file-exists file)
52 | (do (rmfile (app-path user app))
53 | (prompt-page user "Program " app " deleted."))
54 | (prompt-page user "No such app."))))
55 |
56 | (def edit-app (user app)
57 | (whitepage
58 | (pr "user: " user " app: " app)
59 | (br2)
60 | (aform (fn (req)
61 | (let u2 (get-user req)
62 | (if (is u2 user)
63 | (do (when (is (arg req "cmd") "save")
64 | (write-app user app (readall (arg req "exprs"))))
65 | (prompt-page user))
66 | (login-page 'both nil
67 | (fn (u ip) (prompt-page u))))))
68 | (textarea "exprs" 10 82
69 | (pprcode (read-app user app)))
70 | (br2)
71 | (buts 'cmd "save" "cancel"))))
72 |
73 | (def pprcode (exprs)
74 | (each e exprs
75 | (ppr e)
76 | (pr "\n\n")))
77 |
78 | (def view-app (user app)
79 | (whitepage
80 | (pr "user: " user " app: " app)
81 | (br2)
82 | (tag xmp (pprcode (read-app user app)))))
83 |
84 | (def run-app (user app)
85 | (let exprs (read-app user app)
86 | (if exprs
87 | (on-err (fn (c) (pr "Error: " (details c)))
88 | (fn () (map eval exprs)))
89 | (prompt-page user "Error: No application " app " for user " user))))
90 |
91 | (wipe repl-history*)
92 |
93 | (defop repl req
94 | (if (admin (get-user req))
95 | (replpage req)
96 | (pr "Sorry.")))
97 |
98 | (def replpage (req)
99 | (whitepage
100 | (repl (readall (or (arg req "expr") "")) "repl")))
101 |
102 | (def repl (exprs url)
103 | (each expr exprs
104 | (on-err (fn (c) (push (list expr c t) repl-history*))
105 | (fn ()
106 | (= that (eval expr) thatexpr expr)
107 | (push (list expr that) repl-history*))))
108 | (form url
109 | (textarea "expr" 8 60)
110 | (sp)
111 | (submit))
112 | (tag xmp
113 | (each (expr val err) (firstn 20 repl-history*)
114 | (pr "> ")
115 | (ppr expr)
116 | (prn)
117 | (prn (if err "Error: " "")
118 | (ellipsize (tostring (write val)) 800)))))
119 |
120 |
--------------------------------------------------------------------------------
/strings.arc:
--------------------------------------------------------------------------------
1 | ; Matching. Spun off 29 Jul 06.
2 |
3 | ; arc> (tostring (writec (coerce 133 'char)))
4 | ;
5 | ;> (define ss (open-output-string))
6 | ;> (write-char (integer->char 133) ss)
7 | ;> (get-output-string ss)
8 | ;"\u0085"
9 |
10 | (def tokens (s (o sep whitec))
11 | (let test (testify sep)
12 | (let rec (afn (cs toks tok)
13 | (if (no cs) (consif tok toks)
14 | (test (car cs)) (self (cdr cs) (consif tok toks) nil)
15 | (self (cdr cs) toks (cons (car cs) tok))))
16 | (rev (map [coerce _ 'string]
17 | (map rev (rec (coerce s 'cons) nil nil)))))))
18 |
19 | ; names of cut, split, halve not optimal
20 |
21 | (def halve (s (o sep whitec))
22 | (let test (testify sep)
23 | (let rec (afn (cs tok)
24 | (if (no cs) (list (rev tok))
25 | (test (car cs)) (list cs (rev tok))
26 | (self (cdr cs) (cons (car cs) tok))))
27 | (rev (map [coerce _ 'string]
28 | (rec (coerce s 'cons) nil))))))
29 |
30 | ; maybe promote to arc.arc, but if so include a list clause
31 |
32 | (def positions (test seq)
33 | (accum a
34 | (let f (testify test)
35 | (forlen i seq
36 | (if (f (seq i)) (a i))))))
37 |
38 | (def lines (s)
39 | (accum a
40 | ((afn ((p . ps))
41 | (if ps
42 | (do (a (rem #\return (cut s (+ p 1) (car ps))))
43 | (self ps))
44 | (a (cut s (+ p 1)))))
45 | (cons -1 (positions #\newline s)))))
46 |
47 | ; > (require (lib "uri-codec.ss" "net"))
48 | ;> (form-urlencoded-decode "x%ce%bbx")
49 | ;"xλx"
50 |
51 | ; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.
52 |
53 | ; Fixed for utf8 by pc.
54 |
55 | (def urldecode (s)
56 | (tostring
57 | (forlen i s
58 | (caselet c (s i)
59 | #\+ (writec #\space)
60 | #\% (do (when (> (- (len s) i) 2)
61 | (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
62 | (++ i 2))
63 | (writec c)))))
64 |
65 | (def urlencode (s)
66 | (tostring
67 | (each c s
68 | (writec #\%)
69 | (let i (int c)
70 | (if (< i 16) (writec #\0))
71 | (pr (coerce i 'string 16))))))
72 |
73 | (mac litmatch (pat string (o start 0))
74 | (w/uniq (gstring gstart)
75 | `(with (,gstring ,string ,gstart ,start)
76 | (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
77 | (and ,@(let acc nil
78 | (forlen i pat
79 | (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
80 | acc))
81 | (rev acc)))))))
82 |
83 | ; litmatch would be cleaner if map worked for string and integer args:
84 |
85 | ; ,@(map (fn (n c)
86 | ; `(is ,c (,gstring (+ ,gstart ,n))))
87 | ; (len pat)
88 | ; pat)
89 |
90 | (mac endmatch (pat string)
91 | (w/uniq (gstring glen)
92 | `(withs (,gstring ,string ,glen (len ,gstring))
93 | (unless (> ,(len pat) (len ,gstring))
94 | (and ,@(let acc nil
95 | (forlen i pat
96 | (push `(is ,(pat (- (len pat) 1 i))
97 | (,gstring (- ,glen 1 ,i)))
98 | acc))
99 | (rev acc)))))))
100 |
101 | (def posmatch (pat seq (o start 0))
102 | (catch
103 | (if (isa pat 'fn)
104 | (for i start (- (len seq) 1)
105 | (when (pat (seq i)) (throw i)))
106 | (for i start (- (len seq) (len pat))
107 | (when (headmatch pat seq i) (throw i))))
108 | nil))
109 |
110 | (def headmatch (pat seq (o start 0))
111 | (let p (len pat)
112 | ((afn (i)
113 | (or (is i p)
114 | (and (is (pat i) (seq (+ i start)))
115 | (self (+ i 1)))))
116 | 0)))
117 |
118 | (def begins (seq pat (o start 0))
119 | (unless (len> pat (- (len seq) start))
120 | (headmatch pat seq start)))
121 |
122 | (def subst (new old seq)
123 | (let boundary (+ (- (len seq) (len old)) 1)
124 | (tostring
125 | (forlen i seq
126 | (if (and (< i boundary) (headmatch old seq i))
127 | (do (++ i (- (len old) 1))
128 | (pr new))
129 | (pr (seq i)))))))
130 |
131 | (def multisubst (pairs seq)
132 | (tostring
133 | (forlen i seq
134 | (iflet (old new) (find [begins seq (car _) i] pairs)
135 | (do (++ i (- (len old) 1))
136 | (pr new))
137 | (pr (seq i))))))
138 |
139 | ; not a good name
140 |
141 | (def findsubseq (pat seq (o start 0))
142 | (if (< (- (len seq) start) (len pat))
143 | nil
144 | (if (headmatch pat seq start)
145 | start
146 | (findsubseq pat seq (+ start 1)))))
147 |
148 | (def blank (s) (~find ~whitec s))
149 |
150 | (def nonblank (s) (unless (blank s) s))
151 |
152 | (def trim (s where (o test whitec))
153 | (withs (f (testify test)
154 | p1 (pos ~f s))
155 | (if p1
156 | (cut s
157 | (if (in where 'front 'both) p1 0)
158 | (when (in where 'end 'both)
159 | (let i (- (len s) 1)
160 | (while (and (> i p1) (f (s i)))
161 | (-- i))
162 | (+ i 1))))
163 | "")))
164 |
165 | (def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
166 | (withs (comma
167 | (fn (i)
168 | (tostring
169 | (map [apply pr (rev _)]
170 | (rev (intersperse '(#\,)
171 | (tuples (rev (coerce (string i) 'cons))
172 | 3))))))
173 | abrep
174 | (let a (abs n)
175 | (if (< digits 1)
176 | (comma (roundup a))
177 | (exact a)
178 | (string (comma a)
179 | (when (and trail-zeros (> digits 0))
180 | (string "." (newstring digits #\0))))
181 | (withs (d (expt 10 digits)
182 | m (/ (roundup (* a d)) d)
183 | i (trunc m)
184 | r (abs (trunc (- (* m d) (* i d)))))
185 | (+ (if (is i 0)
186 | (if (or init-zero (is r 0)) "0" "")
187 | (comma i))
188 | (withs (rest (string r)
189 | padded (+ (newstring (- digits (len rest)) #\0)
190 | rest)
191 | final (if trail-zeros
192 | padded
193 | (trim padded 'end [is _ #\0])))
194 | (string (unless (empty final) ".")
195 | final)))))))
196 | (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
197 | (+ "-" abrep)
198 | abrep)))
199 |
200 |
201 | ; English
202 |
203 | (def pluralize (n str)
204 | (if (or (is n 1) (single n))
205 | str
206 | (string str "s")))
207 |
208 | (def plural (n x)
209 | (string n #\ (pluralize n x)))
210 |
211 |
212 | ; http://www.eki.ee/letter/chardata.cgi?HTML4=1
213 | ; http://jrgraphix.net/research/unicode_blocks.php?block=1
214 | ; http://home.tiscali.nl/t876506/utf8tbl.html
215 | ; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
216 | ; http://en.wikipedia.org/wiki/Utf-8
217 | ; http://unicode.org/charts/charindex2.html
218 |
--------------------------------------------------------------------------------
/html.arc:
--------------------------------------------------------------------------------
1 | ; HTML Utils.
2 |
3 |
4 | (def color (r g b)
5 | (with (c (table)
6 | f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
7 | (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
8 | c))
9 |
10 | (def dehex (str) (errsafe (coerce str 'int 16)))
11 |
12 | (defmemo hex>color (str)
13 | (and (is (len str) 6)
14 | (with (r (dehex (cut str 0 2))
15 | g (dehex (cut str 2 4))
16 | b (dehex (cut str 4 6)))
17 | (and r g b
18 | (color r g b)))))
19 |
20 | (defmemo gray (n) (color n n n))
21 |
22 | (= white (gray 255)
23 | black (gray 0)
24 | linkblue (color 0 0 190)
25 | orange (color 255 102 0)
26 | darkred (color 180 0 0)
27 | darkblue (color 0 0 120)
28 | )
29 |
30 | (= opmeths* (table))
31 |
32 | (mac opmeth args
33 | `(opmeths* (list ,@args)))
34 |
35 | (mac attribute (tag opt f)
36 | `(= (opmeths* (list ',tag ',opt)) ,f))
37 |
38 | (= hexreps (table))
39 |
40 | (for i 0 255 (= (hexreps i)
41 | (let s (coerce i 'string 16)
42 | (if (is (len s) 1) (+ "0" s) s))))
43 |
44 | (defmemo hexrep (col)
45 | (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
46 |
47 | (def opcolor (key val)
48 | (w/uniq gv
49 | `(whenlet ,gv ,val
50 | (pr ,(string " " key "=#") (hexrep ,gv)))))
51 |
52 | (def opstring (key val)
53 | `(aif ,val (pr ,(+ " " key "=\"") it #\")))
54 |
55 | (def opnum (key val)
56 | `(aif ,val (pr ,(+ " " key "=") it)))
57 |
58 | (def opsym (key val)
59 | `(pr ,(+ " " key "=") ,val))
60 |
61 | (def opsel (key val)
62 | `(if ,val (pr " selected")))
63 |
64 | (def opesc (key val)
65 | `(awhen ,val
66 | (pr ,(string " " key "=\""))
67 | (if (isa it 'string) (pr-escaped it) (pr it))
68 | (pr #\")))
69 |
70 | ; need to escape more? =?
71 |
72 | (def pr-escaped (x)
73 | (each c x
74 | (pr (case c #\< "<"
75 | #\> ">"
76 | #\" """
77 | #\& "&"
78 | c))))
79 |
80 | (attribute a href opstring)
81 | (attribute a rel opstring)
82 | (attribute a class opstring)
83 | (attribute a id opsym)
84 | (attribute a onclick opstring)
85 | (attribute body alink opcolor)
86 | (attribute body bgcolor opcolor)
87 | (attribute body leftmargin opnum)
88 | (attribute body link opcolor)
89 | (attribute body marginheight opnum)
90 | (attribute body marginwidth opnum)
91 | (attribute body topmargin opnum)
92 | (attribute body vlink opcolor)
93 | (attribute font color opcolor)
94 | (attribute font face opstring)
95 | (attribute font size opnum)
96 | (attribute form action opstring)
97 | (attribute form method opsym)
98 | (attribute img align opsym)
99 | (attribute img border opnum)
100 | (attribute img height opnum)
101 | (attribute img width opnum)
102 | (attribute img vspace opnum)
103 | (attribute img hspace opnum)
104 | (attribute img src opstring)
105 | (attribute input name opstring)
106 | (attribute input size opnum)
107 | (attribute input type opsym)
108 | (attribute input value opesc)
109 | (attribute option selected opsel)
110 | (attribute select name opstring)
111 | (attribute table bgcolor opcolor)
112 | (attribute table border opnum)
113 | (attribute table cellpadding opnum)
114 | (attribute table cellspacing opnum)
115 | (attribute table width opstring)
116 | (attribute textarea cols opnum)
117 | (attribute textarea name opstring)
118 | (attribute textarea rows opnum)
119 | (attribute textarea wrap opsym)
120 | (attribute td align opsym)
121 | (attribute td bgcolor opcolor)
122 | (attribute td colspan opnum)
123 | (attribute td width opnum)
124 | (attribute td valign opsym)
125 | (attribute td class opstring)
126 | (attribute tr bgcolor opcolor)
127 | (attribute hr color opcolor)
128 | (attribute span class opstring)
129 | (attribute span align opstring)
130 | (attribute span id opsym)
131 | (attribute rss version opstring)
132 |
133 |
134 | (mac gentag args (start-tag args))
135 |
136 | (mac tag (spec . body)
137 | `(do ,(start-tag spec)
138 | ,@body
139 | ,(end-tag spec)))
140 |
141 | (mac tag-if (test spec . body)
142 | `(if ,test
143 | (tag ,spec ,@body)
144 | (do ,@body)))
145 |
146 | (def start-tag (spec)
147 | (if (atom spec)
148 | `(pr ,(string "<" spec ">"))
149 | (let opts (tag-options (car spec) (pair (cdr spec)))
150 | (if (all [isa _ 'string] opts)
151 | `(pr ,(string "<" (car spec) (apply string opts) ">"))
152 | `(do (pr ,(string "<" (car spec)))
153 | ,@(map (fn (opt)
154 | (if (isa opt 'string)
155 | `(pr ,opt)
156 | opt))
157 | opts)
158 | (pr ">"))))))
159 |
160 | (def end-tag (spec)
161 | `(pr ,(string "")))
162 |
163 | (def literal (x)
164 | (case (type x)
165 | sym (in x nil t)
166 | cons (caris x 'quote)
167 | t))
168 |
169 | ; Returns a list whose elements are either strings, which can
170 | ; simply be printed out, or expressions, which when evaluated
171 | ; generate output.
172 |
173 | (def tag-options (spec options)
174 | (if (no options)
175 | '()
176 | (let ((opt val) . rest) options
177 | (let meth (if (is opt 'style) opstring (opmeth spec opt))
178 | (if meth
179 | (if val
180 | (cons (if (precomputable-tagopt val)
181 | (tostring (eval (meth opt val)))
182 | (meth opt val))
183 | (tag-options spec rest))
184 | (tag-options spec rest))
185 | (do
186 | (pr "")
187 | (tag-options spec rest)))))))
188 |
189 | (def precomputable-tagopt (val)
190 | (and (literal val)
191 | (no (and (is (type val) 'string) (find #\@ val)))))
192 |
193 | (def br ((o n 1))
194 | (repeat n (pr "
"))
195 | (prn))
196 |
197 | (def br2 () (prn "
"))
198 |
199 | (mac center body `(tag center ,@body))
200 | (mac underline body `(tag u ,@body))
201 | (mac tab body `(tag (table border 0) ,@body))
202 | (mac tr body `(tag tr ,@body))
203 |
204 | (let pratoms (fn (body)
205 | (if (or (no body)
206 | (all [and (acons _) (isnt (car _) 'quote)]
207 | body))
208 | body
209 | `((pr ,@body))))
210 |
211 | (mac td body `(tag td ,@(pratoms body)))
212 | (mac trtd body `(tr (td ,@(pratoms body))))
213 | (mac tdr body `(tag (td align 'right) ,@(pratoms body)))
214 | (mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
215 | )
216 |
217 | (mac row args
218 | `(tr ,@(map [list 'td _] args)))
219 |
220 | (mac prrow args
221 | (w/uniq g
222 | `(tr ,@(map (fn (a)
223 | `(let ,g ,a
224 | (if (number ,g)
225 | (tdr (pr ,g))
226 | (td (pr ,g)))))
227 | args))))
228 |
229 | (mac prbold body `(tag b (pr ,@body)))
230 |
231 | (def para args
232 | (gentag p)
233 | (when args (apply pr args)))
234 |
235 | (def menu (name items (o sel nil))
236 | (tag (select name name)
237 | (each i items
238 | (tag (option selected (is i sel))
239 | (pr i)))))
240 |
241 | (mac whitepage body
242 | `(tag html
243 | (tag (body bgcolor white alink linkblue) ,@body)))
244 |
245 | (def errpage args (whitepage (apply prn args)))
246 |
247 | (def blank-url () "s.gif")
248 |
249 | ; Could memoize these.
250 |
251 | ; If h = 0, doesn't affect table column widths in some Netscapes.
252 |
253 | (def hspace (n) (gentag img src (blank-url) height 1 width n))
254 | (def vspace (n) (gentag img src (blank-url) height n width 0))
255 | (def vhspace (h w) (gentag img src (blank-url) height h width w))
256 |
257 | (mac new-hspace (n)
258 | (if (number n)
259 | `(pr ,(string ""))
260 | `(pr "")))
261 |
262 | ;(def spacerow (h) (tr (td (vspace h))))
263 |
264 | (def spacerow (h) (pr "|
"))
265 |
266 | ; For use as nested table.
267 |
268 | (mac zerotable body
269 | `(tag (table border 0 cellpadding 0 cellspacing 0)
270 | ,@body))
271 |
272 | ; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
273 |
274 | (mac sptab body
275 | `(tag (table style "border-spacing: 7px 0px;") ,@body))
276 |
277 | (mac widtable (w . body)
278 | `(tag (table width ,w) (tr (td ,@body))))
279 |
280 | (def cellpr (x) (pr (or x " ")))
281 |
282 | (def but ((o text "submit") (o name nil))
283 | (gentag input type 'submit name name value text))
284 |
285 | (def submit ((o val "submit"))
286 | (gentag input type 'submit value val))
287 |
288 | (def buts (name . texts)
289 | (if (no texts)
290 | (but)
291 | (do (but (car texts) name)
292 | (each text (cdr texts)
293 | (pr " ")
294 | (but text name)))))
295 |
296 | (mac spanrow (n . body)
297 | `(tr (tag (td colspan ,n) ,@body)))
298 |
299 | (mac form (action . body)
300 | `(tag (form method "post" action ,action) ,@body))
301 |
302 | (mac textarea (name rows cols . body)
303 | `(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
304 |
305 | (def input (name (o val "") (o size 10))
306 | (gentag input type 'text name name value val size size))
307 |
308 | (mac inputs args
309 | `(tag (table border 0)
310 | ,@(map (fn ((name label len text))
311 | (w/uniq (gl gt)
312 | `(let ,gl ,len
313 | (tr (td (pr ',label ":"))
314 | (if (isa ,gl 'cons)
315 | (td (textarea ',name (car ,gl) (cadr ,gl)
316 | (let ,gt ,text (if ,gt (pr ,gt)))))
317 | (td (gentag input type ',(if (is label 'password)
318 | 'password
319 | 'text)
320 | name ',name
321 | size ,len
322 | value ,text)))))))
323 | (tuples args 4))))
324 |
325 | (def single-input (label name chars btext (o pwd))
326 | (pr label)
327 | (gentag input type (if pwd 'password 'text) name name size chars)
328 | (sp)
329 | (submit btext))
330 |
331 | (mac cdata body
332 | `(do (pr "")))
335 |
336 | (def eschtml (str)
337 | (tostring
338 | (each c str
339 | (pr (case c #\< "<"
340 | #\> ">"
341 | #\" """
342 | #\' "'"
343 | #\& "&"
344 | c)))))
345 |
346 | (def esc<>& (str)
347 | (tostring
348 | (each c str
349 | (pr (case c #\< "<"
350 | #\> ">"
351 | #\& "&"
352 | c)))))
353 |
354 | (def nbsp () (pr " "))
355 |
356 | (def link (text (o dest text) (o color))
357 | (tag (a href dest)
358 | (tag-if color (font color color)
359 | (pr text))))
360 |
361 | (def underlink (text (o dest text))
362 | (tag (a href dest) (tag u (pr text))))
363 |
364 | (def striptags (s)
365 | (let intag nil
366 | (tostring
367 | (each c s
368 | (if (is c #\<) (set intag)
369 | (is c #\>) (wipe intag)
370 | (no intag) (pr c))))))
371 |
372 | (def clean-url (u)
373 | (rem [in _ #\" #\' #\< #\>] u))
374 |
375 | (def shortlink (url)
376 | (unless (or (no url) (< (len url) 7))
377 | (link (cut url 7) url)))
378 |
379 | ; this should be one regexp
380 |
381 | (def parafy (str)
382 | (let ink nil
383 | (tostring
384 | (each c str
385 | (pr c)
386 | (unless (whitec c) (set ink))
387 | (when (is c #\newline)
388 | (unless ink (pr ""))
389 | (wipe ink))))))
390 |
391 | (mac spanclass (name . body)
392 | `(tag (span class ',name) ,@body))
393 |
394 | (def pagemessage (text)
395 | (when text (prn text) (br2)))
396 |
397 | ; Could be stricter. Memoized because looking for chars in Unicode
398 | ; strings is terribly inefficient in Mzscheme.
399 |
400 | (defmemo valid-url (url)
401 | (and (len> url 10)
402 | (or (begins url "http://")
403 | (begins url "https://"))
404 | (~find [in _ #\< #\> #\" #\'] url)))
405 |
406 | (mac fontcolor (c . body)
407 | (w/uniq g
408 | `(let ,g ,c
409 | (if ,g
410 | (tag (font color ,g) ,@body)
411 | (do ,@body)))))
412 |
--------------------------------------------------------------------------------
/srv.arc:
--------------------------------------------------------------------------------
1 | ; HTTP Server.
2 |
3 | ; To improve performance with static files, set static-max-age*.
4 |
5 | (= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
6 |
7 | (= quitsrv* nil breaksrv* nil)
8 |
9 | (def serve ((o port 8080))
10 | (wipe quitsrv*)
11 | (ensure-srvdirs)
12 | (map [apply new-bgthread _] pending-bgthreads*)
13 | (w/socket s port
14 | (prn "ready to serve port " port)
15 | (flushout)
16 | (= currsock* s)
17 | (until quitsrv*
18 | (handle-request s breaksrv*)))
19 | (prn "quit server"))
20 |
21 | (def serve1 ((o port 8080))
22 | (w/socket s port (handle-request s t)))
23 |
24 | (def ensure-srvdirs ()
25 | (map ensure-dir (list arcdir* logdir* staticdir*)))
26 |
27 | (= srv-noisy* nil)
28 |
29 | ; http requests currently capped at 2 meg by socket-accept
30 |
31 | ; should threads process requests one at a time? no, then
32 | ; a browser that's slow consuming the data could hang the
33 | ; whole server.
34 |
35 | ; wait for a connection from a browser and start a thread
36 | ; to handle it. also arrange to kill that thread if it
37 | ; has not completed in threadlife* seconds.
38 |
39 | (= threadlife* 30 requests* 0 requests/ip* (table)
40 | throttle-ips* (table) ignore-ips* (table) spurned* (table))
41 |
42 | (def handle-request (s breaksrv)
43 | (if breaksrv
44 | (handle-request-1 s)
45 | (errsafe (handle-request-1 s))))
46 |
47 | (def handle-request-1 (s)
48 | (let (i o ip) (socket-accept s)
49 | (if (and (or (ignore-ips* ip) (abusive-ip ip))
50 | (++ (spurned* ip 0)))
51 | (force-close i o)
52 | (do (++ requests*)
53 | (++ (requests/ip* ip 0))
54 | (with (th1 nil th2 nil)
55 | (= th1 (thread
56 | (after (handle-request-thread i o ip)
57 | (close i o)
58 | (kill-thread th2))))
59 | (= th2 (thread
60 | (sleep threadlife*)
61 | (unless (dead th1)
62 | (prn "srv thread took too long for " ip))
63 | (break-thread th1)
64 | (force-close i o))))))))
65 |
66 | ; Returns true if ip has made req-limit* requests in less than
67 | ; req-window* seconds. If an ip is throttled, only 1 request is
68 | ; allowed per req-window* seconds. If an ip makes req-limit*
69 | ; requests in less than dos-window* seconds, it is a treated as a DoS
70 | ; attack and put in ignore-ips* (for this server invocation).
71 |
72 | ; To adjust this while running, adjust the req-window* time, not
73 | ; req-limit*, because algorithm doesn't enforce decreases in the latter.
74 |
75 | (= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
76 |
77 | (def abusive-ip (ip)
78 | (and (only.> (requests/ip* ip) 250)
79 | (let now (seconds)
80 | (do1 (if (req-times* ip)
81 | (and (>= (qlen (req-times* ip))
82 | (if (throttle-ips* ip) 1 req-limit*))
83 | (let dt (- now (deq (req-times* ip)))
84 | (if (< dt dos-window*) (set (ignore-ips* ip)))
85 | (< dt req-window*)))
86 | (do (= (req-times* ip) (queue))
87 | nil))
88 | (enq now (req-times* ip))))))
89 |
90 | (def handle-request-thread (i o ip)
91 | (with (nls 0 lines nil line nil responded nil t0 (msec))
92 | (after
93 | (whilet c (unless responded (readc i))
94 | (if srv-noisy* (pr c))
95 | (if (is c #\newline)
96 | (if (is (++ nls) 2)
97 | (let (type op args n cooks) (parseheader (rev lines))
98 | (let t1 (msec)
99 | (case type
100 | get (respond o op args cooks ip)
101 | post (handle-post i o op args n cooks ip)
102 | (respond-err o "Unknown request: " (car lines)))
103 | (log-request type op args cooks ip t0 t1)
104 | (set responded)))
105 | (do (push (string (rev line)) lines)
106 | (wipe line)))
107 | (unless (is c #\return)
108 | (push c line)
109 | (= nls 0))))
110 | (close i o)))
111 | (harvest-fnids))
112 |
113 | (def log-request (type op args cooks ip t0 t1)
114 | (with (parsetime (- t1 t0) respondtime (- (msec) t1))
115 | (srvlog 'srv ip
116 | parsetime
117 | respondtime
118 | (if (> (+ parsetime respondtime) 1000) "***" "")
119 | type
120 | op
121 | (let arg1 (car args)
122 | (if (caris arg1 "fnid") "" arg1))
123 | cooks)))
124 |
125 | ; Could ignore return chars (which come from textarea fields) here by
126 | ; (unless (is c #\return) (push c line))
127 |
128 | (def handle-post (i o op args n cooks ip)
129 | (if srv-noisy* (pr "Post Contents: "))
130 | (if (no n)
131 | (respond-err o "Post request without Content-Length.")
132 | (let line nil
133 | (whilet c (and (> n 0) (readc i))
134 | (if srv-noisy* (pr c))
135 | (-- n)
136 | (push c line))
137 | (if srv-noisy* (pr "\n\n"))
138 | (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
139 |
140 | (= header* "HTTP/1.1 200 OK
141 | Content-Type: text/html; charset=utf-8
142 | Connection: close")
143 |
144 | (= type-header* (table))
145 |
146 | (def gen-type-header (ctype)
147 | (+ "HTTP/1.0 200 OK
148 | Content-Type: "
149 | ctype
150 | "
151 | Connection: close"))
152 |
153 | (map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
154 | '((gif "image/gif")
155 | (jpg "image/jpeg")
156 | (png "image/png")
157 | (text/html "text/html; charset=utf-8")))
158 |
159 | (= rdheader* "HTTP/1.0 302 Moved")
160 |
161 | (= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
162 |
163 | (def save-optime (name elapsed)
164 | ; this is the place to put a/b testing
165 | ; toggle a flag and push elapsed into one of two lists
166 | (++ (opcounts* name 0))
167 | (unless (optimes* name) (= (optimes* name) (queue)))
168 | (enq-limit elapsed (optimes* name) 1000))
169 |
170 | ; For ops that want to add their own headers. They must thus remember
171 | ; to prn a blank line before anything meant to be part of the page.
172 |
173 | (mac defop-raw (name parms . body)
174 | (w/uniq t1
175 | `(= (srvops* ',name)
176 | (fn ,parms
177 | (let ,t1 (msec)
178 | (do1 (do ,@body)
179 | (save-optime ',name (- (msec) ,t1))))))))
180 |
181 | (mac defopr-raw (name parms . body)
182 | `(= (redirector* ',name) t
183 | (srvops* ',name) (fn ,parms ,@body)))
184 |
185 | (mac defop (name parm . body)
186 | (w/uniq gs
187 | `(do (wipe (redirector* ',name))
188 | (defop-raw ,name (,gs ,parm)
189 | (w/stdout ,gs (prn) ,@body)))))
190 |
191 | ; Defines op as a redirector. Its retval is new location.
192 |
193 | (mac defopr (name parm . body)
194 | (w/uniq gs
195 | `(do (set (redirector* ',name))
196 | (defop-raw ,name (,gs ,parm)
197 | ,@body))))
198 |
199 | ;(mac testop (name . args) `((srvops* ',name) ,@args))
200 |
201 | (deftem request
202 | args nil
203 | cooks nil
204 | ip nil)
205 |
206 | (= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
207 |
208 | (def respond (str op args cooks ip)
209 | (w/stdout str
210 | (iflet f (srvops* op)
211 | (let req (inst 'request 'args args 'cooks cooks 'ip ip)
212 | (if (redirector* op)
213 | (do (prn rdheader*)
214 | (prn "Location: " (f str req))
215 | (prn))
216 | (do (prn header*)
217 | (awhen (max-age* op)
218 | (prn "Cache-Control: max-age=" it))
219 | (f str req))))
220 | (let filetype (static-filetype op)
221 | (aif (and filetype (file-exists (string staticdir* op)))
222 | (do (prn (type-header* filetype))
223 | (awhen static-max-age*
224 | (prn "Cache-Control: max-age=" it))
225 | (prn)
226 | (w/infile i it
227 | (whilet b (readb i)
228 | (writeb b str))))
229 | (respond-err str unknown-msg*))))))
230 |
231 | (def static-filetype (sym)
232 | (let fname (coerce sym 'string)
233 | (and (~find #\/ fname)
234 | (case (downcase (last (check (tokens fname #\.) ~single)))
235 | "gif" 'gif
236 | "jpg" 'jpg
237 | "jpeg" 'jpg
238 | "png" 'png
239 | "css" 'text/html
240 | "txt" 'text/html
241 | "htm" 'text/html
242 | "html" 'text/html
243 | "arc" 'text/html
244 | ))))
245 |
246 | (def respond-err (str msg . args)
247 | (w/stdout str
248 | (prn header*)
249 | (prn)
250 | (apply pr msg args)))
251 |
252 | (def parseheader (lines)
253 | (let (type op args) (parseurl (car lines))
254 | (list type
255 | op
256 | args
257 | (and (is type 'post)
258 | (some (fn (s)
259 | (and (begins s "Content-Length:")
260 | (errsafe:coerce (cadr (tokens s)) 'int)))
261 | (cdr lines)))
262 | (some (fn (s)
263 | (and (begins s "Cookie:")
264 | (parsecookies s)))
265 | (cdr lines)))))
266 |
267 | ; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
268 |
269 | (def parseurl (s)
270 | (let (type url) (tokens s)
271 | (let (base args) (tokens url #\?)
272 | (list (sym (downcase type))
273 | (sym (cut base 1))
274 | (if args
275 | (parseargs args)
276 | nil)))))
277 |
278 | ; I don't urldecode field names or anything in cookies; correct?
279 |
280 | (def parseargs (s)
281 | (map (fn ((k v)) (list k (urldecode v)))
282 | (map [tokens _ #\=] (tokens s #\&))))
283 |
284 | (def parsecookies (s)
285 | (map [tokens _ #\=]
286 | (cdr (tokens s [or (whitec _) (is _ #\;)]))))
287 |
288 | (def arg (req key) (alref req!args key))
289 |
290 | ; *** Warning: does not currently urlencode args, so if need to do
291 | ; that replace v with (urlencode v).
292 |
293 | (def reassemble-args (req)
294 | (aif req!args
295 | (apply string "?" (intersperse '&
296 | (map (fn ((k v))
297 | (string k '= v))
298 | it)))
299 | ""))
300 |
301 | (= fns* (table) fnids* nil timed-fnids* nil)
302 |
303 | ; count on huge (expt 64 10) size of fnid space to avoid clashes
304 |
305 | (def new-fnid ()
306 | (check (sym (rand-string 10)) ~fns* (new-fnid)))
307 |
308 | (def fnid (f)
309 | (atlet key (new-fnid)
310 | (= (fns* key) f)
311 | (push key fnids*)
312 | key))
313 |
314 | (def timed-fnid (lasts f)
315 | (atlet key (new-fnid)
316 | (= (fns* key) f)
317 | (push (list key (seconds) lasts) timed-fnids*)
318 | key))
319 |
320 | ; Within f, it will be bound to the fn's own fnid. Remember that this is
321 | ; so low-level that need to generate the newline to separate from the headers
322 | ; within the body of f.
323 |
324 | (mac afnid (f)
325 | `(atlet it (new-fnid)
326 | (= (fns* it) ,f)
327 | (push it fnids*)
328 | it))
329 |
330 | ;(defop test-afnid req
331 | ; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
332 | ; (pr "click here")))
333 |
334 | ; To be more sophisticated, instead of killing fnids, could first
335 | ; replace them with fns that tell the server it's harvesting too
336 | ; aggressively if they start to get called. But the right thing to
337 | ; do is estimate what the max no of fnids can be and set the harvest
338 | ; limit there-- beyond that the only solution is to buy more memory.
339 |
340 | (def harvest-fnids ((o n 50000)) ; was 20000
341 | (when (len> fns* n)
342 | (pull (fn ((id created lasts))
343 | (when (> (since created) lasts)
344 | (wipe (fns* id))
345 | t))
346 | timed-fnids*)
347 | (atlet nharvest (trunc (/ n 10))
348 | (let (kill keep) (split (rev fnids*) nharvest)
349 | (= fnids* (rev keep))
350 | (each id kill
351 | (wipe (fns* id)))))))
352 |
353 | (= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
354 |
355 | (= dead-msg* "\nUnknown or expired link.")
356 |
357 | (defop-raw x (str req)
358 | (w/stdout str
359 | (aif (fns* (sym (arg req "fnid")))
360 | (it req)
361 | (pr dead-msg*))))
362 |
363 | (defopr-raw y (str req)
364 | (aif (fns* (sym (arg req "fnid")))
365 | (w/stdout str (it req))
366 | "deadlink"))
367 |
368 | ; For asynchronous calls; discards the page. Would be better to tell
369 | ; the fn not to generate it.
370 |
371 | (defop-raw a (str req)
372 | (aif (fns* (sym (arg req "fnid")))
373 | (tostring (it req))))
374 |
375 | (defopr r req
376 | (aif (fns* (sym (arg req "fnid")))
377 | (it req)
378 | "deadlink"))
379 |
380 | (defop deadlink req
381 | (pr dead-msg*))
382 |
383 | (def url-for (fnid)
384 | (string fnurl* "?fnid=" fnid))
385 |
386 | (def flink (f)
387 | (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
388 |
389 | (def rflink (f)
390 | (string rfnurl* "?fnid=" (fnid f)))
391 |
392 | ; Since it's just an expr, gensym a parm for (ignored) args.
393 |
394 | (mac w/link (expr . body)
395 | `(tag (a href (flink (fn (,(uniq)) ,expr)))
396 | ,@body))
397 |
398 | (mac w/rlink (expr . body)
399 | `(tag (a href (rflink (fn (,(uniq)) ,expr)))
400 | ,@body))
401 |
402 | (mac onlink (text . body)
403 | `(w/link (do ,@body) (pr ,text)))
404 |
405 | (mac onrlink (text . body)
406 | `(w/rlink (do ,@body) (pr ,text)))
407 |
408 | ; bad to have both flink and linkf; rename flink something like fnid-link
409 |
410 | (mac linkf (text parms . body)
411 | `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
412 |
413 | (mac rlinkf (text parms . body)
414 | `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
415 |
416 | ;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
417 |
418 | ;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
419 |
420 | (mac w/link-if (test expr . body)
421 | `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
422 | ,@body))
423 |
424 | (def fnid-field (id)
425 | (gentag input type 'hidden name 'fnid value id))
426 |
427 | ; f should be a fn of one arg, which will be http request args.
428 |
429 | (def fnform (f bodyfn (o redir))
430 | (tag (form method 'post action (if redir rfnurl2* fnurl*))
431 | (fnid-field (fnid f))
432 | (bodyfn)))
433 |
434 | ; Could also make a version that uses just an expr, and var capture.
435 | ; Is there a way to ensure user doesn't use "fnid" as a key?
436 |
437 | (mac aform (f . body)
438 | (w/uniq ga
439 | `(tag (form method 'post action fnurl*)
440 | (fnid-field (fnid (fn (,ga)
441 | (prn)
442 | (,f ,ga))))
443 | ,@body)))
444 |
445 | ;(defop test1 req
446 | ; (fnform (fn (req) (prn) (pr req))
447 | ; (fn () (single-input "" 'foo 20 "submit"))))
448 |
449 | ;(defop test2 req
450 | ; (aform (fn (req) (pr req))
451 | ; (single-input "" 'foo 20 "submit")))
452 |
453 | ; Like aform except creates a fnid that will last for lasts seconds
454 | ; (unless the server is restarted).
455 |
456 | (mac timed-aform (lasts f . body)
457 | (w/uniq (gl gf gi ga)
458 | `(withs (,gl ,lasts
459 | ,gf (fn (,ga) (prn) (,f ,ga)))
460 | (tag (form method 'post action fnurl*)
461 | (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
462 | ,@body))))
463 |
464 | (mac arform (f . body)
465 | `(tag (form method 'post action rfnurl*)
466 | (fnid-field (fnid ,f))
467 | ,@body))
468 |
469 | ; overlong
470 |
471 | (mac tarform (lasts f . body)
472 | (w/uniq (gl gf)
473 | `(withs (,gl ,lasts ,gf ,f)
474 | (tag (form method 'post action rfnurl*)
475 | (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
476 | ,@body))))
477 |
478 | (mac aformh (f . body)
479 | `(tag (form method 'post action fnurl*)
480 | (fnid-field (fnid ,f))
481 | ,@body))
482 |
483 | (mac arformh (f . body)
484 | `(tag (form method 'post action rfnurl2*)
485 | (fnid-field (fnid ,f))
486 | ,@body))
487 |
488 | ; only unique per server invocation
489 |
490 | (= unique-ids* (table))
491 |
492 | (def unique-id ((o len 8))
493 | (let id (sym (rand-string (max 5 len)))
494 | (if (unique-ids* id)
495 | (unique-id)
496 | (= (unique-ids* id) id))))
497 |
498 | (def srvlog (type . args)
499 | (w/appendfile o (logfile-name type)
500 | (w/stdout o (atomic (apply prs (seconds) args) (prn)))))
501 |
502 | (def logfile-name (type)
503 | (string logdir* type "-" (memodate)))
504 |
505 | (with (lastasked nil lastval nil)
506 |
507 | (def memodate ()
508 | (let now (seconds)
509 | (if (or (no lastasked) (> (- now lastasked) 60))
510 | (= lastasked now lastval (datestring))
511 | lastval)))
512 |
513 | )
514 |
515 | (defop || req (pr "It's alive."))
516 |
517 | (defop topips req
518 | (when (admin (get-user req))
519 | (whitepage
520 | (sptab
521 | (each ip (let leaders nil
522 | (maptable (fn (ip n)
523 | (when (> n 100)
524 | (insort (compare > requests/ip*)
525 | ip
526 | leaders)))
527 | requests/ip*)
528 | leaders)
529 | (let n (requests/ip* ip)
530 | (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
531 |
532 | (defop spurned req
533 | (when (admin (get-user req))
534 | (whitepage
535 | (sptab
536 | (map (fn ((ip n)) (row ip n))
537 | (sortable spurned*))))))
538 |
539 | ; eventually promote to general util
540 |
541 | (def sortable (ht (o f >))
542 | (let res nil
543 | (maptable (fn kv
544 | (insort (compare f cadr) kv res))
545 | ht)
546 | res))
547 |
548 |
549 | ; Background Threads
550 |
551 | (= bgthreads* (table) pending-bgthreads* nil)
552 |
553 | (def new-bgthread (id f sec)
554 | (aif (bgthreads* id) (break-thread it))
555 | (= (bgthreads* id) (new-thread (fn ()
556 | (while t
557 | (sleep sec)
558 | (f))))))
559 |
560 | ; should be a macro for this?
561 |
562 | (mac defbg (id sec . body)
563 | `(do (pull [caris _ ',id] pending-bgthreads*)
564 | (push (list ',id (fn () ,@body) ,sec)
565 | pending-bgthreads*)))
566 |
567 |
568 |
569 | ; Idea: make form fields that know their value type because of
570 | ; gensymed names, and so the receiving fn gets args that are not
571 | ; strings but parsed values.
572 |
573 |
--------------------------------------------------------------------------------
/app.arc:
--------------------------------------------------------------------------------
1 | ; Application Server. Layer inserted 2 Sep 06.
2 |
3 | ; ideas:
4 | ; def a general notion of apps of which prompt is one, news another
5 | ; give each user a place to store data? A home dir?
6 |
7 | ; A user is simply a string: "pg". Use /whoami to test user cookie.
8 |
9 | (= hpwfile* "arc/hpw"
10 | oidfile* "arc/openids"
11 | adminfile* "arc/admins"
12 | cookfile* "arc/cooks")
13 |
14 | (def asv ((o port 8080))
15 | (load-userinfo)
16 | (serve port))
17 |
18 | (def load-userinfo ()
19 | (= hpasswords* (safe-load-table hpwfile*)
20 | openids* (safe-load-table oidfile*)
21 | admins* (map string (errsafe (readfile adminfile*)))
22 | cookie->user* (safe-load-table cookfile*))
23 | (maptable (fn (k v) (= (user->cookie* v) k))
24 | cookie->user*))
25 |
26 | ; idea: a bidirectional table, so don't need two vars (and sets)
27 |
28 | (= cookie->user* (table) user->cookie* (table) logins* (table))
29 |
30 | (def get-user (req)
31 | (let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
32 | (when u (= (logins* u) req!ip))
33 | u))
34 |
35 | (mac when-umatch (user req . body)
36 | `(if (is ,user (get-user ,req))
37 | (do ,@body)
38 | (mismatch-message)))
39 |
40 | (def mismatch-message ()
41 | (prn "Dead link: users don't match."))
42 |
43 | (mac when-umatch/r (user req . body)
44 | `(if (is ,user (get-user ,req))
45 | (do ,@body)
46 | "mismatch"))
47 |
48 | (defop mismatch req (mismatch-message))
49 |
50 | (mac uform (user req after . body)
51 | `(aform (fn (,req)
52 | (when-umatch ,user ,req
53 | ,after))
54 | ,@body))
55 |
56 | (mac urform (user req after . body)
57 | `(arform (fn (,req)
58 | (when-umatch/r ,user ,req
59 | ,after))
60 | ,@body))
61 |
62 | ; Like onlink, but checks that user submitting the request is the
63 | ; same it was generated for. For extra protection could log the
64 | ; username and ip addr of every genlink, and check if they match.
65 |
66 | (mac ulink (user text . body)
67 | (w/uniq req
68 | `(linkf ,text (,req)
69 | (when-umatch ,user ,req ,@body))))
70 |
71 |
72 | (defop admin req (admin-gate (get-user req)))
73 |
74 | (def admin-gate (u)
75 | (if (admin u)
76 | (admin-page u)
77 | (login-page 'login nil
78 | (fn (u ip) (admin-gate u)))))
79 |
80 | (def admin (u) (and u (mem u admins*)))
81 |
82 | (def user-exists (u) (and u (hpasswords* u) u))
83 |
84 | (def admin-page (user . msg)
85 | (whitepage
86 | (prbold "Admin: ")
87 | (hspace 20)
88 | (pr user " | ")
89 | (w/link (do (logout-user user)
90 | (whitepage (pr "Bye " user ".")))
91 | (pr "logout"))
92 | (when msg (hspace 10) (map pr msg))
93 | (br2)
94 | (aform (fn (req)
95 | (when-umatch user req
96 | (with (u (arg req "u") p (arg req "p"))
97 | (if (or (no u) (no p) (is u "") (is p ""))
98 | (pr "Bad data.")
99 | (user-exists u)
100 | (admin-page user "User already exists: " u)
101 | (do (create-acct u p)
102 | (admin-page user))))))
103 | (pwfields "create (server) account"))))
104 |
105 | (def cook-user (user)
106 | (let id (new-user-cookie)
107 | (= (cookie->user* id) user
108 | (user->cookie* user) id)
109 | (save-table cookie->user* cookfile*)
110 | id))
111 |
112 | ; Unique-ids are only unique per server invocation.
113 |
114 | (def new-user-cookie ()
115 | (let id (unique-id)
116 | (if (cookie->user* id) (new-user-cookie) id)))
117 |
118 | (def logout-user (user)
119 | (wipe (logins* user))
120 | (wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
121 | (save-table cookie->user* cookfile*))
122 |
123 | (def create-acct (user pw)
124 | (set (dc-usernames* (downcase user)))
125 | (set-pw user pw))
126 |
127 | (def disable-acct (user)
128 | (set-pw user (rand-string 20))
129 | (logout-user user))
130 |
131 | (def set-pw (user pw)
132 | (= (hpasswords* user) (and pw (shash pw)))
133 | (save-table hpasswords* hpwfile*))
134 |
135 | (def hello-page (user ip)
136 | (whitepage (prs "hello" user "at" ip)))
137 |
138 | (defop login req (login-page 'login))
139 |
140 | ; switch is one of: register, login, both
141 |
142 | ; afterward is either a function on the newly created username and
143 | ; ip address, in which case it is called to generate the next page
144 | ; after a successful login, or a pair of (function url), which means
145 | ; call the function, then redirect to the url.
146 |
147 | ; classic example of something that should just "return" a val
148 | ; via a continuation rather than going to a new page.
149 |
150 | (def login-page (switch (o msg nil) (o afterward hello-page))
151 | (whitepage
152 | (pagemessage msg)
153 | (when (in switch 'login 'both)
154 | (login-form "Login" switch login-handler afterward)
155 | (hook 'login-form afterward)
156 | (br2))
157 | (when (in switch 'register 'both)
158 | (login-form "Create Account" switch create-handler afterward))))
159 |
160 | (def login-form (label switch handler afterward)
161 | (prbold label)
162 | (br2)
163 | (fnform (fn (req) (handler req switch afterward))
164 | (fn () (pwfields (downcase label)))
165 | (acons afterward)))
166 |
167 | (def login-handler (req switch afterward)
168 | (logout-user (get-user req))
169 | (aif (good-login (arg req "u") (arg req "p") req!ip)
170 | (login it req!ip (user->cookie* it) afterward)
171 | (failed-login switch "Bad login." afterward)))
172 |
173 | (def create-handler (req switch afterward)
174 | (logout-user (get-user req))
175 | (with (user (arg req "u") pw (arg req "p"))
176 | (aif (bad-newacct user pw)
177 | (failed-login switch it afterward)
178 | (do (create-acct user pw)
179 | (login user req!ip (cook-user user) afterward)))))
180 |
181 | (def login (user ip cookie afterward)
182 | (= (logins* user) ip)
183 | (prcookie cookie)
184 | (if (acons afterward)
185 | (let (f url) afterward
186 | (f user ip)
187 | url)
188 | (do (prn)
189 | (afterward user ip))))
190 |
191 | (def failed-login (switch msg afterward)
192 | (if (acons afterward)
193 | (flink (fn ignore (login-page switch msg afterward)))
194 | (do (prn)
195 | (login-page switch msg afterward))))
196 |
197 | (def prcookie (cook)
198 | (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
199 |
200 | (def pwfields ((o label "login"))
201 | (inputs u username 20 nil
202 | p password 20 nil)
203 | (br)
204 | (submit label))
205 |
206 | (= good-logins* (queue) bad-logins* (queue))
207 |
208 | (def good-login (user pw ip)
209 | (let record (list (seconds) ip user)
210 | (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
211 | (do (unless (user->cookie* user) (cook-user user))
212 | (enq-limit record good-logins*)
213 | user)
214 | (do (enq-limit record bad-logins*)
215 | nil))))
216 |
217 | ; Create a file in case people have quote chars in their pws. I can't
218 | ; believe there's no way to just send the chars.
219 |
220 | (def shash (str)
221 | (let fname (+ "/tmp/shash" (rand-string 10))
222 | (w/outfile f fname (disp str f))
223 | (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
224 | (do1 (cut res 0 (- (len res) 1))
225 | (rmfile fname)))))
226 |
227 | (= dc-usernames* (table))
228 |
229 | (def username-taken (user)
230 | (when (empty dc-usernames*)
231 | (each (k v) hpasswords*
232 | (set (dc-usernames* (downcase k)))))
233 | (dc-usernames* (downcase user)))
234 |
235 | (def bad-newacct (user pw)
236 | (if (no (goodname user 2 15))
237 | "Usernames can only contain letters, digits, dashes and
238 | underscores, and should be between 2 and 15 characters long.
239 | Please choose another."
240 | (username-taken user)
241 | "That username is taken. Please choose another."
242 | (or (no pw) (< (len pw) 4))
243 | "Passwords should be a least 4 characters long. Please
244 | choose another."
245 | nil))
246 |
247 | (def goodname (str (o min 1) (o max nil))
248 | (and (isa str 'string)
249 | (>= (len str) min)
250 | (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
251 | str)
252 | (isnt (str 0) #\-)
253 | (or (no max) (<= (len str) max))
254 | str))
255 |
256 | (defop logout req
257 | (aif (get-user req)
258 | (do (logout-user it)
259 | (pr "Logged out."))
260 | (pr "You were not logged in.")))
261 |
262 | (defop whoami req
263 | (aif (get-user req)
264 | (prs it 'at req!ip)
265 | (do (pr "You are not logged in. ")
266 | (w/link (login-page 'both) (pr "Log in"))
267 | (pr "."))))
268 |
269 |
270 | (= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
271 |
272 | ; Eventually figure out a way to separate type name from format of
273 | ; input field, instead of having e.g. toks and bigtoks
274 |
275 | (def varfield (typ id val)
276 | (if (in typ 'string 'string1 'url)
277 | (gentag input type 'text name id value val size formwid*)
278 | (in typ 'num 'int 'posint 'sym)
279 | (gentag input type 'text name id value val size numwid*)
280 | (in typ 'users 'toks)
281 | (gentag input type 'text name id value (tostring (apply prs val))
282 | size formwid*)
283 | (is typ 'sexpr)
284 | (gentag input type 'text name id
285 | value (tostring (map [do (write _) (sp)] val))
286 | size formwid*)
287 | (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
288 | (let text (if (in typ 'syms 'bigtoks)
289 | (tostring (apply prs val))
290 | (is typ 'lines)
291 | (tostring (apply pr (intersperse #\newline val)))
292 | (in typ 'mdtext 'mdtext2)
293 | (unmarkdown val)
294 | (no val)
295 | ""
296 | val)
297 | (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
298 | rows (needrows text formwid* 4)
299 | wrap 'virtual
300 | style (if (is typ 'doc) "font-size:8.5pt")
301 | name id)
302 | (prn) ; needed or 1 initial newline gets chopped off
303 | (pr text))
304 | (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
305 | (pr " ")
306 | (tag (font size -2)
307 | (link "help" formatdoc-url* (gray 175)))))
308 | (caris typ 'choice)
309 | (menu id (cddr typ) val)
310 | (is typ 'yesno)
311 | (menu id '("yes" "no") (if val "yes" "no"))
312 | (is typ 'hexcol)
313 | (gentag input type 'text name id value val)
314 | (is typ 'time)
315 | (gentag input type 'text name id value (if val (english-time val) ""))
316 | (is typ 'date)
317 | (gentag input type 'text name id value (if val (english-date val) ""))
318 | (err "unknown varfield type" typ)))
319 |
320 | (def text-rows (text wid (o pad 3))
321 | (+ (trunc (/ (len text) (* wid .8))) pad))
322 |
323 | (def needrows (text cols (o pad 0))
324 | (+ pad (max (+ 1 (count #\newline text))
325 | (roundup (/ (len text) (- cols 5))))))
326 |
327 | (def varline (typ id val (o liveurls))
328 | (if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
329 | (is typ 'lines) (map prn val)
330 | (is typ 'yesno) (pr (if val 'yes 'no))
331 | (caris typ 'choice) (varline (cadr typ) nil val)
332 | (is typ 'url) (if (and liveurls (valid-url val))
333 | (link val val)
334 | (pr val))
335 | (text-type typ) (pr (or val ""))
336 | (pr val)))
337 |
338 | (def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
339 |
340 | ; Newlines in forms come back as /r/n. Only want the /ns. Currently
341 | ; remove the /rs in individual cases below. Could do it in aform or
342 | ; even in the parsing of http requests, in the server.
343 |
344 | ; Need the calls to striptags so that news users can't get html
345 | ; into a title or comment by editing it. If want a form that
346 | ; can take html, just create another typ for it.
347 |
348 | (def readvar (typ str (o fail nil))
349 | (case (carif typ)
350 | string (striptags str)
351 | string1 (if (blank str) fail (striptags str))
352 | url (if (blank str) "" (valid-url str) (clean-url str) fail)
353 | num (let n (saferead str) (if (number n) n fail))
354 | int (let n (saferead str)
355 | (if (number n) (round n) fail))
356 | posint (let n (saferead str)
357 | (if (and (number n) (> n 0)) (round n) fail))
358 | text (striptags str)
359 | doc (striptags str)
360 | mdtext (md-from-form str)
361 | mdtext2 (md-from-form str t) ; for md with no links
362 | sym (or (sym:car:tokens str) fail)
363 | syms (map sym (tokens str))
364 | sexpr (errsafe (readall str))
365 | users (rem [no (goodname _)] (tokens str))
366 | toks (tokens str)
367 | bigtoks (tokens str)
368 | lines (lines str)
369 | choice (readvar (cadr typ) str)
370 | yesno (is str "yes")
371 | hexcol (if (hex>color str) str fail)
372 | time (or (errsafe (parse-time str)) fail)
373 | date (or (errsafe (parse-date str)) fail)
374 | (err "unknown readvar type" typ)))
375 |
376 | (= fail* (uniq))
377 |
378 | ; Takes a list of fields of the form (type label value view modify) and
379 | ; a fn f and generates a form such that when submitted (f label newval)
380 | ; will be called for each valid value. Finally done is called.
381 |
382 | (def vars-form (user fields f done (o button "update") (o lasts))
383 | (timed-aform lasts
384 | (if (all [no (_ 4)] fields)
385 | (fn (req))
386 | (fn (req)
387 | (when-umatch user req
388 | (each (k v) req!args
389 | (let name (sym k)
390 | (awhen (find [is (cadr _) name] fields)
391 | ; added sho to fix bug
392 | (let (typ id val sho mod) it
393 | (when (and mod v)
394 | (let newval (readvar typ v fail*)
395 | (unless (is newval fail*)
396 | (f name newval))))))))
397 | (done))))
398 | (tab
399 | (showvars fields))
400 | (unless (all [no (_ 4)] fields) ; no modifiable fields
401 | (br)
402 | (submit button))))
403 |
404 | (def showvars (fields (o liveurls))
405 | (each (typ id val view mod question) fields
406 | (when view
407 | (when question
408 | (tr (td (prn question))))
409 | (tr (unless question (tag (td valign 'top) (pr id ":")))
410 | (td (if mod
411 | (varfield typ id val)
412 | (varline typ id val liveurls))))
413 | (prn))))
414 |
415 | ; http://daringfireball.net/projects/markdown/syntax
416 |
417 | (def md-from-form (str (o nolinks))
418 | (markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks))
419 |
420 | (def markdown (s (o maxurl) (o nolinks))
421 | (let ital nil
422 | (tostring
423 | (forlen i s
424 | (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
425 | (do (pr "
")
426 | (let cb (code-block s (- newi spaces 1))
427 | (pr cb)
428 | (= i (+ (- newi spaces 1) (len cb))))
429 | (pr "
"))
430 | (iflet newi (parabreak s i (if (is i 0) 1 0))
431 | (do (unless (is i 0) (pr ""))
432 | (= i (- newi 1)))
433 | (and (is (s i) #\*)
434 | (or ital
435 | (atend i s)
436 | (and (~whitec (s (+ i 1)))
437 | (pos #\* s (+ i 1)))))
438 | (do (pr (if ital "" ""))
439 | (= ital (no ital)))
440 | (and (no nolinks)
441 | (or (litmatch "http://" s i)
442 | (litmatch "https://" s i)))
443 | (withs (n (urlend s i)
444 | url (clean-url (cut s i n)))
445 | (tag (a href url rel 'nofollow)
446 | (pr (if (no maxurl) url (ellipsize url maxurl))))
447 | (= i (- n 1)))
448 | (writec (s i))))))))
449 |
450 | (def indented-code (s i (o newlines 0) (o spaces 0))
451 | (let c (s i)
452 | (if (nonwhite c)
453 | (if (and (> newlines 1) (> spaces 1))
454 | (list i spaces)
455 | nil)
456 | (atend i s)
457 | nil
458 | (is c #\newline)
459 | (indented-code s (+ i 1) (+ newlines 1) 0)
460 | (indented-code s (+ i 1) newlines (+ spaces 1)))))
461 |
462 | ; If i is start a paragraph break, returns index of start of next para.
463 |
464 | (def parabreak (s i (o newlines 0))
465 | (let c (s i)
466 | (if (or (nonwhite c) (atend i s))
467 | (if (> newlines 1) i nil)
468 | (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
469 |
470 | ; Returns the indices of the next paragraph break in s, if any.
471 |
472 | (def next-parabreak (s i)
473 | (unless (atend i s)
474 | (aif (parabreak s i)
475 | (list i it)
476 | (next-parabreak s (+ i 1)))))
477 |
478 | (def paras (s (o i 0))
479 | (if (atend i s)
480 | nil
481 | (iflet (endthis startnext) (next-parabreak s i)
482 | (cons (cut s i endthis)
483 | (paras s startnext))
484 | (list (trim (cut s i) 'end)))))
485 |
486 |
487 | ; Returns the index of the first char not part of the url beginning
488 | ; at i, or len of string if url goes all the way to the end.
489 |
490 | ; Note that > immediately after a url (http://foo.com>) will cause
491 | ; an odd result, because the > gets escaped to something beginning
492 | ; with &, which is treated as part of the url. Perhaps the answer
493 | ; is just to esc<>& after markdown instead of before.
494 |
495 | ; Treats a delimiter as part of a url if it is (a) an open delimiter
496 | ; not followed by whitespace or eos, or (b) a close delimiter
497 | ; balancing a previous open delimiter.
498 |
499 | (def urlend (s i (o indelim))
500 | (let c (s i)
501 | (if (atend i s)
502 | (if ((orf punc whitec opendelim) c)
503 | i
504 | (closedelim c)
505 | (if indelim (+ i 1) i)
506 | (+ i 1))
507 | (if (or (whitec c)
508 | (and (punc c) (whitec (s (+ i 1))))
509 | (and ((orf whitec punc) (s (+ i 1)))
510 | (or (opendelim c)
511 | (and (closedelim c) (no indelim)))))
512 | i
513 | (urlend s (+ i 1) (or (opendelim c)
514 | (and indelim (no (closedelim c)))))))))
515 |
516 | (def opendelim (c) (in c #\< #\( #\[ #\{))
517 |
518 | (def closedelim (c) (in c #\> #\) #\] #\}))
519 |
520 |
521 | (def code-block (s i)
522 | (tostring
523 | (until (let left (- (len s) i 1)
524 | (or (is left 0)
525 | (and (> left 2)
526 | (is (s (+ i 1)) #\newline)
527 | (nonwhite (s (+ i 2))))))
528 | (writec (s (++ i))))))
529 |
530 | (def unmarkdown (s)
531 | (tostring
532 | (forlen i s
533 | (if (litmatch "
" s i)
534 | (do (++ i 2)
535 | (unless (is i 2) (pr "\n\n")))
536 | (litmatch "" s i)
537 | (do (++ i 2) (pr #\*))
538 | (litmatch "" s i)
539 | (do (++ i 3) (pr #\*))
540 | (litmatch "" s endurl)
545 | (+ it 3)
546 | endurl)))
547 | (writec (s i))))
548 | (litmatch "" s i)
549 | (awhen (findsubseq "
" s (+ i 12))
550 | (pr (cut s (+ i 11) it))
551 | (= i (+ it 12)))
552 | (writec (s i))))))
553 |
554 |
555 | (def english-time (min)
556 | (let n (mod min 720)
557 | (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
558 | ":"
559 | (let m (mod n 60)
560 | (if (is m 0) "00"
561 | (< m 10) (string "0" m)
562 | m))
563 | (if (is min 0) " midnight"
564 | (is min 720) " noon"
565 | (>= min 720) " pm"
566 | " am"))))
567 |
568 | (def parse-time (s)
569 | (let (nums (o label "")) (halve s letter)
570 | (with ((h (o m 0)) (map int (tokens nums ~digit))
571 | cleanlabel (downcase (rem ~alphadig label)))
572 | (+ (* (if (is h 12)
573 | (if (in cleanlabel "am" "midnight")
574 | 0
575 | 12)
576 | (is cleanlabel "pm")
577 | (+ h 12)
578 | h)
579 | 60)
580 | m))))
581 |
582 |
583 | (= months* '("January" "February" "March" "April" "May" "June" "July"
584 | "August" "September" "October" "November" "December"))
585 |
586 | (def english-date ((y m d))
587 | (string d " " (months* (- m 1)) " " y))
588 |
589 | (= month-names* (obj "january" 1 "jan" 1
590 | "february" 2 "feb" 2
591 | "march" 3 "mar" 3
592 | "april" 4 "apr" 4
593 | "may" 5
594 | "june" 6 "jun" 6
595 | "july" 7 "jul" 7
596 | "august" 8 "aug" 8
597 | "september" 9 "sept" 9 "sep" 9
598 | "october" 10 "oct" 10
599 | "november" 11 "nov" 11
600 | "december" 12 "dec" 12))
601 |
602 | (def monthnum (s) (month-names* (downcase s)))
603 |
604 | ; Doesn't work for BC dates.
605 |
606 | (def parse-date (s)
607 | (let nums (date-nums s)
608 | (if (valid-date nums)
609 | nums
610 | (err (string "Invalid date: " s)))))
611 |
612 | (def date-nums (s)
613 | (with ((ynow mnow dnow) (date)
614 | toks (tokens s ~alphadig))
615 | (if (all [all digit _] toks)
616 | (let nums (map int toks)
617 | (case (len nums)
618 | 1 (list ynow mnow (car nums))
619 | 2 (iflet d (find [> _ 12] nums)
620 | (list ynow (find [isnt _ d] nums) d)
621 | (cons ynow nums))
622 | (if (> (car nums) 31)
623 | (firstn 3 nums)
624 | (rev (firstn 3 nums)))))
625 | ([all digit _] (car toks))
626 | (withs ((ds ms ys) toks
627 | d (int ds))
628 | (aif (monthnum ms)
629 | (list (or (errsafe (int ys)) ynow)
630 | it
631 | d)
632 | nil))
633 | (monthnum (car toks))
634 | (let (ms ds ys) toks
635 | (aif (errsafe (int ds))
636 | (list (or (errsafe (int ys)) ynow)
637 | (monthnum (car toks))
638 | it)
639 | nil))
640 | nil)))
641 |
642 | ; To be correct needs to know days per month, and about leap years
643 |
644 | (def valid-date ((y m d))
645 | (and y m d
646 | (< 0 m 13)
647 | (< 0 d 32)))
648 |
649 | (mac defopl (name parm . body)
650 | `(defop ,name ,parm
651 | (if (get-user ,parm)
652 | (do ,@body)
653 | (login-page 'both
654 | "You need to be logged in to do that."
655 | (list (fn (u ip))
656 | (string ',name (reassemble-args ,parm)))))))
657 |
658 |
--------------------------------------------------------------------------------
/ac.scm:
--------------------------------------------------------------------------------
1 | ; Arc Compiler.
2 |
3 | (module ac mzscheme
4 |
5 | (provide (all-defined))
6 | ; uncomment the following require for mzscheme-4.x
7 | ; much of Arc will work, but not mutable pairs.
8 | ; (require rnrs/mutable-pairs-6)
9 | (require (lib "port.ss"))
10 | (require (lib "process.ss"))
11 | (require (lib "pretty.ss"))
12 |
13 | ; compile an Arc expression into a Scheme expression,
14 | ; both represented as s-expressions.
15 | ; env is a list of lexically bound variables, which we
16 | ; need in order to decide whether set should create a global.
17 |
18 | (define (ac s env)
19 | (cond ((string? s) (ac-string s env))
20 | ((literal? s) s)
21 | ((eqv? s 'nil) (list 'quote 'nil))
22 | ((ssyntax? s) (ac (expand-ssyntax s) env))
23 | ((symbol? s) (ac-var-ref s env))
24 | ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
25 | ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
26 | ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
27 | ((eq? (xcar s) 'if) (ac-if (cdr s) env))
28 | ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
29 | ((eq? (xcar s) 'assign) (ac-set (cdr s) env))
30 | ; the next three clauses could be removed without changing semantics
31 | ; ... except that they work for macros (so prob should do this for
32 | ; every elt of s, not just the car)
33 | ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
34 | ((eq? (xcar (xcar s)) 'complement)
35 | (ac (list 'no (cons (cadar s) (cdr s))) env))
36 | ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
37 | ((pair? s) (ac-call (car s) (cdr s) env))
38 | (#t (err "Bad object in expression" s))))
39 |
40 | (define atstrings #f)
41 |
42 | (define (ac-string s env)
43 | (if atstrings
44 | (if (atpos s 0)
45 | (ac (cons 'string (map (lambda (x)
46 | (if (string? x)
47 | (unescape-ats x)
48 | x))
49 | (codestring s)))
50 | env)
51 | (unescape-ats s))
52 | (string-copy s))) ; avoid immutable strings
53 |
54 | (define (literal? x)
55 | (or (boolean? x)
56 | (char? x)
57 | (string? x)
58 | (number? x)
59 | (eq? x '())))
60 |
61 | (define (ssyntax? x)
62 | (and (symbol? x)
63 | (not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
64 | (let ((name (symbol->string x)))
65 | (has-ssyntax-char? name (- (string-length name) 1)))))
66 |
67 | (define (has-ssyntax-char? string i)
68 | (and (>= i 0)
69 | (or (let ((c (string-ref string i)))
70 | (or (eqv? c #\:) (eqv? c #\~)
71 | (eqv? c #\+)
72 | ;(eqv? c #\_)
73 | (eqv? c #\.) (eqv? c #\!)))
74 | (has-ssyntax-char? string (- i 1)))))
75 |
76 | (define (read-from-string str)
77 | (let ((port (open-input-string str)))
78 | (let ((val (read port)))
79 | (close-input-port port)
80 | val)))
81 |
82 | ; Though graphically the right choice, can't use _ for currying
83 | ; because then _!foo becomes a function. Maybe use <>. For now
84 | ; leave this off and see how often it would have been useful.
85 |
86 | ; Might want to make ~ have less precedence than +, because
87 | ; ~foo+bar prob should mean (andf (complement foo) bar), not
88 | ; (complement (andf foo bar)).
89 |
90 | (define (expand-ssyntax sym)
91 | ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
92 | ((insym? #\+ sym) expand-and)
93 | ; ((insym? #\_ sym) expand-curry)
94 | ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
95 | (#t (error "Unknown ssyntax" sym)))
96 | sym))
97 |
98 | (define (expand-compose sym)
99 | (let ((elts (map (lambda (tok)
100 | (if (eqv? (car tok) #\~)
101 | (if (null? (cdr tok))
102 | 'no
103 | `(complement ,(chars->value (cdr tok))))
104 | (chars->value tok)))
105 | (tokens (lambda (c) (eqv? c #\:))
106 | (symbol->chars sym)
107 | '()
108 | '()
109 | #f))))
110 | (if (null? (cdr elts))
111 | (car elts)
112 | (cons 'compose elts))))
113 |
114 | (define (expand-and sym)
115 | (let ((elts (map chars->value
116 | (tokens (lambda (c) (eqv? c #\+))
117 | (symbol->chars sym)
118 | '()
119 | '()
120 | #f))))
121 | (if (null? (cdr elts))
122 | (car elts)
123 | (cons 'andf elts))))
124 |
125 | ; How to include quoted arguments? Can't treat all as quoted, because
126 | ; never want to quote fn given as first. Do we want to allow quote chars
127 | ; within symbols? Could be ugly.
128 |
129 | ; If release, fix the fact that this simply uses v0... as vars. Should
130 | ; make these vars gensyms.
131 |
132 | (define (expand-curry sym)
133 | (let ((expr (exc (map (lambda (x)
134 | (if (pair? x) (chars->value x) x))
135 | (tokens (lambda (c) (eqv? c #\_))
136 | (symbol->chars sym)
137 | '()
138 | '()
139 | #t))
140 | 0)))
141 | (list 'fn
142 | (keep (lambda (s)
143 | (and (symbol? s)
144 | (eqv? (string-ref (symbol->string s) 0)
145 | #\v)))
146 | expr)
147 | expr)))
148 |
149 | (define (keep f xs)
150 | (cond ((null? xs) '())
151 | ((f (car xs)) (cons (car xs) (keep f (cdr xs))))
152 | (#t (keep f (cdr xs)))))
153 |
154 | (define (exc elts n)
155 | (cond ((null? elts)
156 | '())
157 | ((eqv? (car elts) #\_)
158 | (cons (string->symbol (string-append "v" (number->string n)))
159 | (exc (cdr elts) (+ n 1))))
160 | (#t
161 | (cons (car elts) (exc (cdr elts) n)))))
162 |
163 | (define (expand-sexpr sym)
164 | (build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
165 | (symbol->chars sym)
166 | '()
167 | '()
168 | #t))
169 | sym))
170 |
171 | (define (build-sexpr toks orig)
172 | (cond ((null? toks)
173 | 'get)
174 | ((null? (cdr toks))
175 | (chars->value (car toks)))
176 | (#t
177 | (list (build-sexpr (cddr toks) orig)
178 | (if (eqv? (cadr toks) #\!)
179 | (list 'quote (chars->value (car toks)))
180 | (if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
181 | (err "Bad ssyntax" orig)
182 | (chars->value (car toks))))))))
183 |
184 | (define (insym? char sym) (member char (symbol->chars sym)))
185 |
186 | (define (symbol->chars x) (string->list (symbol->string x)))
187 |
188 | (define (chars->value chars) (read-from-string (list->string chars)))
189 |
190 | (define (tokens test source token acc keepsep?)
191 | (cond ((null? source)
192 | (reverse (if (pair? token)
193 | (cons (reverse token) acc)
194 | acc)))
195 | ((test (car source))
196 | (tokens test
197 | (cdr source)
198 | '()
199 | (let ((rec (if (null? token)
200 | acc
201 | (cons (reverse token) acc))))
202 | (if keepsep?
203 | (cons (car source) rec)
204 | rec))
205 | keepsep?))
206 | (#t
207 | (tokens test
208 | (cdr source)
209 | (cons (car source) token)
210 | acc
211 | keepsep?))))
212 |
213 | (define (ac-global-name s)
214 | (string->symbol (string-append "_" (symbol->string s))))
215 |
216 | (define (ac-var-ref s env)
217 | (if (lex? s env)
218 | s
219 | (ac-global-name s)))
220 |
221 | ; quasiquote
222 |
223 | (define (ac-qq args env)
224 | (list 'quasiquote (ac-qq1 1 args env)))
225 |
226 | ; process the argument of a quasiquote. keep track of
227 | ; depth of nesting. handle unquote only at top level (level = 1).
228 | ; complete form, e.g. x or (fn x) or (unquote (fn x))
229 |
230 | (define (ac-qq1 level x env)
231 | (cond ((= level 0)
232 | (ac x env))
233 | ((and (pair? x) (eqv? (car x) 'unquote))
234 | (list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
235 | ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
236 | (list 'unquote-splicing
237 | (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
238 | ((and (pair? x) (eqv? (car x) 'quasiquote))
239 | (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
240 | ((pair? x)
241 | (map (lambda (x) (ac-qq1 level x env)) x))
242 | (#t x)))
243 |
244 | ; (if) -> nil
245 | ; (if x) -> x
246 | ; (if t a ...) -> a
247 | ; (if nil a b) -> b
248 | ; (if nil a b c) -> (if b c)
249 |
250 | (define (ac-if args env)
251 | (cond ((null? args) ''nil)
252 | ((null? (cdr args)) (ac (car args) env))
253 | (#t `(if (not (ar-false? ,(ac (car args) env)))
254 | ,(ac (cadr args) env)
255 | ,(ac-if (cddr args) env)))))
256 |
257 | (define (ac-dbname! name env)
258 | (if (symbol? name)
259 | (cons (list name) env)
260 | env))
261 |
262 | (define (ac-dbname env)
263 | (cond ((null? env) #f)
264 | ((pair? (car env)) (caar env))
265 | (#t (ac-dbname (cdr env)))))
266 |
267 | ; translate fn directly into a lambda if it has ordinary
268 | ; parameters, otherwise use a rest parameter and parse it.
269 |
270 | (define (ac-fn args body env)
271 | (if (ac-complex-args? args)
272 | (ac-complex-fn args body env)
273 | (ac-nameit
274 | (ac-dbname env)
275 | `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
276 | ,@(ac-body* body (append (ac-arglist args) env))))))
277 |
278 | ; does an fn arg list use optional parameters or destructuring?
279 | ; a rest parameter is not complex
280 |
281 | (define (ac-complex-args? args)
282 | (cond ((eqv? args '()) #f)
283 | ((symbol? args) #f)
284 | ((and (pair? args) (symbol? (car args)))
285 | (ac-complex-args? (cdr args)))
286 | (#t #t)))
287 |
288 | ; translate a fn with optional or destructuring args
289 | ; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
290 | ; arguments in top-level list are mandatory (unless optional),
291 | ; but it's OK for parts of a list you're destructuring to
292 | ; be missing.
293 |
294 | (define (ac-complex-fn args body env)
295 | (let* ((ra (ar-gensym))
296 | (z (ac-complex-args args env ra #t)))
297 | `(lambda ,ra
298 | (let* ,z
299 | ,@(ac-body* body (append (ac-complex-getargs z) env))))))
300 |
301 | ; returns a list of two-element lists, first is variable name,
302 | ; second is (compiled) expression. to be used in a let.
303 | ; caller should extract variables and add to env.
304 | ; ra is the rest argument to the fn.
305 | ; is-params indicates that args are function arguments
306 | ; (not destructuring), so they must be passed or be optional.
307 |
308 | (define (ac-complex-args args env ra is-params)
309 | (cond ((or (eqv? args '()) (eqv? args 'nil)) '())
310 | ((symbol? args) (list (list args ra)))
311 | ((pair? args)
312 | (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
313 | (ac-complex-opt (cadar args)
314 | (if (pair? (cddar args))
315 | (caddar args)
316 | 'nil)
317 | env
318 | ra)
319 | (ac-complex-args
320 | (car args)
321 | env
322 | (if is-params
323 | `(car ,ra)
324 | `(ar-xcar ,ra))
325 | #f)))
326 | (xa (ac-complex-getargs x)))
327 | (append x (ac-complex-args (cdr args)
328 | (append xa env)
329 | `(ar-xcdr ,ra)
330 | is-params))))
331 | (#t (err "Can't understand fn arg list" args))))
332 |
333 | ; (car ra) is the argument
334 | ; so it's not present if ra is nil or '()
335 |
336 | (define (ac-complex-opt var expr env ra)
337 | (list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
338 |
339 | ; extract list of variables from list of two-element lists.
340 |
341 | (define (ac-complex-getargs a)
342 | (map (lambda (x) (car x)) a))
343 |
344 | ; (a b . c) -> (a b c)
345 | ; a -> (a)
346 |
347 | (define (ac-arglist a)
348 | (cond ((null? a) '())
349 | ((symbol? a) (list a))
350 | ((symbol? (cdr a)) (list (car a) (cdr a)))
351 | (#t (cons (car a) (ac-arglist (cdr a))))))
352 |
353 | (define (ac-body body env)
354 | (map (lambda (x) (ac x env)) body))
355 |
356 | ; like ac-body, but spits out a nil expression if empty
357 |
358 | (define (ac-body* body env)
359 | (if (null? body)
360 | (list (list 'quote 'nil))
361 | (ac-body body env)))
362 |
363 | ; (set v1 expr1 v2 expr2 ...)
364 |
365 | (define (ac-set x env)
366 | `(begin ,@(ac-setn x env)))
367 |
368 | (define (ac-setn x env)
369 | (if (null? x)
370 | '()
371 | (cons (ac-set1 (ac-macex (car x)) (cadr x) env)
372 | (ac-setn (cddr x) env))))
373 |
374 | ; trick to tell Scheme the name of something, so Scheme
375 | ; debugging and profiling make more sense.
376 |
377 | (define (ac-nameit name v)
378 | (if (symbol? name)
379 | (let ((n (string->symbol (string-append " " (symbol->string name)))))
380 | (list 'let `((,n ,v)) n))
381 | v))
382 |
383 | ; = replaced by set, which is only for vars
384 | ; = now defined in arc (is it?)
385 | ; name is to cause fns to have their arc names for debugging
386 |
387 | (define (ac-set1 a b1 env)
388 | (if (symbol? a)
389 | (let ((b (ac b1 (ac-dbname! a env))))
390 | (list 'let `((zz ,b))
391 | (cond ((eqv? a 'nil) (err "Can't rebind nil"))
392 | ((eqv? a 't) (err "Can't rebind t"))
393 | ((lex? a env) `(set! ,a zz))
394 | (#t `(namespace-set-variable-value! ',(ac-global-name a)
395 | zz)))
396 | 'zz))
397 | (err "First arg to set must be a symbol" a)))
398 |
399 | ; given a list of Arc expressions, return a list of Scheme expressions.
400 | ; for compiling passed arguments.
401 |
402 | (define (ac-args names exprs env)
403 | (if (null? exprs)
404 | '()
405 | (cons (ac (car exprs)
406 | (ac-dbname! (if (pair? names) (car names) #f) env))
407 | (ac-args (if (pair? names) (cdr names) '())
408 | (cdr exprs)
409 | env))))
410 |
411 | ; generate special fast code for ordinary two-operand
412 | ; calls to the following functions. this is to avoid
413 | ; calling e.g. ar-is with its &rest and apply.
414 |
415 | (define ac-binaries
416 | '((is ar-is2)
417 | (< ar-<2)
418 | (> ar->2)
419 | (+ ar-+2)))
420 |
421 | ; (foo bar) where foo is a global variable bound to a procedure.
422 |
423 | (define (ac-global-call fn args env)
424 | (cond ((and (assoc fn ac-binaries) (= (length args) 2))
425 | `(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
426 | (#t
427 | `(,(ac-global-name fn) ,@(ac-args '() args env)))))
428 |
429 | ; compile a function call
430 | ; special cases for speed, to avoid compiled output like
431 | ; (ar-apply _pr (list 1 2))
432 | ; which results in 1/2 the CPU time going to GC. Instead:
433 | ; (ar-funcall2 _pr 1 2)
434 | ; and for (foo bar), if foo is a reference to a global variable,
435 | ; and it's bound to a function, generate (foo bar) instead of
436 | ; (ar-funcall1 foo bar)
437 |
438 | (define direct-calls #f)
439 |
440 | (define (ac-call fn args env)
441 | (let ((macfn (ac-macro? fn)))
442 | (cond (macfn
443 | (ac-mac-call macfn args env))
444 | ((and (pair? fn) (eqv? (car fn) 'fn))
445 | `(,(ac fn env) ,@(ac-args (cadr fn) args env)))
446 | ((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
447 | (procedure? (namespace-variable-value (ac-global-name fn))))
448 | (ac-global-call fn args env))
449 | ((= (length args) 0)
450 | `(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
451 | ((= (length args) 1)
452 | `(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
453 | ((= (length args) 2)
454 | `(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
455 | ((= (length args) 3)
456 | `(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
457 | ((= (length args) 4)
458 | `(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
459 | (#t
460 | `(ar-apply ,(ac fn env)
461 | (list ,@(map (lambda (x) (ac x env)) args)))))))
462 |
463 | (define (ac-mac-call m args env)
464 | (let ((x1 (apply m (map ac-niltree args))))
465 | (let ((x2 (ac (ac-denil x1) env)))
466 | x2)))
467 |
468 | ; returns #f or the macro function
469 |
470 | (define (ac-macro? fn)
471 | (if (symbol? fn)
472 | (let ((v (namespace-variable-value (ac-global-name fn)
473 | #t
474 | (lambda () #f))))
475 | (if (and v
476 | (ar-tagged? v)
477 | (eq? (ar-type v) 'mac))
478 | (ar-rep v)
479 | #f))
480 | #f))
481 |
482 | ; macroexpand the outer call of a form as much as possible
483 |
484 | (define (ac-macex e . once)
485 | (if (pair? e)
486 | (let ((m (ac-macro? (car e))))
487 | (if m
488 | (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
489 | (if (null? once) (ac-macex expansion) expansion))
490 | e))
491 | e))
492 |
493 | ; macros return Arc lists, ending with NIL.
494 | ; but the Arc compiler expects Scheme lists, ending with '().
495 | ; what to do with (is x nil . nil) ?
496 | ; the first nil ought to be replaced with 'NIL
497 | ; the second with '()
498 | ; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
499 | ; NIL by itself -> NIL
500 |
501 | (define (ac-denil x)
502 | (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
503 | (#t x)))
504 |
505 | (define (ac-denil-car x)
506 | (if (eq? x 'nil)
507 | 'nil
508 | (ac-denil x)))
509 |
510 | (define (ac-denil-cdr x)
511 | (if (eq? x 'nil)
512 | '()
513 | (ac-denil x)))
514 |
515 | ; is v lexically bound?
516 |
517 | (define (lex? v env)
518 | (memq v env))
519 |
520 | (define (xcar x)
521 | (and (pair? x) (car x)))
522 |
523 | ; #f and '() -> nil for a whole quoted list/tree.
524 |
525 | ; Arc primitives written in Scheme should look like:
526 |
527 | ; (xdef foo (lambda (lst)
528 | ; (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
529 |
530 | ; That is, Arc lists are NIL-terminated. When calling a Scheme
531 | ; function that treats an argument as a list, call ar-nil-terminate
532 | ; to change NIL to '(). When returning any data created by Scheme
533 | ; to Arc, call ac-niltree to turn all '() into NIL.
534 | ; (hash-table-get doesn't use its argument as a list, so it doesn't
535 | ; need ar-nil-terminate).
536 |
537 | (define (ac-niltree x)
538 | (cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
539 | ((or (eq? x #f) (eq? x '())) 'nil)
540 | (#t x)))
541 |
542 | ; The next two are optimizations, except work for macros.
543 |
544 | (define (decompose fns args)
545 | (cond ((null? fns) `((fn vals (car vals)) ,@args))
546 | ((null? (cdr fns)) (cons (car fns) args))
547 | (#t (list (car fns) (decompose (cdr fns) args)))))
548 |
549 | (define (ac-andf s env)
550 | (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
551 | `((fn ,gs
552 | (and ,@(map (lambda (f) `(,f ,@gs))
553 | (cdar s))))
554 | ,@(cdr s)))
555 | env))
556 |
557 | (define err error)
558 |
559 | ; run-time primitive procedures
560 |
561 | ;(define (xdef a b)
562 | ; (namespace-set-variable-value! (ac-global-name a) b)
563 | ; b)
564 |
565 | (define-syntax xdef
566 | (syntax-rules ()
567 | ((xxdef a b)
568 | (let ((nm (ac-global-name 'a))
569 | (a b))
570 | (namespace-set-variable-value! nm a)
571 | a))))
572 |
573 | (define fn-signatures (make-hash-table 'equal))
574 |
575 | ; This is a replacement for xdef that stores opeator signatures.
576 | ; Haven't started using it yet.
577 |
578 | (define (odef a parms b)
579 | (namespace-set-variable-value! (ac-global-name a) b)
580 | (hash-table-put! fn-signatures a (list parms))
581 | b)
582 |
583 | (xdef sig fn-signatures)
584 |
585 | ; versions of car and cdr for parsing arguments for optional
586 | ; parameters, that yield nil for nil. maybe we should use
587 | ; full Arc car and cdr, so we can destructure more things
588 |
589 | (define (ar-xcar x)
590 | (if (or (eqv? x 'nil) (eqv? x '()))
591 | 'nil
592 | (car x)))
593 |
594 | (define (ar-xcdr x)
595 | (if (or (eqv? x 'nil) (eqv? x '()))
596 | 'nil
597 | (cdr x)))
598 |
599 | ; convert #f from a Scheme predicate to NIL.
600 |
601 | (define (ar-nill x)
602 | (if (or (eq? x '()) (eq? x #f))
603 | 'nil
604 | x))
605 |
606 | ; definition of falseness for Arc if.
607 | ; must include '() since sometimes Arc functions see
608 | ; Scheme lists (e.g. . body of a macro).
609 |
610 | (define (ar-false? x)
611 | (or (eq? x 'nil) (eq? x '()) (eq? x #f)))
612 |
613 | ; call a function or perform an array ref, hash ref, &c
614 |
615 | ; Non-fn constants in functional position are valuable real estate, so
616 | ; should figure out the best way to exploit it. What could (1 foo) or
617 | ; ('a foo) mean? Maybe it should mean currying.
618 |
619 | ; For now the way to make the default val of a hash table be other than
620 | ; nil is to supply the val when doing the lookup. Later may also let
621 | ; defaults be supplied as an arg to table. To implement this, need: an
622 | ; eq table within scheme mapping tables to defaults, and to adapt the
623 | ; code in arc.arc that reads and writes tables to read and write their
624 | ; default vals with them. To make compatible with existing written tables,
625 | ; just use an atom or 3-elt list to keep the default.
626 |
627 | (define (ar-apply fn args)
628 | (cond ((procedure? fn)
629 | (apply fn args))
630 | ((pair? fn)
631 | (list-ref fn (car args)))
632 | ((string? fn)
633 | (string-ref fn (car args)))
634 | ((hash-table? fn)
635 | (ar-nill (hash-table-get fn
636 | (car args)
637 | (if (pair? (cdr args)) (cadr args) #f))))
638 | ; experiment: means e.g. [1] is a constant fn
639 | ; ((or (number? fn) (symbol? fn)) fn)
640 | ; another possibility: constant in functional pos means it gets
641 | ; passed to the first arg, i.e. ('kids item) means (item 'kids).
642 | (#t (err "Function call on inappropriate object" fn args))))
643 |
644 | (xdef apply (lambda (fn . args)
645 | (ar-apply fn (ar-apply-args args))))
646 |
647 | ; special cases of ar-apply for speed and to avoid consing arg lists
648 |
649 | (define (ar-funcall0 fn)
650 | (if (procedure? fn)
651 | (fn)
652 | (ar-apply fn (list))))
653 |
654 | (define (ar-funcall1 fn arg1)
655 | (if (procedure? fn)
656 | (fn arg1)
657 | (ar-apply fn (list arg1))))
658 |
659 | (define (ar-funcall2 fn arg1 arg2)
660 | (if (procedure? fn)
661 | (fn arg1 arg2)
662 | (ar-apply fn (list arg1 arg2))))
663 |
664 | (define (ar-funcall3 fn arg1 arg2 arg3)
665 | (if (procedure? fn)
666 | (fn arg1 arg2 arg3)
667 | (ar-apply fn (list arg1 arg2 arg3))))
668 |
669 | (define (ar-funcall4 fn arg1 arg2 arg3 arg4)
670 | (if (procedure? fn)
671 | (fn arg1 arg2 arg3 arg4)
672 | (ar-apply fn (list arg1 arg2 arg3 arg4))))
673 |
674 | ; replace the nil at the end of a list with a '()
675 |
676 | (define (ar-nil-terminate l)
677 | (if (or (eqv? l '()) (eqv? l 'nil))
678 | '()
679 | (cons (car l) (ar-nil-terminate (cdr l)))))
680 |
681 | ; turn the arguments to Arc apply into a list.
682 | ; if you call (apply fn 1 2 '(3 4))
683 | ; then args is '(1 2 (3 4 . nil) . ())
684 | ; that is, the main list is a scheme list.
685 | ; and we should return '(1 2 3 4 . ())
686 | ; was once (apply apply list (ac-denil args))
687 | ; but that didn't work for (apply fn nil)
688 |
689 | (define (ar-apply-args args)
690 | (cond ((null? args) '())
691 | ((null? (cdr args)) (ar-nil-terminate (car args)))
692 | (#t (cons (car args) (ar-apply-args (cdr args))))))
693 |
694 |
695 |
696 |
697 |
698 | (xdef cons cons)
699 |
700 | (xdef car (lambda (x)
701 | (cond ((pair? x) (car x))
702 | ((eqv? x 'nil) 'nil)
703 | ((eqv? x '()) 'nil)
704 | (#t (err "Can't take car of" x)))))
705 |
706 | (xdef cdr (lambda (x)
707 | (cond ((pair? x) (cdr x))
708 | ((eqv? x 'nil) 'nil)
709 | ((eqv? x '()) 'nil)
710 | (#t (err "Can't take cdr of" x)))))
711 |
712 | (define (tnil x) (if x 't 'nil))
713 |
714 | ; (pairwise pred '(a b c d)) =>
715 | ; (and (pred a b) (pred b c) (pred c d))
716 | ; pred returns t/nil, as does pairwise
717 | ; reduce?
718 |
719 | (define (pairwise pred lst)
720 | (cond ((null? lst) 't)
721 | ((null? (cdr lst)) 't)
722 | ((not (eqv? (pred (car lst) (cadr lst)) 'nil))
723 | (pairwise pred (cdr lst)))
724 | (#t 'nil)))
725 |
726 | ; not quite right, because behavior of underlying eqv unspecified
727 | ; in many cases according to r5rs
728 | ; do we really want is to ret t for distinct strings?
729 |
730 | ; for (is x y)
731 |
732 | (define (ar-is2 a b)
733 | (tnil (or (eqv? a b)
734 | (and (string? a) (string? b) (string=? a b))
735 | (and (ar-false? a) (ar-false? b)))))
736 |
737 | ; for all other uses of is
738 |
739 | (xdef is (lambda args (pairwise ar-is2 args)))
740 |
741 | (xdef err err)
742 | (xdef nil 'nil)
743 | (xdef t 't)
744 |
745 | (define (all test seq)
746 | (or (null? seq)
747 | (and (test (car seq)) (all test (cdr seq)))))
748 |
749 | (define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
750 |
751 | ; Generic +: strings, lists, numbers.
752 | ; Return val has same type as first argument.
753 |
754 | (xdef + (lambda args
755 | (cond ((null? args) 0)
756 | ((char-or-string? (car args))
757 | (apply string-append
758 | (map (lambda (a) (ar-coerce a 'string))
759 | args)))
760 | ((arc-list? (car args))
761 | (ac-niltree (apply append (map ar-nil-terminate args))))
762 | (#t (apply + args)))))
763 |
764 | (define (char-or-string? x) (or (string? x) (char? x)))
765 |
766 | (define (ar-+2 x y)
767 | (cond ((char-or-string? x)
768 | (string-append (ar-coerce x 'string) (ar-coerce y 'string)))
769 | ((and (arc-list? x) (arc-list? y))
770 | (ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
771 | (#t (+ x y))))
772 |
773 | (xdef - -)
774 | (xdef * *)
775 | (xdef / /)
776 | (xdef mod modulo)
777 | (xdef expt expt)
778 | (xdef sqrt sqrt)
779 |
780 | ; generic comparison
781 |
782 | (define (ar->2 x y)
783 | (tnil (cond ((and (number? x) (number? y)) (> x y))
784 | ((and (string? x) (string? y)) (string>? x y))
785 | ((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
786 | (symbol->string y)))
787 | ((and (char? x) (char? y)) (char>? x y))
788 | (#t (> x y)))))
789 |
790 | (xdef > (lambda args (pairwise ar->2 args)))
791 |
792 | (define (ar-<2 x y)
793 | (tnil (cond ((and (number? x) (number? y)) (< x y))
794 | ((and (string? x) (string? y)) (stringstring x)
796 | (symbol->string y)))
797 | ((and (char? x) (char? y)) (char sym
817 |
818 | (define (ar-type x)
819 | (cond ((ar-tagged? x) (vector-ref x 1))
820 | ((pair? x) 'cons)
821 | ((symbol? x) 'sym)
822 | ((null? x) 'sym)
823 | ((procedure? x) 'fn)
824 | ((char? x) 'char)
825 | ((string? x) 'string)
826 | ((integer? x) 'int)
827 | ((number? x) 'num) ; unsure about this
828 | ((hash-table? x) 'table)
829 | ((output-port? x) 'output)
830 | ((input-port? x) 'input)
831 | ((tcp-listener? x) 'socket)
832 | ((exn? x) 'exception)
833 | ((thread? x) 'thread)
834 | (#t (err "Type: unknown type" x))))
835 | (xdef type ar-type)
836 |
837 | (define (ar-rep x)
838 | (if (ar-tagged? x)
839 | (vector-ref x 2)
840 | x))
841 |
842 | (xdef rep ar-rep)
843 |
844 | ; currently rather a joke: returns interned symbols
845 |
846 | (define ar-gensym-count 0)
847 |
848 | (define (ar-gensym)
849 | (set! ar-gensym-count (+ ar-gensym-count 1))
850 | (string->symbol (string-append "gs" (number->string ar-gensym-count))))
851 |
852 | (xdef uniq ar-gensym)
853 |
854 | (xdef ccc call-with-current-continuation)
855 |
856 | (xdef infile open-input-file)
857 |
858 | (xdef outfile (lambda (f . args)
859 | (open-output-file f
860 | 'text
861 | (if (equal? args '(append))
862 | 'append
863 | 'truncate))))
864 |
865 | (xdef instring open-input-string)
866 | (xdef outstring open-output-string)
867 |
868 | ; use as general fn for looking inside things
869 |
870 | (xdef inside get-output-string)
871 |
872 | (xdef stdout current-output-port) ; should be a vars
873 | (xdef stdin current-input-port)
874 | (xdef stderr current-error-port)
875 |
876 | (xdef call-w/stdout
877 | (lambda (port thunk)
878 | (parameterize ((current-output-port port)) (thunk))))
879 |
880 | (xdef call-w/stdin
881 | (lambda (port thunk)
882 | (parameterize ((current-input-port port)) (thunk))))
883 |
884 | (xdef readc (lambda str
885 | (let ((c (read-char (if (pair? str)
886 | (car str)
887 | (current-input-port)))))
888 | (if (eof-object? c) 'nil c))))
889 |
890 |
891 | (xdef readb (lambda str
892 | (let ((c (read-byte (if (pair? str)
893 | (car str)
894 | (current-input-port)))))
895 | (if (eof-object? c) 'nil c))))
896 |
897 | (xdef peekc (lambda str
898 | (let ((c (peek-char (if (pair? str)
899 | (car str)
900 | (current-input-port)))))
901 | (if (eof-object? c) 'nil c))))
902 |
903 | (xdef writec (lambda (c . args)
904 | (write-char c
905 | (if (pair? args)
906 | (car args)
907 | (current-output-port)))
908 | c))
909 |
910 | (xdef writeb (lambda (b . args)
911 | (write-byte b
912 | (if (pair? args)
913 | (car args)
914 | (current-output-port)))
915 | b))
916 |
917 | (define explicit-flush #f)
918 |
919 | (define (printwith f args)
920 | (let ((port (if (> (length args) 1)
921 | (cadr args)
922 | (current-output-port))))
923 | (when (pair? args)
924 | (f (ac-denil (car args)) port))
925 | (unless explicit-flush (flush-output port)))
926 | 'nil)
927 |
928 | (xdef write (lambda args (printwith write args)))
929 | (xdef disp (lambda args (printwith display args)))
930 |
931 | ; sread = scheme read. eventually replace by writing read
932 |
933 | (xdef sread (lambda (p eof)
934 | (let ((expr (read p)))
935 | (if (eof-object? expr) eof expr))))
936 |
937 | ; these work in PLT but not scheme48
938 |
939 | (define char->ascii char->integer)
940 | (define ascii->char integer->char)
941 |
942 | (define (iround x) (inexact->exact (round x)))
943 |
944 | (define (ar-coerce x type . args)
945 | (cond
946 | ((ar-tagged? x) (err "Can't coerce annotated object"))
947 | ((eqv? type (ar-type x)) x)
948 | ((char? x) (case type
949 | ((int) (char->ascii x))
950 | ((string) (string x))
951 | ((sym) (string->symbol (string x)))
952 | (else (err "Can't coerce" x type))))
953 | ((integer? x) (case type
954 | ((num) x)
955 | ((char) (ascii->char x))
956 | ((string) (apply number->string x args))
957 | (else (err "Can't coerce" x type))))
958 | ((number? x) (case type
959 | ((int) (iround x))
960 | ((char) (ascii->char (iround x)))
961 | ((string) (apply number->string x args))
962 | (else (err "Can't coerce" x type))))
963 | ((string? x) (case type
964 | ((sym) (string->symbol x))
965 | ((cons) (ac-niltree (string->list x)))
966 | ((num) (or (apply string->number x args)
967 | (err "Can't coerce" x type)))
968 | ((int) (let ((n (apply string->number x args)))
969 | (if n
970 | (iround n)
971 | (err "Can't coerce" x type))))
972 | (else (err "Can't coerce" x type))))
973 | ((pair? x) (case type
974 | ((string) (apply string-append
975 | (map (lambda (y) (ar-coerce y 'string))
976 | (ar-nil-terminate x))))
977 | (else (err "Can't coerce" x type))))
978 | ((eqv? x 'nil) (case type
979 | ((string) "")
980 | (else (err "Can't coerce" x type))))
981 | ((null? x) (case type
982 | ((string) "")
983 | (else (err "Can't coerce" x type))))
984 | ((symbol? x) (case type
985 | ((string) (symbol->string x))
986 | (else (err "Can't coerce" x type))))
987 | (#t x)))
988 |
989 | (xdef coerce ar-coerce)
990 |
991 | (xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
992 |
993 | ; the 2050 means http requests currently capped at 2 meg
994 | ; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
995 |
996 | (xdef socket-accept (lambda (s)
997 | (let ((oc (current-custodian))
998 | (nc (make-custodian)))
999 | (current-custodian nc)
1000 | (call-with-values
1001 | (lambda () (tcp-accept s))
1002 | (lambda (in out)
1003 | (let ((in1 (make-limited-input-port in 100000 #t)))
1004 | (current-custodian oc)
1005 | (associate-custodian nc in1 out)
1006 | (list in1
1007 | out
1008 | (let-values (((us them) (tcp-addresses out)))
1009 | them))))))))
1010 |
1011 | (xdef new-thread thread)
1012 | (xdef kill-thread kill-thread)
1013 | (xdef break-thread break-thread)
1014 | (xdef current-thread current-thread)
1015 |
1016 | (define (wrapnil f) (lambda args (apply f args) 'nil))
1017 |
1018 | (xdef sleep (wrapnil sleep))
1019 |
1020 | ; Will system "execute" a half-finished string if thread killed
1021 | ; in the middle of generating it?
1022 |
1023 | (xdef system (wrapnil system))
1024 |
1025 | (xdef pipe-from (lambda (cmd)
1026 | (let ((tf (ar-tmpname)))
1027 | (system (string-append cmd " > " tf))
1028 | (let ((str (open-input-file tf)))
1029 | (system (string-append "rm -f " tf))
1030 | str))))
1031 |
1032 | (define (ar-tmpname)
1033 | (call-with-input-file "/dev/urandom"
1034 | (lambda (rstr)
1035 | (do ((s "/tmp/")
1036 | (c (read-char rstr) (read-char rstr))
1037 | (i 0 (+ i 1)))
1038 | ((>= i 16) s)
1039 | (set! s (string-append s
1040 | (string
1041 | (integer->char
1042 | (+ (char->integer #\a)
1043 | (modulo
1044 | (char->integer (read-char rstr))
1045 | 26))))))))))
1046 |
1047 | ; PLT scheme provides only eq? and equal? hash tables,
1048 | ; we need the latter for strings.
1049 |
1050 | (xdef table (lambda args
1051 | (let ((h (make-hash-table 'equal)))
1052 | (if (pair? args) ((car args) h))
1053 | h)))
1054 |
1055 | ;(xdef table (lambda args
1056 | ; (fill-table (make-hash-table 'equal)
1057 | ; (if (pair? args) (ac-denil (car args)) '()))))
1058 |
1059 | (define (fill-table h pairs)
1060 | (if (eq? pairs '())
1061 | h
1062 | (let ((pair (car pairs)))
1063 | (begin (hash-table-put! h (car pair) (cadr pair))
1064 | (fill-table h (cdr pairs))))))
1065 |
1066 | (xdef maptable (lambda (fn table) ; arg is (fn (key value) ...)
1067 | (hash-table-for-each table fn)
1068 | table))
1069 |
1070 | (define (protect during after)
1071 | (dynamic-wind (lambda () #t) during after))
1072 |
1073 | (xdef protect protect)
1074 |
1075 | ; need to use a better seed
1076 |
1077 | (xdef rand random)
1078 |
1079 | (xdef dir (lambda (name)
1080 | (ac-niltree (map path->string (directory-list name)))))
1081 |
1082 | ; Would def mkdir in terms of make-directory and call that instead
1083 | ; of system in ensure-dir, but make-directory is too weak: it doesn't
1084 | ; create intermediate directories like mkdir -p.
1085 |
1086 | (xdef file-exists (lambda (name)
1087 | (if (file-exists? name) name 'nil)))
1088 |
1089 | (xdef dir-exists (lambda (name)
1090 | (if (directory-exists? name) name 'nil)))
1091 |
1092 | (xdef rmfile (wrapnil delete-file))
1093 |
1094 | (xdef mvfile (lambda (old new)
1095 | (rename-file-or-directory old new #t)
1096 | 'nil))
1097 |
1098 | ; top level read-eval-print
1099 | ; tle kept as a way to get a break loop when a scheme err
1100 |
1101 | (define (arc-eval expr)
1102 | (eval (ac expr '())))
1103 |
1104 | (define (tle)
1105 | (display "Arc> ")
1106 | (let ((expr (read)))
1107 | (when (not (eqv? expr ':a))
1108 | (write (arc-eval expr))
1109 | (newline)
1110 | (tle))))
1111 |
1112 | (define last-condition* #f)
1113 |
1114 | (define (tl)
1115 | (display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
1116 | (tl2))
1117 |
1118 | (define (tl2)
1119 | (display "arc> ")
1120 | (on-err (lambda (c)
1121 | (set! last-condition* c)
1122 | (display "Error: ")
1123 | (write (exn-message c))
1124 | (newline)
1125 | (tl2))
1126 | (lambda ()
1127 | (let ((expr (read)))
1128 | (if (eqv? expr ':a)
1129 | 'done
1130 | (let ((val (arc-eval expr)))
1131 | (write (ac-denil val))
1132 | (namespace-set-variable-value! '_that val)
1133 | (namespace-set-variable-value! '_thatexpr expr)
1134 | (newline)
1135 | (tl2)))))))
1136 |
1137 | (define (aload1 p)
1138 | (let ((x (read p)))
1139 | (if (eof-object? x)
1140 | #t
1141 | (begin
1142 | (arc-eval x)
1143 | (aload1 p)))))
1144 |
1145 | (define (atests1 p)
1146 | (let ((x (read p)))
1147 | (if (eof-object? x)
1148 | #t
1149 | (begin
1150 | (write x)
1151 | (newline)
1152 | (let ((v (arc-eval x)))
1153 | (if (ar-false? v)
1154 | (begin
1155 | (display " FAILED")
1156 | (newline))))
1157 | (atests1 p)))))
1158 |
1159 | (define (aload filename)
1160 | (call-with-input-file filename aload1))
1161 |
1162 | (define (test filename)
1163 | (call-with-input-file filename atests1))
1164 |
1165 | (define (acompile1 ip op)
1166 | (let ((x (read ip)))
1167 | (if (eof-object? x)
1168 | #t
1169 | (let ((scm (ac x '())))
1170 | (eval scm)
1171 | (pretty-print scm op)
1172 | (newline op)
1173 | (newline op)
1174 | (acompile1 ip op)))))
1175 |
1176 | ; compile xx.arc to xx.arc.scm
1177 | ; useful to examine the Arc compiler output
1178 | (define (acompile inname)
1179 | (let ((outname (string-append inname ".scm")))
1180 | (if (file-exists? outname)
1181 | (delete-file outname))
1182 | (call-with-input-file inname
1183 | (lambda (ip)
1184 | (call-with-output-file outname
1185 | (lambda (op)
1186 | (acompile1 ip op)))))))
1187 |
1188 | (xdef macex (lambda (e) (ac-macex (ac-denil e))))
1189 |
1190 | (xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
1191 |
1192 | (xdef eval (lambda (e)
1193 | (eval (ac (ac-denil e) '()))))
1194 |
1195 | ; If an err occurs in an on-err expr, no val is returned and code
1196 | ; after it doesn't get executed. Not quite what I had in mind.
1197 |
1198 | (define (on-err errfn f)
1199 | ((call-with-current-continuation
1200 | (lambda (k)
1201 | (lambda ()
1202 | (with-handlers ((exn:fail? (lambda (c)
1203 | (k (lambda () (errfn c))))))
1204 | (f)))))))
1205 | (xdef on-err on-err)
1206 |
1207 | (define (disp-to-string x)
1208 | (let ((o (open-output-string)))
1209 | (display x o)
1210 | (close-output-port o)
1211 | (get-output-string o)))
1212 |
1213 | (xdef details (lambda (c)
1214 | (disp-to-string (exn-message c))))
1215 |
1216 | (xdef scar (lambda (x val)
1217 | (if (string? x)
1218 | (string-set! x 0 val)
1219 | (set-car! x val))
1220 | val))
1221 |
1222 | (xdef scdr (lambda (x val)
1223 | (if (string? x)
1224 | (err "Can't set cdr of a string" x)
1225 | (set-cdr! x val))
1226 | val))
1227 |
1228 | ; When and if cdr of a string returned an actual (eq) tail, could
1229 | ; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
1230 | ; for now would be misleading to allow this, because fails for cddr.
1231 |
1232 | (define (string-replace! str val index)
1233 | (if (eqv? (string-length val) (- (string-length str) index))
1234 | (do ((i index (+ i 1)))
1235 | ((= i (string-length str)) str)
1236 | (string-set! str i (string-ref val (- i index))))
1237 | (err "Length mismatch between strings" str val index)))
1238 |
1239 | ; Later may want to have multiple indices.
1240 |
1241 | (xdef sref
1242 | (lambda (com val ind)
1243 | (cond ((hash-table? com) (if (eqv? val 'nil)
1244 | (hash-table-remove! com ind)
1245 | (hash-table-put! com ind val)))
1246 | ((string? com) (string-set! com ind val))
1247 | ((pair? com) (nth-set! com ind val))
1248 | (#t (err "Can't set reference " com ind val)))
1249 | val))
1250 |
1251 | (define (nth-set! lst n val)
1252 | (set-car! (list-tail lst n) val))
1253 |
1254 | ; rewrite to pass a (true) gensym instead of #f in case var bound to #f
1255 |
1256 | (define (bound? arcname)
1257 | (namespace-variable-value (ac-global-name arcname)
1258 | #t
1259 | (lambda () #f)))
1260 |
1261 | (xdef bound (lambda (x) (tnil (bound? x))))
1262 |
1263 | (xdef newstring make-string)
1264 |
1265 | (xdef trunc (lambda (x) (inexact->exact (truncate x))))
1266 |
1267 | (xdef exact (lambda (x)
1268 | (tnil (and (integer? x) (exact? x)))))
1269 |
1270 | (xdef msec current-milliseconds)
1271 | (xdef current-process-milliseconds current-process-milliseconds)
1272 | (xdef current-gc-milliseconds current-gc-milliseconds)
1273 |
1274 | (xdef seconds current-seconds)
1275 |
1276 | (print-hash-table #t)
1277 |
1278 | (xdef client-ip (lambda (port)
1279 | (let-values (((x y) (tcp-addresses port)))
1280 | y)))
1281 |
1282 | ; make sure only one thread at a time executes anything
1283 | ; inside an atomic-invoke. atomic-invoke is allowed to
1284 | ; nest within a thread; the thread-cell keeps track of
1285 | ; whether this thread already holds the lock.
1286 |
1287 | (define ar-the-sema (make-semaphore 1))
1288 |
1289 | (define ar-sema-cell (make-thread-cell #f))
1290 |
1291 | (xdef atomic-invoke (lambda (f)
1292 | (if (thread-cell-ref ar-sema-cell)
1293 | (ar-apply f '())
1294 | (begin
1295 | (thread-cell-set! ar-sema-cell #t)
1296 | (protect
1297 | (lambda ()
1298 | (call-with-semaphore
1299 | ar-the-sema
1300 | (lambda () (ar-apply f '()))))
1301 | (lambda ()
1302 | (thread-cell-set! ar-sema-cell #f)))))))
1303 |
1304 | (xdef dead (lambda (x) (tnil (thread-dead? x))))
1305 |
1306 | ; Added because Mzscheme buffers output. Not a permanent part of Arc.
1307 | ; Only need to use when declare explicit-flush optimization.
1308 |
1309 | (xdef flushout (lambda () (flush-output) 't))
1310 |
1311 | (xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
1312 |
1313 | (xdef ssexpand (lambda (x)
1314 | (if (symbol? x) (expand-ssyntax x) x)))
1315 |
1316 | (xdef quit exit)
1317 |
1318 | ; there are two ways to close a TCP output port.
1319 | ; (close o) waits for output to drain, then closes UNIX descriptor.
1320 | ; (force-close o) discards buffered output, then closes UNIX desc.
1321 | ; web servers need the latter to get rid of connections to
1322 | ; clients that are not reading data.
1323 | ; mzscheme close-output-port doesn't work (just raises an error)
1324 | ; if there is buffered output for a non-responsive socket.
1325 | ; must use custodian-shutdown-all instead.
1326 |
1327 | (define custodians (make-hash-table 'equal))
1328 |
1329 | (define (associate-custodian c i o)
1330 | (hash-table-put! custodians i c)
1331 | (hash-table-put! custodians o c))
1332 |
1333 | ; if a port has a custodian, use it to close the port forcefully.
1334 | ; also get rid of the reference to the custodian.
1335 | ; sadly doing this to the input port also kills the output port.
1336 |
1337 | (define (try-custodian p)
1338 | (let ((c (hash-table-get custodians p #f)))
1339 | (if c
1340 | (begin
1341 | (custodian-shutdown-all c)
1342 | (hash-table-remove! custodians p)
1343 | #t)
1344 | #f)))
1345 |
1346 | (define (ar-close . args)
1347 | (map (lambda (p)
1348 | (cond ((input-port? p) (close-input-port p))
1349 | ((output-port? p) (close-output-port p))
1350 | ((tcp-listener? p) (tcp-close p))
1351 | (#t (err "Can't close " p))))
1352 | args)
1353 | (map (lambda (p) (try-custodian p)) args) ; free any custodian
1354 | 'nil)
1355 |
1356 | (xdef close ar-close)
1357 |
1358 | (xdef force-close (lambda args
1359 | (map (lambda (p)
1360 | (if (not (try-custodian p))
1361 | (ar-close p)))
1362 | args)
1363 | 'nil))
1364 |
1365 | (xdef memory current-memory-use)
1366 |
1367 | (xdef declare (lambda (key val)
1368 | (let ((flag (not (ar-false? val))))
1369 | (case key
1370 | ((atstrings) (set! atstrings flag))
1371 | ((direct-calls) (set! direct-calls flag))
1372 | ((explicit-flush) (set! explicit-flush flag)))
1373 | val)))
1374 |
1375 | (putenv "TZ" ":GMT")
1376 |
1377 | (define (gmt-date sec) (seconds->date sec))
1378 |
1379 | (xdef timedate
1380 | (lambda args
1381 | (let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
1382 | (ac-niltree (list (date-second d)
1383 | (date-minute d)
1384 | (date-hour d)
1385 | (date-day d)
1386 | (date-month d)
1387 | (date-year d))))))
1388 |
1389 | (xdef sin sin)
1390 | (xdef cos cos)
1391 | (xdef tan tan)
1392 | (xdef asin asin)
1393 | (xdef acos acos)
1394 | (xdef atan atan)
1395 | (xdef log log)
1396 |
1397 | (define (codestring s)
1398 | (let ((i (atpos s 0)))
1399 | (if i
1400 | (cons (substring s 0 i)
1401 | (let* ((rest (substring s (+ i 1)))
1402 | (in (open-input-string rest))
1403 | (expr (read in))
1404 | (i2 (let-values (((x y z) (port-next-location in))) z)))
1405 | (close-input-port in)
1406 | (cons expr (codestring (substring rest (- i2 1))))))
1407 | (list s))))
1408 |
1409 | ; First unescaped @ in s, if any. Escape by doubling.
1410 |
1411 | (define (atpos s i)
1412 | (cond ((eqv? i (string-length s))
1413 | #f)
1414 | ((eqv? (string-ref s i) #\@)
1415 | (if (and (< (+ i 1) (string-length s))
1416 | (not (eqv? (string-ref s (+ i 1)) #\@)))
1417 | i
1418 | (atpos s (+ i 2))))
1419 | (#t
1420 | (atpos s (+ i 1)))))
1421 |
1422 | (define (unescape-ats s)
1423 | (list->string (letrec ((unesc (lambda (cs)
1424 | (cond
1425 | ((null? cs)
1426 | '())
1427 | ((and (eqv? (car cs) #\@)
1428 | (not (null? (cdr cs)))
1429 | (eqv? (cadr cs) #\@))
1430 | (unesc (cdr cs)))
1431 | (#t
1432 | (cons (car cs) (unesc (cdr cs))))))))
1433 | (unesc (string->list s)))))
1434 |
1435 | )
1436 |
1437 |
--------------------------------------------------------------------------------
/arc.arc:
--------------------------------------------------------------------------------
1 | ; Main Arc lib. Ported to Scheme version Jul 06.
2 |
3 | ; don't like names of conswhen and consif
4 |
5 | ; need better way of generating strings; too many calls to string
6 | ; maybe strings with escape char for evaluation
7 | ; make foo~bar equiv of foo:~bar (in expand-ssyntax)
8 | ; add sigs of ops defined in ac.scm
9 | ; get hold of error types within arc
10 | ; does macex have to be defined in scheme instead of using def below?
11 | ; write disp, read, write in arc
12 | ; could I get all of macros up into arc.arc?
13 | ; warn when shadow a global name
14 | ; some simple regexp/parsing plan
15 |
16 | ; compromises in this implementation:
17 | ; no objs in code
18 | ; (mac testlit args (listtab args)) breaks when called
19 | ; separate string type
20 | ; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
21 | ; not sure this is a mistake; strings may be subtly different from
22 | ; lists of chars
23 |
24 |
25 | (assign do (annotate 'mac
26 | (fn args `((fn () ,@args)))))
27 |
28 | (assign safeset (annotate 'mac
29 | (fn (var val)
30 | `(do (if (bound ',var)
31 | (do (disp "*** redefining " (stderr))
32 | (disp ',var (stderr))
33 | (disp #\newline (stderr))))
34 | (assign ,var ,val)))))
35 |
36 | (assign def (annotate 'mac
37 | (fn (name parms . body)
38 | `(do (sref sig ',parms ',name)
39 | (safeset ,name (fn ,parms ,@body))))))
40 |
41 | (def caar (xs) (car (car xs)))
42 | (def cadr (xs) (car (cdr xs)))
43 | (def cddr (xs) (cdr (cdr xs)))
44 |
45 | (def no (x) (is x nil))
46 |
47 | (def acons (x) (is (type x) 'cons))
48 |
49 | (def atom (x) (no (acons x)))
50 |
51 | ; Can return to this def once Rtm gets ac to make all rest args
52 | ; nil-terminated lists.
53 |
54 | ; (def list args args)
55 |
56 | (def copylist (xs)
57 | (if (no xs)
58 | nil
59 | (cons (car xs) (copylist (cdr xs)))))
60 |
61 | (def list args (copylist args))
62 |
63 | (def idfn (x) x)
64 |
65 | ; Maybe later make this internal. Useful to let xs be a fn?
66 |
67 | (def map1 (f xs)
68 | (if (no xs)
69 | nil
70 | (cons (f (car xs)) (map1 f (cdr xs)))))
71 |
72 | (def pair (xs (o f list))
73 | (if (no xs)
74 | nil
75 | (no (cdr xs))
76 | (list (list (car xs)))
77 | (cons (f (car xs) (cadr xs))
78 | (pair (cddr xs) f))))
79 |
80 | (assign mac (annotate 'mac
81 | (fn (name parms . body)
82 | `(do (sref sig ',parms ',name)
83 | (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
84 |
85 | (mac and args
86 | (if args
87 | (if (cdr args)
88 | `(if ,(car args) (and ,@(cdr args)))
89 | (car args))
90 | 't))
91 |
92 | (def assoc (key al)
93 | (if (atom al)
94 | nil
95 | (and (acons (car al)) (is (caar al) key))
96 | (car al)
97 | (assoc key (cdr al))))
98 |
99 | (def alref (al key) (cadr (assoc key al)))
100 |
101 | (mac with (parms . body)
102 | `((fn ,(map1 car (pair parms))
103 | ,@body)
104 | ,@(map1 cadr (pair parms))))
105 |
106 | (mac let (var val . body)
107 | `(with (,var ,val) ,@body))
108 |
109 | (mac withs (parms . body)
110 | (if (no parms)
111 | `(do ,@body)
112 | `(let ,(car parms) ,(cadr parms)
113 | (withs ,(cddr parms) ,@body))))
114 |
115 | ; Rtm prefers to overload + to do this
116 |
117 | (def join args
118 | (if (no args)
119 | nil
120 | (let a (car args)
121 | (if (no a)
122 | (apply join (cdr args))
123 | (cons (car a) (apply join (cdr a) (cdr args)))))))
124 |
125 | ; Need rfn for use in macro expansions.
126 |
127 | (mac rfn (name parms . body)
128 | `(let ,name nil
129 | (assign ,name (fn ,parms ,@body))))
130 |
131 | (mac afn (parms . body)
132 | `(let self nil
133 | (assign self (fn ,parms ,@body))))
134 |
135 | ; Ac expands x:y:z into (compose x y z), ~x into (complement x)
136 |
137 | ; Only used when the call to compose doesn't occur in functional position.
138 | ; Composes in functional position are transformed away by ac.
139 |
140 | (mac compose args
141 | (let g (uniq)
142 | `(fn ,g
143 | ,((afn (fs)
144 | (if (cdr fs)
145 | (list (car fs) (self (cdr fs)))
146 | `(apply ,(if (car fs) (car fs) 'idfn) ,g)))
147 | args))))
148 |
149 | ; Ditto: complement in functional position optimized by ac.
150 |
151 | (mac complement (f)
152 | (let g (uniq)
153 | `(fn ,g (no (apply ,f ,g)))))
154 |
155 | (def rev (xs)
156 | ((afn (xs acc)
157 | (if (no xs)
158 | acc
159 | (self (cdr xs) (cons (car xs) acc))))
160 | xs nil))
161 |
162 | (def isnt (x y) (no (is x y)))
163 |
164 | (mac w/uniq (names . body)
165 | (if (acons names)
166 | `(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
167 | names))
168 | ,@body)
169 | `(let ,names (uniq) ,@body)))
170 |
171 | (mac or args
172 | (and args
173 | (w/uniq g
174 | `(let ,g ,(car args)
175 | (if ,g ,g (or ,@(cdr args)))))))
176 |
177 | (def alist (x) (or (no x) (is (type x) 'cons)))
178 |
179 | (mac in (x . choices)
180 | (w/uniq g
181 | `(let ,g ,x
182 | (or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
183 |
184 | ; Could take n args, but have never once needed that.
185 |
186 | (def iso (x y)
187 | (or (is x y)
188 | (and (acons x)
189 | (acons y)
190 | (iso (car x) (car y))
191 | (iso (cdr x) (cdr y)))))
192 |
193 | (mac when (test . body)
194 | `(if ,test (do ,@body)))
195 |
196 | (mac unless (test . body)
197 | `(if (no ,test) (do ,@body)))
198 |
199 | (mac while (test . body)
200 | (w/uniq (gf gp)
201 | `((rfn ,gf (,gp)
202 | (when ,gp ,@body (,gf ,test)))
203 | ,test)))
204 |
205 | (def empty (seq)
206 | (or (no seq)
207 | (and (no (acons seq)) (is (len seq) 0))))
208 |
209 | (def reclist (f xs)
210 | (and xs (or (f xs) (reclist f (cdr xs)))))
211 |
212 | (def recstring (test s (o start 0))
213 | ((afn (i)
214 | (and (< i (len s))
215 | (or (test i)
216 | (self (+ i 1)))))
217 | start))
218 |
219 | (def testify (x)
220 | (if (isa x 'fn) x [is _ x]))
221 |
222 | ; Like keep, seems like some shouldn't testify. But find should,
223 | ; and all probably should.
224 |
225 | (def some (test seq)
226 | (let f (testify test)
227 | (if (alist seq)
228 | (reclist f:car seq)
229 | (recstring f:seq seq))))
230 |
231 | (def all (test seq)
232 | (~some (complement (testify test)) seq))
233 |
234 | (def mem (test seq)
235 | (let f (testify test)
236 | (reclist [if (f:car _) _] seq)))
237 |
238 | (def find (test seq)
239 | (let f (testify test)
240 | (if (alist seq)
241 | (reclist [if (f:car _) (car _)] seq)
242 | (recstring [if (f:seq _) (seq _)] seq))))
243 |
244 | (def isa (x y) (is (type x) y))
245 |
246 | ; Possible to write map without map1, but makes News 3x slower.
247 |
248 | ;(def map (f . seqs)
249 | ; (if (some1 no seqs)
250 | ; nil
251 | ; (no (cdr seqs))
252 | ; (let s1 (car seqs)
253 | ; (cons (f (car s1))
254 | ; (map f (cdr s1))))
255 | ; (cons (apply f (map car seqs))
256 | ; (apply map f (map cdr seqs)))))
257 |
258 |
259 | (def map (f . seqs)
260 | (if (some [isa _ 'string] seqs)
261 | (withs (n (apply min (map len seqs))
262 | new (newstring n))
263 | ((afn (i)
264 | (if (is i n)
265 | new
266 | (do (sref new (apply f (map [_ i] seqs)) i)
267 | (self (+ i 1)))))
268 | 0))
269 | (no (cdr seqs))
270 | (map1 f (car seqs))
271 | ((afn (seqs)
272 | (if (some no seqs)
273 | nil
274 | (cons (apply f (map1 car seqs))
275 | (self (map1 cdr seqs)))))
276 | seqs)))
277 |
278 | (def mappend (f . args)
279 | (apply + nil (apply map f args)))
280 |
281 | (def firstn (n xs)
282 | (if (no n) xs
283 | (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs)))
284 | nil))
285 |
286 | (def nthcdr (n xs)
287 | (if (no n) xs
288 | (> n 0) (nthcdr (- n 1) (cdr xs))
289 | xs))
290 |
291 | ; Generalization of pair: (tuples x) = (pair x)
292 |
293 | (def tuples (xs (o n 2))
294 | (if (no xs)
295 | nil
296 | (cons (firstn n xs)
297 | (tuples (nthcdr n xs) n))))
298 |
299 | ; If ok to do with =, why not with def? But see if use it.
300 |
301 | (mac defs args
302 | `(do ,@(map [cons 'def _] (tuples args 3))))
303 |
304 | (def caris (x val)
305 | (and (acons x) (is (car x) val)))
306 |
307 | (def warn (msg . args)
308 | (disp (+ "Warning: " msg ". "))
309 | (map [do (write _) (disp " ")] args)
310 | (disp #\newline))
311 |
312 | (mac atomic body
313 | `(atomic-invoke (fn () ,@body)))
314 |
315 | (mac atlet args
316 | `(atomic (let ,@args)))
317 |
318 | (mac atwith args
319 | `(atomic (with ,@args)))
320 |
321 | (mac atwiths args
322 | `(atomic (withs ,@args)))
323 |
324 |
325 | ; setforms returns (vars get set) for a place based on car of an expr
326 | ; vars is a list of gensyms alternating with expressions whose vals they
327 | ; should be bound to, suitable for use as first arg to withs
328 | ; get is an expression returning the current value in the place
329 | ; set is an expression representing a function of one argument
330 | ; that stores a new value in the place
331 |
332 | ; A bit gross that it works based on the *name* in the car, but maybe
333 | ; wrong to worry. Macros live in expression land.
334 |
335 | ; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
336 | ; can't in cl though. could I define a setter for push or pop?
337 |
338 | (assign setter (table))
339 |
340 | (mac defset (name parms . body)
341 | (w/uniq gexpr
342 | `(sref setter
343 | (fn (,gexpr)
344 | (let ,parms (cdr ,gexpr)
345 | ,@body))
346 | ',name)))
347 |
348 | (defset car (x)
349 | (w/uniq g
350 | (list (list g x)
351 | `(car ,g)
352 | `(fn (val) (scar ,g val)))))
353 |
354 | (defset cdr (x)
355 | (w/uniq g
356 | (list (list g x)
357 | `(cdr ,g)
358 | `(fn (val) (scdr ,g val)))))
359 |
360 | (defset caar (x)
361 | (w/uniq g
362 | (list (list g x)
363 | `(caar ,g)
364 | `(fn (val) (scar (car ,g) val)))))
365 |
366 | (defset cadr (x)
367 | (w/uniq g
368 | (list (list g x)
369 | `(cadr ,g)
370 | `(fn (val) (scar (cdr ,g) val)))))
371 |
372 | (defset cddr (x)
373 | (w/uniq g
374 | (list (list g x)
375 | `(cddr ,g)
376 | `(fn (val) (scdr (cdr ,g) val)))))
377 |
378 | ; Note: if expr0 macroexpands into any expression whose car doesn't
379 | ; have a setter, setforms assumes it's a data structure in functional
380 | ; position. Such bugs will be seen only when the code is executed, when
381 | ; sref complains it can't set a reference to a function.
382 |
383 | (def setforms (expr0)
384 | (let expr (macex expr0)
385 | (if (isa expr 'sym)
386 | (if (ssyntax expr)
387 | (setforms (ssexpand expr))
388 | (w/uniq (g h)
389 | (list (list g expr)
390 | g
391 | `(fn (,h) (assign ,expr ,h)))))
392 | ; make it also work for uncompressed calls to compose
393 | (and (acons expr) (metafn (car expr)))
394 | (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))
395 | (and (acons expr) (acons (car expr)) (is (caar expr) 'get))
396 | (setforms (list (cadr expr) (cadr (car expr))))
397 | (let f (setter (car expr))
398 | (if f
399 | (f expr)
400 | ; assumed to be data structure in fn position
401 | (do (when (caris (car expr) 'fn)
402 | (warn "Inverting what looks like a function call"
403 | expr0 expr))
404 | (w/uniq (g h)
405 | (let argsyms (map [uniq] (cdr expr))
406 | (list (+ (list g (car expr))
407 | (mappend list argsyms (cdr expr)))
408 | `(,g ,@argsyms)
409 | `(fn (,h) (sref ,g ,h ,(car argsyms))))))))))))
410 |
411 | (def metafn (x)
412 | (or (ssyntax x)
413 | (and (acons x) (in (car x) 'compose 'complement))))
414 |
415 | (def expand-metafn-call (f args)
416 | (if (is (car f) 'compose)
417 | ((afn (fs)
418 | (if (caris (car fs) 'compose) ; nested compose
419 | (self (join (cdr (car fs)) (cdr fs)))
420 | (cdr fs)
421 | (list (car fs) (self (cdr fs)))
422 | (cons (car fs) args)))
423 | (cdr f))
424 | (is (car f) 'no)
425 | (err "Can't invert " (cons f args))
426 | (cons f args)))
427 |
428 | (def expand= (place val)
429 | (if (and (isa place 'sym) (~ssyntax place))
430 | `(assign ,place ,val)
431 | (let (vars prev setter) (setforms place)
432 | (w/uniq g
433 | `(atwith ,(+ vars (list g val))
434 | (,setter ,g))))))
435 |
436 | (def expand=list (terms)
437 | `(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _]
438 | (pair terms))))
439 |
440 | (mac = args
441 | (expand=list args))
442 |
443 | (mac loop (start test update . body)
444 | (w/uniq (gfn gparm)
445 | `(do ,start
446 | ((rfn ,gfn (,gparm)
447 | (if ,gparm
448 | (do ,@body ,update (,gfn ,test))))
449 | ,test))))
450 |
451 | (mac for (v init max . body)
452 | (w/uniq (gi gm)
453 | `(with (,v nil ,gi ,init ,gm (+ ,max 1))
454 | (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
455 | ,@body))))
456 |
457 | (mac down (v init min . body)
458 | (w/uniq (gi gm)
459 | `(with (,v nil ,gi ,init ,gm (- ,min 1))
460 | (loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1))
461 | ,@body))))
462 |
463 | (mac repeat (n . body)
464 | `(for ,(uniq) 1 ,n ,@body))
465 |
466 | ; could bind index instead of gensym
467 |
468 | (mac each (var expr . body)
469 | (w/uniq (gseq gf gv)
470 | `(let ,gseq ,expr
471 | (if (alist ,gseq)
472 | ((rfn ,gf (,gv)
473 | (when (acons ,gv)
474 | (let ,var (car ,gv) ,@body)
475 | (,gf (cdr ,gv))))
476 | ,gseq)
477 | (isa ,gseq 'table)
478 | (maptable (fn ,var ,@body)
479 | ,gseq)
480 | (for ,gv 0 (- (len ,gseq) 1)
481 | (let ,var (,gseq ,gv) ,@body))))))
482 |
483 | ; (nthcdr x y) = (cut y x).
484 |
485 | (def cut (seq start (o end))
486 | (let end (if (no end) (len seq)
487 | (< end 0) (+ (len seq) end)
488 | end)
489 | (if (isa seq 'string)
490 | (let s2 (newstring (- end start))
491 | (for i 0 (- end start 1)
492 | (= (s2 i) (seq (+ start i))))
493 | s2)
494 | (firstn (- end start) (nthcdr start seq)))))
495 |
496 | (mac whilet (var test . body)
497 | (w/uniq (gf gp)
498 | `((rfn ,gf (,gp)
499 | (let ,var ,gp
500 | (when ,var ,@body (,gf ,test))))
501 | ,test)))
502 |
503 | (def last (xs)
504 | (if (cdr xs)
505 | (last (cdr xs))
506 | (car xs)))
507 |
508 | (def rem (test seq)
509 | (let f (testify test)
510 | (if (alist seq)
511 | ((afn (s)
512 | (if (no s) nil
513 | (f (car s)) (self (cdr s))
514 | (cons (car s) (self (cdr s)))))
515 | seq)
516 | (coerce (rem test (coerce seq 'cons)) 'string))))
517 |
518 | ; Seems like keep doesn't need to testify-- would be better to
519 | ; be able to use tables as fns. But rem does need to, because
520 | ; often want to rem a table from a list. So maybe the right answer
521 | ; is to make keep the more primitive, not rem.
522 |
523 | (def keep (test seq)
524 | (rem (complement (testify test)) seq))
525 |
526 | ;(def trues (f seq)
527 | ; (rem nil (map f seq)))
528 |
529 | (def trues (f xs)
530 | (and xs
531 | (let fx (f (car xs))
532 | (if fx
533 | (cons fx (trues f (cdr xs)))
534 | (trues f (cdr xs))))))
535 |
536 | (mac do1 args
537 | (w/uniq g
538 | `(let ,g ,(car args)
539 | ,@(cdr args)
540 | ,g)))
541 |
542 | ; Would like to write a faster case based on table generated by a macro,
543 | ; but can't insert objects into expansions in Mzscheme.
544 |
545 | (mac caselet (var expr . args)
546 | (let ex (afn (args)
547 | (if (no (cdr args))
548 | (car args)
549 | `(if (is ,var ',(car args))
550 | ,(cadr args)
551 | ,(self (cddr args)))))
552 | `(let ,var ,expr ,(ex args))))
553 |
554 | (mac case (expr . args)
555 | `(caselet ,(uniq) ,expr ,@args))
556 |
557 | (mac push (x place)
558 | (w/uniq gx
559 | (let (binds val setter) (setforms place)
560 | `(let ,gx ,x
561 | (atwiths ,binds
562 | (,setter (cons ,gx ,val)))))))
563 |
564 | (mac swap (place1 place2)
565 | (w/uniq (g1 g2)
566 | (with ((binds1 val1 setter1) (setforms place1)
567 | (binds2 val2 setter2) (setforms place2))
568 | `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
569 | (,setter1 ,g2)
570 | (,setter2 ,g1)))))
571 |
572 | (mac rotate places
573 | (with (vars (map [uniq] places)
574 | forms (map setforms places))
575 | `(atwiths ,(mappend (fn (g (binds val setter))
576 | (+ binds (list g val)))
577 | vars
578 | forms)
579 | ,@(map (fn (g (binds val setter))
580 | (list setter g))
581 | (+ (cdr vars) (list (car vars)))
582 | forms))))
583 |
584 | (mac pop (place)
585 | (w/uniq g
586 | (let (binds val setter) (setforms place)
587 | `(atwiths ,(+ binds (list g val))
588 | (do1 (car ,g)
589 | (,setter (cdr ,g)))))))
590 |
591 | (def adjoin (x xs (o test iso))
592 | (if (some [test x _] xs)
593 | xs
594 | (cons x xs)))
595 |
596 | (mac pushnew (x place . args)
597 | (w/uniq gx
598 | (let (binds val setter) (setforms place)
599 | `(atwiths ,(+ (list gx x) binds)
600 | (,setter (adjoin ,gx ,val ,@args))))))
601 |
602 | (mac pull (test place)
603 | (w/uniq g
604 | (let (binds val setter) (setforms place)
605 | `(atwiths ,(+ (list g test) binds)
606 | (,setter (rem ,g ,val))))))
607 |
608 | (mac togglemem (x place . args)
609 | (w/uniq gx
610 | (let (binds val setter) (setforms place)
611 | `(atwiths ,(+ (list gx x) binds)
612 | (,setter (if (mem ,gx ,val)
613 | (rem ,gx ,val)
614 | (adjoin ,gx ,val ,@args)))))))
615 |
616 | (mac ++ (place (o i 1))
617 | (if (isa place 'sym)
618 | `(= ,place (+ ,place ,i))
619 | (w/uniq gi
620 | (let (binds val setter) (setforms place)
621 | `(atwiths ,(+ binds (list gi i))
622 | (,setter (+ ,val ,gi)))))))
623 |
624 | (mac -- (place (o i 1))
625 | (if (isa place 'sym)
626 | `(= ,place (- ,place ,i))
627 | (w/uniq gi
628 | (let (binds val setter) (setforms place)
629 | `(atwiths ,(+ binds (list gi i))
630 | (,setter (- ,val ,gi)))))))
631 |
632 | ; E.g. (++ x) equiv to (zap + x 1)
633 |
634 | (mac zap (op place . args)
635 | (with (gop (uniq)
636 | gargs (map [uniq] args)
637 | mix (afn seqs
638 | (if (some no seqs)
639 | nil
640 | (+ (map car seqs)
641 | (apply self (map cdr seqs))))))
642 | (let (binds val setter) (setforms place)
643 | `(atwiths ,(+ binds (list gop op) (mix gargs args))
644 | (,setter (,gop ,val ,@gargs))))))
645 |
646 | ; Can't simply mod pr to print strings represented as lists of chars,
647 | ; because empty string will get printed as nil. Would need to rep strings
648 | ; as lists of chars annotated with 'string, and modify car and cdr to get
649 | ; the rep of these. That would also require hacking the reader.
650 |
651 | (def pr args
652 | (map1 disp args)
653 | (car args))
654 |
655 | (def prt args
656 | (map1 [if _ (disp _)] args)
657 | (car args))
658 |
659 | (def prn args
660 | (do1 (apply pr args)
661 | (writec #\newline)))
662 |
663 | (mac wipe args
664 | `(do ,@(map (fn (a) `(= ,a nil)) args)))
665 |
666 | (mac set args
667 | `(do ,@(map (fn (a) `(= ,a t)) args)))
668 |
669 | ; Destructuring means ambiguity: are pat vars bound in else? (no)
670 |
671 | (mac iflet (var expr then . rest)
672 | (w/uniq gv
673 | `(let ,gv ,expr
674 | (if ,gv (let ,var ,gv ,then) ,@rest))))
675 |
676 | (mac whenlet (var expr . body)
677 | `(iflet ,var ,expr (do ,@body)))
678 |
679 | (mac aif (expr . body)
680 | `(let it ,expr
681 | (if it
682 | ,@(if (cddr body)
683 | `(,(car body) (aif ,@(cdr body)))
684 | body))))
685 |
686 | (mac awhen (expr . body)
687 | `(let it ,expr (if it (do ,@body))))
688 |
689 | (mac aand args
690 | (if (no args)
691 | 't
692 | (no (cdr args))
693 | (car args)
694 | `(let it ,(car args) (and it (aand ,@(cdr args))))))
695 |
696 | (mac accum (accfn . body)
697 | (w/uniq gacc
698 | `(withs (,gacc nil ,accfn [push _ ,gacc])
699 | ,@body
700 | (rev ,gacc))))
701 |
702 | ; Repeatedly evaluates its body till it returns nil, then returns vals.
703 |
704 | (mac drain (expr (o eof nil))
705 | (w/uniq (gacc gdone gres)
706 | `(with (,gacc nil ,gdone nil)
707 | (while (no ,gdone)
708 | (let ,gres ,expr
709 | (if (is ,gres ,eof)
710 | (= ,gdone t)
711 | (push ,gres ,gacc))))
712 | (rev ,gacc))))
713 |
714 | ; For the common C idiom while x = snarfdata != stopval.
715 | ; Rename this if use it often.
716 |
717 | (mac whiler (var expr endval . body)
718 | (w/uniq gf
719 | `(withs (,var nil ,gf (testify ,endval))
720 | (while (no (,gf (= ,var ,expr)))
721 | ,@body))))
722 |
723 | ;(def macex (e)
724 | ; (if (atom e)
725 | ; e
726 | ; (let op (and (atom (car e)) (eval (car e)))
727 | ; (if (isa op 'mac)
728 | ; (apply (rep op) (cdr e))
729 | ; e))))
730 |
731 | (def consif (x y) (if x (cons x y) y))
732 |
733 | (def string args
734 | (apply + "" (map [coerce _ 'string] args)))
735 |
736 | (def flat x
737 | ((afn (x acc)
738 | (if (no x) acc
739 | (atom x) (cons x acc)
740 | (self (car x) (self (cdr x) acc))))
741 | x nil))
742 |
743 | (mac check (x test (o alt))
744 | (w/uniq gx
745 | `(let ,gx ,x
746 | (if (,test ,gx) ,gx ,alt))))
747 |
748 | (def pos (test seq (o start 0))
749 | (let f (testify test)
750 | (if (alist seq)
751 | ((afn (seq n)
752 | (if (no seq)
753 | nil
754 | (f (car seq))
755 | n
756 | (self (cdr seq) (+ n 1))))
757 | (nthcdr start seq)
758 | start)
759 | (recstring [if (f (seq _)) _] seq start))))
760 |
761 | (def even (n) (is (mod n 2) 0))
762 |
763 | (def odd (n) (no (even n)))
764 |
765 | (mac after (x . ys)
766 | `(protect (fn () ,x) (fn () ,@ys)))
767 |
768 | (let expander
769 | (fn (f var name body)
770 | `(let ,var (,f ,name)
771 | (after (do ,@body) (close ,var))))
772 |
773 | (mac w/infile (var name . body)
774 | (expander 'infile var name body))
775 |
776 | (mac w/outfile (var name . body)
777 | (expander 'outfile var name body))
778 |
779 | (mac w/instring (var str . body)
780 | (expander 'instring var str body))
781 |
782 | (mac w/socket (var port . body)
783 | (expander 'open-socket var port body))
784 | )
785 |
786 | (mac w/outstring (var . body)
787 | `(let ,var (outstring) ,@body))
788 |
789 | ; what happens to a file opened for append if arc is killed in
790 | ; the middle of a write?
791 |
792 | (mac w/appendfile (var name . body)
793 | `(let ,var (outfile ,name 'append)
794 | (after (do ,@body) (close ,var))))
795 |
796 | ; rename this simply "to"? - prob not; rarely use
797 |
798 | (mac w/stdout (str . body)
799 | `(call-w/stdout ,str (fn () ,@body)))
800 |
801 | (mac w/stdin (str . body)
802 | `(call-w/stdin ,str (fn () ,@body)))
803 |
804 | (mac tostring body
805 | (w/uniq gv
806 | `(w/outstring ,gv
807 | (w/stdout ,gv ,@body)
808 | (inside ,gv))))
809 |
810 | (mac fromstring (str . body)
811 | (w/uniq gv
812 | `(w/instring ,gv ,str
813 | (w/stdin ,gv ,@body))))
814 |
815 | (def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
816 |
817 | (def read ((o x (stdin)) (o eof nil))
818 | (if (isa x 'string) (readstring1 x eof) (sread x eof)))
819 |
820 | ; inconsistency between names of readfile[1] and writefile
821 |
822 | (def readfile (name) (w/infile s name (drain (read s))))
823 |
824 | (def readfile1 (name) (w/infile s name (read s)))
825 |
826 | (def readall (src (o eof nil))
827 | ((afn (i)
828 | (let x (read i eof)
829 | (if (is x eof)
830 | nil
831 | (cons x (self i)))))
832 | (if (isa src 'string) (instring src) src)))
833 |
834 | (def allchars (str)
835 | (tostring (whiler c (readc str nil) no
836 | (writec c))))
837 |
838 | (def filechars (name)
839 | (w/infile s name (allchars s)))
840 |
841 | (def writefile (val file)
842 | (let tmpfile (+ file ".tmp")
843 | (w/outfile o tmpfile (write val o))
844 | (mvfile tmpfile file))
845 | val)
846 |
847 | (def sym (x) (coerce x 'sym))
848 |
849 | (def int (x (o b 10)) (coerce x 'int b))
850 |
851 | (mac rand-choice exprs
852 | `(case (rand ,(len exprs))
853 | ,@(let key -1
854 | (mappend [list (++ key) _]
855 | exprs))))
856 |
857 | (mac n-of (n expr)
858 | (w/uniq ga
859 | `(let ,ga nil
860 | (repeat ,n (push ,expr ,ga))
861 | (rev ,ga))))
862 |
863 | ; rejects bytes >= 248 lest digits be overrepresented
864 |
865 | (def rand-string (n)
866 | (let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
867 | (with (nc 62 s (newstring n) i 0)
868 | (w/infile str "/dev/urandom"
869 | (while (< i n)
870 | (let x (readb str)
871 | (unless (> x 247)
872 | (= (s i) (c (mod x nc)))
873 | (++ i)))))
874 | s)))
875 |
876 | (mac forlen (var s . body)
877 | `(for ,var 0 (- (len ,s) 1) ,@body))
878 |
879 | (mac on (var s . body)
880 | (if (is var 'index)
881 | (err "Can't use index as first arg to on.")
882 | (w/uniq gs
883 | `(let ,gs ,s
884 | (forlen index ,gs
885 | (let ,var (,gs index)
886 | ,@body))))))
887 |
888 | (def best (f seq)
889 | (if (no seq)
890 | nil
891 | (let wins (car seq)
892 | (each elt (cdr seq)
893 | (if (f elt wins) (= wins elt)))
894 | wins)))
895 |
896 | (def max args (best > args))
897 | (def min args (best < args))
898 |
899 | ; (mac max2 (x y)
900 | ; (w/uniq (a b)
901 | ; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
902 |
903 | (def most (f seq)
904 | (unless (no seq)
905 | (withs (wins (car seq) topscore (f wins))
906 | (each elt (cdr seq)
907 | (let score (f elt)
908 | (if (> score topscore) (= wins elt topscore score))))
909 | wins)))
910 |
911 | ; Insert so that list remains sorted. Don't really want to expose
912 | ; these but seem to have to because can't include a fn obj in a
913 | ; macroexpansion.
914 |
915 | (def insert-sorted (test elt seq)
916 | (if (no seq)
917 | (list elt)
918 | (test elt (car seq))
919 | (cons elt seq)
920 | (cons (car seq) (insert-sorted test elt (cdr seq)))))
921 |
922 | (mac insort (test elt seq)
923 | `(zap [insert-sorted ,test ,elt _] ,seq))
924 |
925 | (def reinsert-sorted (test elt seq)
926 | (if (no seq)
927 | (list elt)
928 | (is elt (car seq))
929 | (reinsert-sorted test elt (cdr seq))
930 | (test elt (car seq))
931 | (cons elt (rem elt seq))
932 | (cons (car seq) (reinsert-sorted test elt (cdr seq)))))
933 |
934 | (mac insortnew (test elt seq)
935 | `(zap [reinsert-sorted ,test ,elt _] ,seq))
936 |
937 | ; Could make this look at the sig of f and return a fn that took the
938 | ; right no of args and didn't have to call apply (or list if 1 arg).
939 |
940 | (def memo (f)
941 | (with (cache (table) nilcache (table))
942 | (fn args
943 | (or (cache args)
944 | (and (no (nilcache args))
945 | (aif (apply f args)
946 | (= (cache args) it)
947 | (do (set (nilcache args))
948 | nil)))))))
949 |
950 |
951 | (mac defmemo (name parms . body)
952 | `(safeset ,name (memo (fn ,parms ,@body))))
953 |
954 | (def <= args
955 | (or (no args)
956 | (no (cdr args))
957 | (and (no (> (car args) (cadr args)))
958 | (apply <= (cdr args)))))
959 |
960 | (def >= args
961 | (or (no args)
962 | (no (cdr args))
963 | (and (no (< (car args) (cadr args)))
964 | (apply >= (cdr args)))))
965 |
966 | (def whitec (c)
967 | (in c #\space #\newline #\tab #\return))
968 |
969 | (def nonwhite (c) (no (whitec c)))
970 |
971 | (def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z)))
972 |
973 | (def digit (c) (<= #\0 c #\9))
974 |
975 | (def alphadig (c) (or (letter c) (digit c)))
976 |
977 | (def punc (c)
978 | (in c #\. #\, #\; #\: #\! #\?))
979 |
980 | (def readline ((o str (stdin)))
981 | (awhen (readc str)
982 | (tostring
983 | (writec it)
984 | (whiler c (readc str) [in _ nil #\newline]
985 | (writec c)))))
986 |
987 | ; Don't currently use this but suspect some code could.
988 |
989 | (mac summing (sumfn . body)
990 | (w/uniq (gc gt)
991 | `(let ,gc 0
992 | (let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))
993 | ,@body)
994 | ,gc)))
995 |
996 | (def sum (f xs)
997 | (let n 0
998 | (each x xs (++ n (f x)))
999 | n))
1000 |
1001 | (def treewise (f base tree)
1002 | (if (atom tree)
1003 | (base tree)
1004 | (f (treewise f base (car tree))
1005 | (treewise f base (cdr tree)))))
1006 |
1007 | (def carif (x) (if (atom x) x (car x)))
1008 |
1009 | ; Could prob be generalized beyond printing.
1010 |
1011 | (def prall (elts (o init "") (o sep ", "))
1012 | (when elts
1013 | (pr init (car elts))
1014 | (map [pr sep _] (cdr elts))
1015 | elts))
1016 |
1017 | (def prs args
1018 | (prall args "" #\space))
1019 |
1020 | (def tree-subst (old new tree)
1021 | (if (is tree old)
1022 | new
1023 | (atom tree)
1024 | tree
1025 | (cons (tree-subst old new (car tree))
1026 | (tree-subst old new (cdr tree)))))
1027 |
1028 | (def ontree (f tree)
1029 | (f tree)
1030 | (unless (atom tree)
1031 | (ontree f (car tree))
1032 | (ontree f (cdr tree))))
1033 |
1034 | (def dotted (x)
1035 | (if (atom x)
1036 | nil
1037 | (and (cdr x) (or (atom (cdr x))
1038 | (dotted (cdr x))))))
1039 |
1040 | (def fill-table (table data)
1041 | (each (k v) (pair data) (= (table k) v))
1042 | table)
1043 |
1044 | (def keys (h)
1045 | (accum a (each (k v) h (a k))))
1046 |
1047 | (def vals (h)
1048 | (accum a (each (k v) h (a v))))
1049 |
1050 | ; These two should really be done by coerce. Wrap coerce?
1051 |
1052 | (def tablist (h)
1053 | (accum a (maptable (fn args (a args)) h)))
1054 |
1055 | (def listtab (al)
1056 | (let h (table)
1057 | (map (fn ((k v)) (= (h k) v))
1058 | al)
1059 | h))
1060 |
1061 | (mac obj args
1062 | `(listtab (list ,@(map (fn ((k v))
1063 | `(list ',k ,v))
1064 | (pair args)))))
1065 |
1066 | (def load-table (file (o eof))
1067 | (w/infile i file (read-table i eof)))
1068 |
1069 | (def read-table ((o i (stdin)) (o eof))
1070 | (let e (read i eof)
1071 | (if (alist e) (listtab e) e)))
1072 |
1073 | (def load-tables (file)
1074 | (w/infile i file
1075 | (w/uniq eof
1076 | (drain (read-table i eof) eof))))
1077 |
1078 | (def save-table (h file)
1079 | (writefile (tablist h) file))
1080 |
1081 | (def write-table (h (o o (stdout)))
1082 | (write (tablist h) o))
1083 |
1084 | (def copy (x . args)
1085 | (let x2 (case (type x)
1086 | sym x
1087 | cons (copylist x) ; (apply (fn args args) x)
1088 | string (let new (newstring (len x))
1089 | (forlen i x
1090 | (= (new i) (x i)))
1091 | new)
1092 | table (let new (table)
1093 | (each (k v) x
1094 | (= (new k) v))
1095 | new)
1096 | (err "Can't copy " x))
1097 | (map (fn ((k v)) (= (x2 k) v))
1098 | (pair args))
1099 | x2))
1100 |
1101 | (def abs (n)
1102 | (if (< n 0) (- n) n))
1103 |
1104 | ; The problem with returning a list instead of multiple values is that
1105 | ; you can't act as if the fn didn't return multiple vals in cases where
1106 | ; you only want the first. Not a big problem.
1107 |
1108 | (def round (n)
1109 | (withs (base (trunc n) rem (abs (- n base)))
1110 | (if (> rem 1/2) ((if (> n 0) + -) base 1)
1111 | (< rem 1/2) base
1112 | (odd base) ((if (> n 0) + -) base 1)
1113 | base)))
1114 |
1115 | (def roundup (n)
1116 | (withs (base (trunc n) rem (abs (- n base)))
1117 | (if (>= rem 1/2)
1118 | ((if (> n 0) + -) base 1)
1119 | base)))
1120 |
1121 | (def nearest (n quantum)
1122 | (* (roundup (/ n quantum)) quantum))
1123 |
1124 | (def avg (ns) (/ (apply + ns) (len ns)))
1125 |
1126 | (def med (ns (o test >))
1127 | ((sort test ns) (round (/ (len ns) 2))))
1128 |
1129 | ; Use mergesort on assumption that mostly sorting mostly sorted lists
1130 | ; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1)
1131 |
1132 | (def sort (test seq)
1133 | (if (alist seq)
1134 | (mergesort test (copy seq))
1135 | (coerce (mergesort test (coerce seq 'cons)) (type seq))))
1136 |
1137 | ; Destructive stable merge-sort, adapted from slib and improved
1138 | ; by Eli Barzilay for MzLib; re-written in Arc.
1139 |
1140 | (def mergesort (less? lst)
1141 | (with (n (len lst))
1142 | (if (<= n 1) lst
1143 | ; ; check if the list is already sorted
1144 | ; ; (which can be a common case, eg, directory lists).
1145 | ; (let loop ([last (car lst)] [next (cdr lst)])
1146 | ; (or (null? next)
1147 | ; (and (not (less? (car next) last))
1148 | ; (loop (car next) (cdr next)))))
1149 | ; lst
1150 | ((afn (n)
1151 | (if (> n 2)
1152 | ; needs to evaluate L->R
1153 | (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round
1154 | a (self j)
1155 | b (self (- n j)))
1156 | (merge less? a b))
1157 | ; the following case just inlines the length 2 case,
1158 | ; it can be removed (and use the above case for n>1)
1159 | ; and the code still works, except a little slower
1160 | (is n 2)
1161 | (with (x (car lst) y (cadr lst) p lst)
1162 | (= lst (cddr lst))
1163 | (when (less? y x) (scar p y) (scar (cdr p) x))
1164 | (scdr (cdr p) nil)
1165 | p)
1166 | (is n 1)
1167 | (with (p lst)
1168 | (= lst (cdr lst))
1169 | (scdr p nil)
1170 | p)
1171 | nil))
1172 | n))))
1173 |
1174 | ; Also by Eli.
1175 |
1176 | (def merge (less? x y)
1177 | (if (no x) y
1178 | (no y) x
1179 | (let lup nil
1180 | (assign lup
1181 | (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?
1182 | (if (less? (car y) (car x))
1183 | (do (if r-x? (scdr r y))
1184 | (if (cdr y) (lup y x (cdr y) nil) (scdr y x)))
1185 | ; (car x) <= (car y)
1186 | (do (if (no r-x?) (scdr r x))
1187 | (if (cdr x) (lup x (cdr x) y t) (scdr x y))))))
1188 | (if (less? (car y) (car x))
1189 | (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))
1190 | y)
1191 | ; (car x) <= (car y)
1192 | (do (if (cdr x) (lup x (cdr x) y t) (scdr x y))
1193 | x)))))
1194 |
1195 | (def bestn (n f seq)
1196 | (firstn n (sort f seq)))
1197 |
1198 | (def split (seq pos)
1199 | (list (cut seq 0 pos) (cut seq pos)))
1200 |
1201 | (mac time (expr)
1202 | (w/uniq (t1 t2)
1203 | `(let ,t1 (msec)
1204 | (do1 ,expr
1205 | (let ,t2 (msec)
1206 | (prn "time: " (- ,t2 ,t1) " msec."))))))
1207 |
1208 | (mac jtime (expr)
1209 | `(do1 'ok (time ,expr)))
1210 |
1211 | (mac time10 (expr)
1212 | `(time (repeat 10 ,expr)))
1213 |
1214 | (def union (f xs ys)
1215 | (+ xs (rem (fn (y) (some [f _ y] xs))
1216 | ys)))
1217 |
1218 | (= templates* (table))
1219 |
1220 | (mac deftem (tem . fields)
1221 | (withs (name (carif tem) includes (if (acons tem) (cdr tem)))
1222 | `(= (templates* ',name)
1223 | (+ (mappend templates* ',(rev includes))
1224 | (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
1225 | (pair fields)))))))
1226 |
1227 | (mac addtem (name . fields)
1228 | `(= (templates* ',name)
1229 | (union (fn (x y) (is (car x) (car y)))
1230 | (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
1231 | (pair fields)))
1232 | (templates* ',name))))
1233 |
1234 | (def inst (tem . args)
1235 | (let x (table)
1236 | (each (k v) (templates* tem)
1237 | (unless (no v) (= (x k) (v))))
1238 | (each (k v) (pair args)
1239 | (= (x k) v))
1240 | x))
1241 |
1242 | ; To write something to be read by temread, (write (tablist x))
1243 |
1244 | (def temread (tem (o str (stdin)))
1245 | (templatize tem (read str)))
1246 |
1247 | ; Converts alist to inst; ugly; maybe should make this part of coerce.
1248 | ; Note: discards fields not defined by the template.
1249 |
1250 | (def templatize (tem raw)
1251 | (with (x (inst tem) fields (templates* tem))
1252 | (each (k v) raw
1253 | (when (assoc k fields)
1254 | (= (x k) v)))
1255 | x))
1256 |
1257 | (def temload (tem file)
1258 | (w/infile i file (temread tem i)))
1259 |
1260 | (def temloadall (tem file)
1261 | (map (fn (pairs) (templatize tem pairs))
1262 | (w/infile in file (readall in))))
1263 |
1264 |
1265 | (def number (n) (in (type n) 'int 'num))
1266 |
1267 | (def since (t1) (- (seconds) t1))
1268 |
1269 | (def minutes-since (t1) (/ (since t1) 60))
1270 | (def hours-since (t1) (/ (since t1) 3600))
1271 | (def days-since (t1) (/ (since t1) 86400))
1272 |
1273 | ; could use a version for fns of 1 arg at least
1274 |
1275 | (def cache (timef valf)
1276 | (with (cached nil gentime nil)
1277 | (fn ()
1278 | (unless (and cached (< (since gentime) (timef)))
1279 | (= cached (valf)
1280 | gentime (seconds)))
1281 | cached)))
1282 |
1283 | (mac defcache (name lasts . body)
1284 | `(safeset ,name (cache (fn () ,lasts)
1285 | (fn () ,@body))))
1286 |
1287 | (mac errsafe (expr)
1288 | `(on-err (fn (c) nil)
1289 | (fn () ,expr)))
1290 |
1291 | (def saferead (arg) (errsafe:read arg))
1292 |
1293 | (def safe-load-table (filename)
1294 | (or (errsafe:load-table filename)
1295 | (table)))
1296 |
1297 | (def ensure-dir (path)
1298 | (unless (dir-exists path)
1299 | (system (string "mkdir -p " path))))
1300 |
1301 | (def date ((o s (seconds)))
1302 | (rev (nthcdr 3 (timedate s))))
1303 |
1304 | (def datestring ((o s (seconds)))
1305 | (let (y m d) (date s)
1306 | (string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d)))
1307 |
1308 | (def count (test x)
1309 | (with (n 0 testf (testify test))
1310 | (each elt x
1311 | (if (testf elt) (++ n)))
1312 | n))
1313 |
1314 | (def ellipsize (str (o limit 80))
1315 | (if (<= (len str) limit)
1316 | str
1317 | (+ (cut str 0 limit) "...")))
1318 |
1319 | (def rand-elt (seq)
1320 | (seq (rand (len seq))))
1321 |
1322 | (mac until (test . body)
1323 | `(while (no ,test) ,@body))
1324 |
1325 | (def before (x y seq (o i 0))
1326 | (with (xp (pos x seq i) yp (pos y seq i))
1327 | (and xp (or (no yp) (< xp yp)))))
1328 |
1329 | (def orf fns
1330 | (fn args
1331 | ((afn (fs)
1332 | (and fs (or (apply (car fs) args) (self (cdr fs)))))
1333 | fns)))
1334 |
1335 | (def andf fns
1336 | (fn args
1337 | ((afn (fs)
1338 | (if (no fs) t
1339 | (no (cdr fs)) (apply (car fs) args)
1340 | (and (apply (car fs) args) (self (cdr fs)))))
1341 | fns)))
1342 |
1343 | (def atend (i s)
1344 | (> i (- (len s) 2)))
1345 |
1346 | (def multiple (x y)
1347 | (is 0 (mod x y)))
1348 |
1349 | (mac nor args `(no (or ,@args)))
1350 |
1351 | ; Consider making the default sort fn take compare's two args (when do
1352 | ; you ever have to sort mere lists of numbers?) and rename current sort
1353 | ; as prim-sort or something.
1354 |
1355 | ; Could simply modify e.g. > so that (> len) returned the same thing
1356 | ; as (compare > len).
1357 |
1358 | (def compare (comparer scorer)
1359 | (fn (x y) (comparer (scorer x) (scorer y))))
1360 |
1361 | ; Cleaner thus, but may only ever need in 2 arg case.
1362 |
1363 | ;(def compare (comparer scorer)
1364 | ; (fn args (apply comparer map scorer args)))
1365 |
1366 | ; (def only (f g . args) (aif (apply g args) (f it)))
1367 |
1368 | (def only (f)
1369 | (fn args (if (car args) (apply f args))))
1370 |
1371 | (mac conswhen (f x y)
1372 | (w/uniq (gf gx)
1373 | `(with (,gf ,f ,gx ,x)
1374 | (if (,gf ,gx) (cons ,gx ,y) ,y))))
1375 |
1376 | ; Could combine with firstn if put f arg last, default to (fn (x) t).
1377 |
1378 | (def retrieve (n f xs)
1379 | (if (no n) (keep f xs)
1380 | (or (<= n 0) (no xs)) nil
1381 | (f (car xs)) (cons (car xs) (retrieve (- n 1) f (cdr xs)))
1382 | (retrieve n f (cdr xs))))
1383 |
1384 | (def dedup (xs)
1385 | (with (h (table) acc nil)
1386 | (each x xs
1387 | (unless (h x)
1388 | (push x acc)
1389 | (set (h x))))
1390 | (rev acc)))
1391 |
1392 | (def single (x) (and (acons x) (no (cdr x))))
1393 |
1394 | (def intersperse (x ys)
1395 | (and ys (cons (car ys)
1396 | (mappend [list x _] (cdr ys)))))
1397 |
1398 | (def counts (seq (o c (table)))
1399 | (if (no seq)
1400 | c
1401 | (do (++ (c (car seq) 0))
1402 | (counts (cdr seq) c))))
1403 |
1404 | (def commonest (seq)
1405 | (with (winner nil n 0)
1406 | (each (k v) (counts seq)
1407 | (when (> v n) (= winner k n v)))
1408 | (list winner n)))
1409 |
1410 | (def reduce (f xs)
1411 | (if (cddr xs)
1412 | (reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))
1413 | (apply f xs)))
1414 |
1415 | (def rreduce (f xs)
1416 | (if (cddr xs)
1417 | (f (car xs) (rreduce f (cdr xs)))
1418 | (apply f xs)))
1419 |
1420 | (let argsym (uniq)
1421 |
1422 | (def parse-format (str)
1423 | (accum a
1424 | (with (chars nil i -1)
1425 | (w/instring s str
1426 | (whilet c (readc s)
1427 | (case c
1428 | #\# (do (a (coerce (rev chars) 'string))
1429 | (wipe chars)
1430 | (a (read s)))
1431 | #\~ (do (a (coerce (rev chars) 'string))
1432 | (wipe chars)
1433 | (readc s)
1434 | (a (list argsym (++ i))))
1435 | (push c chars))))
1436 | (when chars
1437 | (a (coerce (rev chars) 'string))))))
1438 |
1439 | (mac prf (str . args)
1440 | `(let ,argsym (list ,@args)
1441 | (pr ,@(parse-format str))))
1442 | )
1443 |
1444 | (def load (file)
1445 | (w/infile f file
1446 | (w/uniq eof
1447 | (whiler e (read f eof) eof
1448 | (eval e)))))
1449 |
1450 | (def positive (x)
1451 | (and (number x) (> x 0)))
1452 |
1453 | (mac w/table (var . body)
1454 | `(let ,var (table) ,@body ,var))
1455 |
1456 | (def ero args
1457 | (w/stdout (stderr)
1458 | (each a args
1459 | (write a)
1460 | (writec #\space))
1461 | (writec #\newline))
1462 | (car args))
1463 |
1464 | (def queue () (list nil nil 0))
1465 |
1466 | ; Despite call to atomic, once had some sign this wasn't thread-safe.
1467 | ; Keep an eye on it.
1468 |
1469 | (def enq (obj q)
1470 | (atomic
1471 | (++ (q 2))
1472 | (if (no (car q))
1473 | (= (cadr q) (= (car q) (list obj)))
1474 | (= (cdr (cadr q)) (list obj)
1475 | (cadr q) (cdr (cadr q))))
1476 | (car q)))
1477 |
1478 | (def deq (q)
1479 | (atomic (unless (is (q 2) 0) (-- (q 2)))
1480 | (pop (car q))))
1481 |
1482 | ; Should redef len to do this, and make queues lists annotated queue.
1483 |
1484 | (def qlen (q) (q 2))
1485 |
1486 | (def qlist (q) (car q))
1487 |
1488 | (def enq-limit (val q (o limit 1000))
1489 | (atomic
1490 | (unless (< (qlen q) limit)
1491 | (deq q))
1492 | (enq val q)))
1493 |
1494 | (def median (ns)
1495 | ((sort > ns) (trunc (/ (len ns) 2))))
1496 |
1497 | (mac noisy-each (n var val . body)
1498 | (w/uniq (gn gc)
1499 | `(with (,gn ,n ,gc 0)
1500 | (each ,var ,val
1501 | (when (multiple (++ ,gc) ,gn)
1502 | (pr ".")
1503 | (flushout)
1504 | )
1505 | ,@body)
1506 | (prn)
1507 | (flushout))))
1508 |
1509 | (mac point (name . body)
1510 | (w/uniq (g p)
1511 | `(ccc (fn (,g)
1512 | (let ,name (fn ((o ,p)) (,g ,p))
1513 | ,@body)))))
1514 |
1515 | (mac catch body
1516 | `(point throw ,@body))
1517 |
1518 | (def downcase (x)
1519 | (let downc (fn (c)
1520 | (let n (coerce c 'int)
1521 | (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223))
1522 | (coerce (+ n 32) 'char)
1523 | c)))
1524 | (case (type x)
1525 | string (map downc x)
1526 | char (downc x)
1527 | sym (sym (map downc (coerce x 'string)))
1528 | (err "Can't downcase" x))))
1529 |
1530 | (def upcase (x)
1531 | (let upc (fn (c)
1532 | (let n (coerce c 'int)
1533 | (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255))
1534 | (coerce (- n 32) 'char)
1535 | c)))
1536 | (case (type x)
1537 | string (map upc x)
1538 | char (upc x)
1539 | sym (sym (map upc (coerce x 'string)))
1540 | (err "Can't upcase" x))))
1541 |
1542 | (def inc (x (o n 1))
1543 | (coerce (+ (coerce x 'int) n) (type x)))
1544 |
1545 | (def range (start end)
1546 | (if (> start end)
1547 | nil
1548 | (cons start (range (inc start) end))))
1549 |
1550 | (def mismatch (s1 s2)
1551 | (catch
1552 | (on c s1
1553 | (when (isnt c (s2 index))
1554 | (throw index)))))
1555 |
1556 | (def memtable (ks)
1557 | (let h (table)
1558 | (each k ks (set (h k)))
1559 | h))
1560 |
1561 | (= bar* " | ")
1562 |
1563 | (mac w/bars body
1564 | (w/uniq (out needbars)
1565 | `(let ,needbars nil
1566 | (do ,@(map (fn (e)
1567 | `(let ,out (tostring ,e)
1568 | (unless (is ,out "")
1569 | (if ,needbars
1570 | (pr bar* ,out)
1571 | (do (set ,needbars)
1572 | (pr ,out))))))
1573 | body)))))
1574 |
1575 | (def len< (x n) (< (len x) n))
1576 |
1577 | (def len> (x n) (> (len x) n))
1578 |
1579 | (mac thread body
1580 | `(new-thread (fn () ,@body)))
1581 |
1582 | (mac trav (x . fs)
1583 | (w/uniq g
1584 | `((afn (,g)
1585 | (when ,g
1586 | ,@(map [list _ g] fs)))
1587 | ,x)))
1588 |
1589 | (mac or= (place expr)
1590 | (let (binds val setter) (setforms place)
1591 | `(atwiths ,binds
1592 | (or ,val (,setter ,expr)))))
1593 |
1594 | (= hooks* (table))
1595 |
1596 | (def hook (name . args)
1597 | (aif (hooks* name) (apply it args)))
1598 |
1599 | (mac defhook (name . rest)
1600 | `(= (hooks* ',name) (fn ,@rest)))
1601 |
1602 | (mac out (expr) `(pr ,(tostring (eval expr))))
1603 |
1604 | ; if renamed this would be more natural for (map [_ user] pagefns*)
1605 |
1606 | (def get (index) [_ index])
1607 |
1608 | (= savers* (table))
1609 |
1610 | (mac fromdisk (var file init load save)
1611 | (w/uniq (gf gv)
1612 | `(unless (bound ',var)
1613 | (do1 (= ,var (iflet ,gf (file-exists ,file)
1614 | (,load ,gf)
1615 | ,init))
1616 | (= (savers* ',var) (fn (,gv) (,save ,gv ,file)))))))
1617 |
1618 | (mac diskvar (var file)
1619 | `(fromdisk ,var ,file nil readfile1 writefile))
1620 |
1621 | (mac disktable (var file)
1622 | `(fromdisk ,var ,file (table) load-table save-table))
1623 |
1624 | (mac todisk (var (o expr var))
1625 | `((savers* ',var)
1626 | ,(if (is var expr) var `(= ,var ,expr))))
1627 |
1628 |
1629 | (mac evtil (expr test)
1630 | (w/uniq gv
1631 | `(let ,gv ,expr
1632 | (while (no (,test ,gv))
1633 | (= ,gv ,expr))
1634 | ,gv)))
1635 |
1636 | (def rand-key (h)
1637 | (if (empty h)
1638 | nil
1639 | (let n (rand (len h))
1640 | (catch
1641 | (each (k v) h
1642 | (when (is (-- n) -1)
1643 | (throw k)))))))
1644 |
1645 | (def ratio (test xs)
1646 | (if (empty xs)
1647 | 0
1648 | (/ (count test xs) (len xs))))
1649 |
1650 |
1651 | ; any logical reason I can't say (push x (if foo y z)) ?
1652 | ; eval would have to always ret 2 things, the val and where it came from
1653 | ; idea: implicit tables of tables; setf empty field, becomes table
1654 | ; or should setf on a table just take n args?
1655 |
1656 | ; idea: use constants in functional position for currying?
1657 | ; (1 foo) would mean (fn args (apply foo 1 args))
1658 | ; another solution would be to declare certain symbols curryable, and
1659 | ; if > was, >_10 would mean [> _ 10]
1660 | ; or just say what the hell and make _ ssyntax for currying
1661 | ; idea: make >10 ssyntax for [> _ 10]
1662 | ; solution to the "problem" of improper lists: allow any atom as a list
1663 | ; terminator, not just nil. means list recursion should terminate on
1664 | ; atom rather than nil, (def empty (x) (or (atom x) (is x "")))
1665 | ; table should be able to take an optional initial-value. handle in sref.
1666 | ; warn about code of form (if (= )) -- probably mean is
1667 | ; warn when a fn has a parm that's already defined as a macro.
1668 | ; (def foo (after) (after))
1669 | ; idea: a fn (nothing) that returns a special gensym which is ignored
1670 | ; by map, so can use map in cases when don't want all the vals
1671 | ; idea: anaph macro so instead of (aand x y) say (anaph and x y)
1672 | ; idea: foo.bar!baz as an abbrev for (foo bar 'baz)
1673 | ; or something a bit more semantic?
1674 | ; could uniq be (def uniq () (annotate 'symbol (list 'u))) again?
1675 | ; idea: use x- for (car x) and -x for (cdr x) (but what about math -?)
1676 | ; idea: get rid of strings and just use symbols
1677 | ; could a string be (#\a #\b . "") ?
1678 | ; better err msg when , outside of a bq
1679 | ; idea: parameter (p foo) means in body foo is (pair arg)
1680 | ; idea: make ('string x) equiv to (coerce x 'string) ? or isa?
1681 | ; quoted atoms in car valuable unused semantic space
1682 | ; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y))
1683 | ; probably would lead to lots of errors when call with missing args
1684 | ; but would be really dense with . notation, (foo.1 2)
1685 | ; or use special ssyntax for currying: (foo@1 2)
1686 | ; remember, can also double; could use foo::bar to mean something
1687 | ; wild idea: inline defs for repetitive code
1688 | ; same args as fn you're in
1689 | ; variant of compose where first fn only applied to first arg?
1690 | ; (> (len x) y) means (>+len x y)
1691 | ; use ssyntax underscore for a var?
1692 | ; foo_bar means [foo _ bar]
1693 | ; what does foo:_:bar mean?
1694 | ; matchcase
1695 | ; idea: atable that binds it to table, assumes input is a list
1696 | ; crazy that finding the top 100 nos takes so long:
1697 | ; (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb)))
1698 | ; time: 2237 msec. -> now down to 850 msec
1699 |
1700 |
--------------------------------------------------------------------------------