Skip to content

HTTPS clone URL

Subversion checkout URL

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