API tools faq
paste
Guest User

Untitled

a guest
Jun 20th, 2018
149
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.32 KB | None | 0 0
raw download clone embed print report
  1. #lang sweet-exp stacklisp
  2.  
  3. provide
  4. rename-out void identity
  5. define-variable!
  6. set-variable-value!
  7. lookup-variable-value
  8. extend-environment
  9. tag
  10. rename-out allocate-words allocate
  11. rename-out read-memory-offset read-memory
  12. rename-out write-memory-offset write-memory
  13. false?
  14. rename-out + add
  15. make-fixnum
  16. fixnum-value
  17. rename-out fixnum-value symbol-value
  18. rename-out fixnum-value character-value
  19. save-continuation
  20. restore-continuation!
  21. continuation?
  22. make-compiled-procedure
  23. compiled-procedure-entry
  24. compiled-procedure-env
  25. compiled-procedure?
  26. primitive-procedure?
  27. apply-primitive-procedure
  28. singleton
  29. pair
  30. pair?
  31. left
  32. right
  33. null?
  34. null
  35. rename-out vector-read read-vector
  36. rename-out vector-write! write-vector
  37.  
  38. define TAG-FIXNUM 0
  39. define TAG-SYMBOL 1
  40. define TAG-COMPILED-PROCEDURE 2
  41. define TAG-PRIMITIVE-PROCEDURE 3
  42. define TAG-PAIR 4
  43. define TAG-VECTOR 5
  44. define TAG-NIL 6
  45. define TAG-CONTINUATION 7
  46. define TAG-FRAME 8
  47. define TAG-ENVIRONMENT 9
  48. define TAG-CHARACTER 10
  49. define TAG-BYTES 11
  50.  
  51. define WORD 32
  52.  
  53. define MEM-ENV #x00
  54. define MEM-PROC #x20
  55. define MEM-CONTINUE #x40
  56. define MEM-ARGL #x60
  57. define MEM-VAL #x80
  58. define MEM-STACK-SIZE #xa0
  59. define MEM-NULL #xc0
  60. define MEM-ALLOCATOR #xe0
  61. define MEM-DYNAMIC-START #x100 ; This should be the highest hardcoded memory address.
  62.  
  63. define =() evm(EQ)
  64. define +() evm(ADD)
  65. define -() evm(SUB)
  66. define *() evm(MUL)
  67. define or() evm(OR)
  68.  
  69. define (or3 a b c) or(a or(b c))
  70. define (+& ptr idx)
  71. + ptr *(idx WORD)
  72.  
  73. define entry(user-program)
  74. initialize-environment()
  75. program()
  76. return read-register(MEM-VAL)
  77.  
  78. define initialize-environment()
  79. write-address MEM-ALLOCATOR MEM-DYNAMIC-START
  80. write-address MEM-ENV make-empty-environment()
  81. write-address MEM-CONTINUE 31337
  82. write-address MEM-PROC 1337
  83. write-address MEM-ARGL 337
  84. write-address MEM-NULL TAG-NULL
  85.  
  86. define return(ptr)
  87. if {ptr > 2}
  88. return-unboxed ptr
  89. return-boxed tag(ptr) ptr
  90.  
  91. define return-unboxed(x)
  92. return-fixnum(make-fixnum(x))
  93.  
  94. define error(x)
  95. evm('REVERT)
  96.  
  97. define return-boxed(tag ptr)
  98. if {{tag = TAG-FIXNUM} or3
  99. {tag = TAG-CHARACTER} or3
  100. {tag = TAG-SYMBOL}}
  101. return-fixnum ptr
  102. if {tag = TAG-PAIR}
  103. return-list ptr
  104. if {tag = TAG-VECTOR}
  105. return-vector ptr
  106. if {tag = TAG-NULL}
  107. return-null
  108. if {tag = TAG-BYTES}
  109. return-bytes ptr
  110. error('return-invalid-type)
  111.  
  112.  
  113. define return-fixnum(ptr)
  114. evm(RETURN)({ptr +& 1} WORD)
  115.  
  116. define return-list(ptr)
  117. return-vector list->vector(ptr)
  118.  
  119. define return-vector(ptr)
  120. vector-unbox! ptr
  121. evm(RETURN)(vector-data(ptr) *(vector-len(ptr) WORD))
  122.  
  123. define return-null() evm(STOP)
  124. define return-bytes(ptr)
  125. evm(RETURN)(bytes-data(ptr) bytes-len(ptr))
  126.  
  127. define read-register read-memory
  128.  
  129. ; Values
  130.  
  131. define tag read-memory
  132.  
  133. define make-fixnum(x) initialize2(TAG-FIXNUM x)
  134. define fixnum-value(ptr) read-memory({ ptr +& 1 })
  135.  
  136. define list->vector(ptr)
  137. copy-list->memory! ptr make-vector(list-length(ptr))
  138.  
  139. define copy-list->memory!(list ptr)
  140. if null?(list)
  141. void()
  142. begin
  143. write-memory! left(list) ptr
  144. copy-list->memory! right(list) +(ptr WORD)
  145.  
  146. define vector-unbox!(vec)
  147. vector-map! vec fixnum-value
  148.  
  149. define vector-map!(vec f)
  150. memory-map! vector-data(vec) vector-len(vec) f
  151.  
  152. define memory-map!(ptr len f)
  153. if {len = 0}
  154. void()
  155. begin
  156. write-memory! ptr f(read-memory ptr)
  157. memory-map! {ptr +& 1} f
  158.  
  159. define bytes-data(ptr) { ptr +& 2 }
  160. define bytes-len(ptr) { ptr +& 1 }
  161.  
  162. define read-memory() evm(MLOAD)
  163.  
  164. define write-memory() evm(MSTORE)
  165.  
  166. define void()
  167.  
  168. define allocate-words(n) allocate{ n * WORD }
  169. define allocate(bytes-size)
  170. define ptr read-memory(MEM-ALLOCATOR)
  171. write-memory ptr {ptr + bytes-size}
  172. ptr
  173.  
  174. define initialize1(ptr a)
  175. define ptr allocate-words(1)
  176. write-memory ptr a
  177. ptr
  178.  
  179. define initialize2(ptr a b)
  180. define ptr allocate-words(2)
  181. write-memory ptr a
  182. write-memory {ptr +& 1} b
  183. ptr
  184.  
  185. define initialize3(ptr a b c)
  186. define ptr allocate-words(3)
  187. write-memory ptr a
  188. write-memory {ptr +& 1} b
  189. write-memory {ptr +& 2} c
  190. ptr
  191.  
  192. ; Primitive Operations
  193.  
  194. define define-variable!(name value env)
  195. define frame environment-frame(env)
  196. define-variable-scan left(frame) right(frame) name value frame
  197.  
  198. define define-variable-scan(fvars fvals name value frame)
  199. if null?(fvars)
  200. add-binding-to-frame! name value frame
  201. if { left(fvars) = name }
  202. set-left! fvals value
  203. define-variable-scan right(fvars) right(fvals) name value frame
  204.  
  205. define environment-frame left
  206.  
  207. define set-variable-value-scan(fvars fvals name value env)
  208. if null?(fvars)
  209. set-variable-value! name value env
  210. if { left(fvars) = name }
  211. set-left! fvals value
  212. set-variable-value-scan left(fvars) left(fvals) name value env
  213.  
  214. define set-variable-value-env-loop(frame name value env)
  215. set-variable-value-scan left(frame) right(frame) name value env
  216.  
  217. define set-variable-value!(name value env)
  218. if null?(env)
  219. error('set-variable-value!-not-found)
  220. set-variable-value-env-loop left(env) name value right(env)
  221.  
  222. define lookup-variable-value-scan(fvars fvals name env)
  223. if null?(fvars)
  224. lookup-variable-value name right(env)
  225. if { left(fvars) = name }
  226. left fvals
  227. lookup-variable-value-scan right(fvars) right(fvals) name env
  228.  
  229. define lookup-variable-value(name env)
  230. if null?(env)
  231. error('lookup-variable-value-not-found)
  232. let* <* frame left(env) *>
  233. lookup-variable-value-scan left(frame) right(frame) name env
  234.  
  235. define make-frame(vars vals)
  236. initialize3 TAG-FRAME vars vals
  237.  
  238. define make-environment(frame rest)
  239. initialize3 TAG-ENVIRONMENT frame rest
  240.  
  241. define extend-environment(vars vals env)
  242. make-environment make-frame(vars vals) env
  243.  
  244. define false?() evm(ISZERO)
  245.  
  246. define save-continuation()
  247. pop-vector read-memory(MEM-STACK-SIZE) ; [ vec ]
  248. allocate-words(4) ; [ ptr; vec ]
  249. write-memory! evm(DUP1) TAG-CONTINUATION
  250. write-memory! {evm(DUP1) +& 1} read-memory(MEM-CONTINUE)
  251. write-memory! {evm(DUP1) +& 2} read-memory(MEM-ENV)
  252. evm(DUP1) ; [ ptr; ptr; vec ]
  253. evm(SWAP2) ; [ vec; ptr; ptr ]
  254. evm(SWAP1) ; [ ptr; vec; ptr ]
  255. write-memory! {void() +& 3} void() ; [ ptr ]
  256. write-memory! MEM-STACK-SIZE void() ; [ ]
  257. continuation-stack (read-memory MEM-STACK-SIZE) ; [ stack ]
  258. push-vector void() ; [ *STACK ]
  259. read-memory MEM-STACK-SIZE ; [ ptr ]
  260. evm(DUP1) ; [ ptr; ptr ]
  261. continuation-stack-size void() ; [ size; ptr ]
  262. write-memory MEM-STACK-SIZE void() ; [ ptr ]
  263.  
  264. define restore-continuation!() ; [ cont ]
  265. write-memory! MEM-ENV void() ; [ ]
  266. pop $ read-memory MEM-STACK-SIZE ; [ ERASED-STACK ]
  267. read-memory MEM-ENV ; [ cont ]
  268. write-memory MEM-ENV read-memory({ evm(DUP1) +& 2 }) ; [ cont ]
  269. write-memory MEM-CONTINUE read-memory({ evm(DUP1) +& 1 }) ; [ cont ]
  270. continuation-stack void() ; [ stack-ptr ]
  271. write-memory MEM-STACK-SIZE vector-len(evm(DUP1)) ; [ stack-ptr ]
  272. push-vector void() ; [ *STACK ]
  273. goto read-memory(MEM-CONTINUE) ; [ *STACK ]
  274.  
  275. define continuation?(cont) { tag(cont) = TAG-CONTINUATION }
  276. define make-compiled-procedure(code env)
  277. initialize3 TAG-COMPILED-PROCEDURE code env
  278.  
  279. define compiled-procedure-entry(x)
  280. read-memory { x +& 1 }
  281.  
  282. define compiled-procedure-env
  283. read-memory { x +& 2 }
  284.  
  285. define compiled-procedure?(x) { tag(x) = TAG-COMPILED-PROCEDURE }
  286.  
  287. define primitive-procedure?(x) { tag(x) = TAG-PRIMITIVE-PROCEDURE }
  288. define apply-primitive-procedure(proc argl) error('apply-primitive-procedure-unimplemented)
  289. define singleton(x)
  290. pair x null
  291. define pair(a b) initialize3(TAG-PAIR a b)
  292. define pair?(x) { tag(x) = TAG-PAIR }
  293. define left(x) read-memory{ x +& 1 }
  294. define right(x) read-memory{ x +& 2 }
  295. define set-left!(ptr x) write-memory({ ptr +& 1} x)
  296. define set-right!(ptr x) write-memory({ ptr +& 2} x)
  297. define null?(x) { x = MEM-NULL }
  298. define null MEM-NULL
  299.  
  300. define vector-read(vec i) read-memory{ vec +& {i + 2}}
  301. define vector-write!(vec i x) write-memory({ vec +& {i + 2}} x)
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!