Skip to content
Newer
Older
100644 206 lines (177 sloc) 6.57 KB
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
1 (require 'lisp-parser)
2 (require 'functional)
3 (require 'with-stack)
4 (require 'stack-words)
cea7637 @VincentToups microstack doc
authored Feb 2, 2011
5 (provide 'microstack)
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
6
7 (defunc =microstack-symbol ()
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
8 "Parser for a microstack symbol, or a space (no-op)."
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
9 (=let* [_ (=or (letter)
10 (=space)
11 (=other-id-char))]
12 (if _
13 (intern (concat (list _))) nil)))
14
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
15 (defunc =escaped-close-bracket ()
16 "Parse an escaped close bracket."
17 "["
18 (=let* [_ (=string "\\]")]
19 (if _ ?\" nil)))
20
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
21 ;; (defunc =bracketed-string ()
22 ;; (=let* [_ (=char ?\[)
23 ;; contents (zero-or-more (=or
24 ;; (=escaped-close-bracket)
25 ;; (=satisfies
26 ;; (lex-lambda (c) (!= c ?\])))))
27 ;; _ (=char ?\])]
28 ;; (parse-and-translate-microstack (coerce (flatten contents) 'string))))
29
30 (defunc =single-quote-string ()
31 (=let* [_ (=char ?\')
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
32 contents (zero-or-more (=or
33 (=escaped-close-bracket)
34 (=satisfies
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
35 (lex-lambda (c) (!= c ?\')))))
36 _ (=char ?\')]
37 (coerce (flatten contents) 'string)))
38
39 (defun =microstack-string ()
40 (=or (=single-quote-string)
41 (=lisp-string)))
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
42
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
43
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
44 (defun =microstack-quote ()
45 (=let* [_ (=char ?\[)
46 contents (microstack-parser)
47 _ (=char ?\])]
48 (translate-microstack contents)))
49
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
50 (defun microstack-parser ()
51 "Parser for the microstack language."
52 (zero-or-more (=or
53 (=microstack-symbol)
54 (=number)
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
55 (=microstack-string)
56 (=microstack-quote))))
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
57
58 (defun parse-microstack (code)
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
59 "Parse the microstack language and return the results as a sequence of symbols, numbers, strings. Remove no-ops."
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
60 (filter
61 (f-not (cr #'eq (intern " ")))
62 (car (parse-string-det (microstack-parser) code))))
63
64 (defstackword delete-forward0
65 (backward-delete-char -1))
66 (defstackword delete-backward0
67 (backward-delete-char 1))
68 (defstackword delete-backward
69 (backward-delete-char (pop *stack*)))
70 (defstackword delete-forward
71 (backward-delete-char (- (pop *stack*))))
72 (defstackword insert (insert (pop *stack*)))
73 (defstackword microstack->quotation
74 (let ((str (pop *stack*)))
c95dfaf @VincentToups fixed microstack
authored Feb 2, 2011
75 (push (translate-microstack (parse-microstack str)) *stack*)))
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
76 (defstackword do-n-times
77 (let ((n (pop *stack*))
78 (q (pop *stack*)))
79 (loop for i from 0 below n do
80 (|||- {q} call))))
81
82 (defstackword call-string
83 (|||- 1>intern 1>list call))
84
85 (defstackword string->quotation
86 (|||- 1>intern 1>list))
87
88 (defstackword kill-current-region
c95dfaf @VincentToups fixed microstack
authored Feb 3, 2011
89 (|||- lisp-val: (point) lisp-val: (mark) 2>kill-region))
90
91 (defstackword char-at-point->string
92 (push (buffer-substring-no-properties (point) (+ 1 (point))) *stack*))
93
94 (defstackword loop-while
95 (let ((con (pop *stack*))
96 (qtn (pop *stack*)))
97 (loop do
98 (|||- {con} call)
99 while (pop *stack*)
100 do
101 (|||- {qtn} call))))
102 (defstackword loop-until
103 (let ((con (pop *stack*))
104 (qtn (pop *stack*)))
105 (loop do
106 (|||- {con} call)
107 while (not (pop *stack*))
108 do
109 (|||- {qtn} call))))
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
110
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
111 (defstackword loop-until-char
112 (|||- '(char-at-point->string string=) curry loop-until))
113
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
114 (defstackword forward
115 (forward-char))
116 (defstackword backward
117 (backward-char))
118
119 (defstackword format
120 (let ((fmtstr (pop *stack*))
121 (rest (pop *stack*)))
122 (push (apply #'format (cons fmtstr rest)) *stack*)))
123
302bcda @VincentToups Multimethods library, bros
authored Feb 13, 2011
124 (defstackword generic-move
125 (let ((arg (pop *stack*)))
126 (cond
127 ((numberp arg) (|||- {arg} word))
128 ((
129
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
130 (setq micro-stack-map
131 (alist>>
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
132 'b 'backward ; move the point backward once
133 'B '1>backward-char ; move the point backward n times, pop n from the stack
134 'f 'forward ; move the point forward once
135 'F '1>forward-char ; move the point forward n times, pop n from the stack
136 'd 'delete-forward0 ; delete forward once
137 'D 'delete-forward ; delete forward n times, pop n from the stack
138 'k 'delete-backward0 ; delete backward once
139 'K 'delete-backward ; delete backward n times, remove n from the stack
140 'q 'microstack->quotation ; convert a STRING to a microstack compiled quotation, "..."q is eq to [...]
141 'Q 'string->quotation ;push the stack word represented by string onto the stack to be called later
142 '! 'call ; call a quotation/stack word
143 '? 'if ; if
144 '+ '+ ; plus
145 '- '- ; -
146 't 't ; push t
147 '_ 'nil ; push nil
148 'm '0>push-mark ; mark the current point as the mark
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
149 'M '0>mark ; put the mark position on the stack
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
150 'g '1>goto-char ; jump to a character number popped from the stack
151 'x 'kill-current-region ; kill the current region between the point and mark
152 '* '* ; times
153 '/ '/ ; divide
154 '= '2>equal ; equals
155 'N 'do-n-times ; do a quotation n times before stopping
156 'L 'loop ; the loop word in all its general glory - execute a quotation until the top of the stack is true
157 '{ '{{ ; start a list
158 '} '}} ; end a list
159 's '1>search-forward ; search forward for the string on the stack, which is popped
160 'S '1>search-forward-regexp ; search forward for the regex on the stack, which is popped
161 'c 'concat ; concat two strings
162 (intern ",") 'print-stack ; print the stack
163 (intern ":") 'dup ; dup
164 (intern "$") 'swap ; swap the top two stack elements
165 (intern "#") 'length ; pop object off the stack and push its length
166 (intern "@") 'char-at-point->string ;push the current character onto the stack
167 (intern ".") 'print ; print the top of the stack, pop it
168 (intern "%") 'format ; lst format-string format; calls format with the string format-string and lst as rest args
d3ded5e @VincentToups microstack doc
authored Feb 3, 2011
169 (intern "|") 'compose ; compose two quotations
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
170 (intern "^") 'curry ; curry the value on the stack into the quotation below it.
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
171 'U 'loop-until ; qt pred loop-until ; loop qt until pred is true
9cd75a7 @VincentToups microstack updates
authored Feb 4, 2011
172 'u 'loop-until-char ; qt char loop-until-char; loop qt until char is beneath the cursor.
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
173 'W 'loop-while ; qt pred loop-while ; loop qt while pred is true
174 'i 'insert ; insert the top of the stack as text into the buffer
d3ded5e @VincentToups microstack doc
authored Feb 4, 2011
175
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
176 ))
177
178
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
179
180 (defun translate-microstack (code)
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
181 "Translate the single character symbols to their stack words. Process special microstack behavior words."
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
182 (loop for el in code append
183 (cond
184 ((symbolp el)
185 (let ((trans (alist micro-stack-map el)))
186 (if trans (list trans) (error "Unknown microstack word."))))
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
187 ((listp el)
188 (list 'lisp-val: `(quote ,el)))
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
189 (t (list el)))))
190
9035699 @VincentToups Extended microstack.
authored Feb 3, 2011
191 (defun parse-and-translate-microstack (code)
192 (translate-microstack (parse-microstack code)))
193
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
194 (defun do-microstack-parsed-translated (code)
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
195 "Evaluate the parsed and translated CODE for a microstack statement. Should be regular stack code at this point."
c95dfaf @VincentToups fixed microstack
authored Feb 3, 2011
196 (eval `(|||p ,@code)))
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
197
198 (defun do-microstack (str)
ef7feb5 @VincentToups microstack doc
authored Feb 2, 2011
199 "Parse, translated and execute the microstack code in STR."
9dabfe0 @VincentToups microstack first
authored Feb 2, 2011
200 (interactive "s")
201 (let* ((code (parse-microstack str))
202 (code (translate-microstack code)))
203 (print code)
204 (do-microstack-parsed-translated code)))
205
Something went wrong with that request. Please try again.