read-macros.sl 7.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323
  1. % READ-MACROS.SL - some specilized reader macros
  2. %
  3. % Author: Don Morrison
  4. % Symbolic Computation Group
  5. % Computer Science Dept.
  6. % University of Utah
  7. % Date: Wednesday, 12 May 1982
  8. % Copyright (c) 1981 University of Utah
  9. % Edit by Cris Perdue, 1 Feb 1983 1400-PST
  10. % Dochar moved into "nonkernel", "C" for "CONTROL", etc. commented out.
  11. % Many miscellaneous symbolic names for characters removed.
  12. ((lambda (o-table)
  13. (setq LispScanTable* (TotalCopy o-table)) % in case it's in pure space
  14. (cond ((eq CurrentScanTable* o-table)
  15. (setq CurrentScanTable* LispScanTable*))))
  16. LispScanTable*)
  17. % plug backquote and friends into the lisp reader via read macros
  18. % ` for backquote, , for unquote, ,@ for unquotel, and ,. for unquoted
  19. (de backquote-read-macro (channel qt)
  20. (list 'backquote (ChannelReadTokenWithHooks channel)))
  21. (de unquote-read-macro (channel qt)
  22. (list 'unquote (ChannelReadTokenWithHooks channel)))
  23. (de unquotel-read-macro (channel qt)
  24. (list 'unquotel (ChannelReadTokenWithHooks channel)))
  25. (de unquoted-read-macro (channel qt)
  26. (list 'unquoted (ChannelReadTokenWithHooks channel)))
  27. (putv LispScanTable* (char !`) 11)
  28. (putv LispScanTable* (char !,) 13)
  29. (put '!, (getv LispScanTable* 128) '((!@ . !,!@)(!. . !,!.)))
  30. (deflist
  31. '((!` backquote-read-macro)
  32. (!, unquote-read-macro)
  33. (!,!@ unquotel-read-macro)
  34. (!,!. unquoted-read-macro))
  35. 'LispReadMacro)
  36. % A couple of MACLISP style sharp sign read macros...
  37. (putv LispScanTable* (char !#) 13)
  38. (put '!# (getv LispScanTable* 128) '((!. . !#!.)
  39. (!/ . !#!/)
  40. (!' . !#!')
  41. (!+ . !#!+)
  42. (!- . !#!-)
  43. (!\ . !#!\)))
  44. (deflist
  45. `((!#!' ,(function function-read-macro))
  46. (!#!. ,(function eval-read-macro))
  47. (!#!\ ,(function char-read-macro))
  48. (!#!+ ,(function if-system-read-macro))
  49. (!#!- ,(function if-not-system-read-macro))
  50. (!#!/ ,(function single-char-read-macro)))
  51. 'LispReadMacro)
  52. (de function-read-macro (channel qt)
  53. `(function ,(ChannelReadTokenWithHooks channel)))
  54. (de eval-read-macro (channel qt)
  55. (eval (ChannelReadTokenWithHooks channel)))
  56. % (imports '(if-system)) % actually doesn't use the code, just the convention
  57. (fluid '(system_list*))
  58. (de if-system-read-macro (channel qt)
  59. ((lambda (system)
  60. ((lambda (when_true)
  61. (cond ((memq system system_list*) when_true)
  62. (t (ChannelReadTokenWithHooks channel))))
  63. (ChannelReadTokenWithHooks channel)))
  64. (ChannelReadTokenWithHooks channel)))
  65. (de if-not-system-read-macro (channel qt)
  66. ((lambda (system)
  67. ((lambda (when_false)
  68. (cond ((not (memq system system_list*)) when_false)
  69. (t (ChannelReadTokenWithHooks channel))))
  70. (ChannelReadTokenWithHooks channel)))
  71. (ChannelReadTokenWithHooks channel)))
  72. %(de when-read-macro (channel qt)
  73. % (let ((a (ChannelReadTokenWithHooks channel)))
  74. % (let ((b (ChannelReadTokenWithHooks channel))
  75. % (fn (and (idp a) (get a 'when-macro))))
  76. % (if fn
  77. % (apply fn (list b))
  78. % (StdError (BldMsg "Can't evaluate %r at %r time" b a))))))
  79. % CompileTime and friends have to be made to work from LISP before these
  80. % will be of much use.
  81. %(foreach u in '(compile c CompileTime compile-time comp) do
  82. % (put u 'when-macro #'(lambda(x) `(CompileTime ,x))))
  83. %(foreach u in '(load l LoadTime load-time) do
  84. % (put u 'when-macro #'(lambda(x) `(LoadTime ,x))))
  85. %(foreach u in '(both b BothTimes both-times BothTime both-time) do
  86. % (put u 'when-macro #'(lambda(x) `(BothTimes ,x))))
  87. %(foreach u in '(read r ReadTime read-time) do
  88. % (put u 'when-macro #'eval))
  89. (de single-char-read-macro (channel qt)
  90. (ChannelReadChar channel))
  91. % % Frightfully kludgey. Anybody know how to just read the one character?
  92. % ((lambda (*raise)
  93. % ((lambda (ch)
  94. % ((lambda (n)
  95. % (if (lessp n 128)
  96. % n
  97. % (StdError (BldMsg "%r is illegal after #/" ch))))
  98. % (dochar ch)))
  99. % (ChannelReadTokenWithHooks channel)))
  100. % nil))
  101. (de char-read-macro (channel qt)
  102. (dochar (ChannelReadTokenWithHooks channel)))
  103. % Definition of dochar moved to char-macro.sl in the kernel /csp
  104. % Alternative modifiers (below) removed, hope they aren't needed (yuk) /csp
  105. % (put 'c 'char-prefix-function (get 'control 'char-prefix-function))
  106. % (put '!^ 'char-prefix-function (get 'control 'char-prefix-function))
  107. % (put 'm 'char-prefix-function (get 'meta 'char-prefix-function))
  108. (commentoutcode
  109. (deflist
  110. % let char know all about the "standard" two and three letter names for
  111. % non-printing ASCII characters.
  112. '((NUL 0)
  113. (SOH 1)
  114. (STX 2)
  115. (ETX 3)
  116. (EOT 4)
  117. (ENQ 5)
  118. (ACK 6)
  119. (BEL 7)
  120. (BS 8)
  121. (HT 9)
  122. (NL 10)
  123. (VT 11)
  124. (NP 12)
  125. (CR 13)
  126. (SO 14)
  127. (SI 15)
  128. (DLE 16)
  129. (DC1 17)
  130. (DC2 18)
  131. (DC3 19)
  132. (DC4 20)
  133. (NAK 21)
  134. (SYN 22)
  135. (ETB 23)
  136. (CAN 24)
  137. (EM 25)
  138. (SUB 26)
  139. (ESC 27)
  140. (FS 28)
  141. (GS 29)
  142. (RS 30)
  143. (US 31)
  144. (SP 32)
  145. (DEL 127))
  146. 'charconst)
  147. )
  148. (commentoutcode
  149. (deflist
  150. '((!^!@ 0) % "creeping featurism" here for sure...
  151. (!^A 1)
  152. (!^B 2)
  153. (!^C 3)
  154. (!^D 4)
  155. (!^E 5)
  156. (!^F 6)
  157. (!^G 7)
  158. (!^H 8)
  159. (!^I 9)
  160. (!^J 10)
  161. (!^K 11)
  162. (!^L 12)
  163. (!^M 13)
  164. (!^N 14)
  165. (!^O 15)
  166. (!^P 16)
  167. (!^Q 17)
  168. (!^R 18)
  169. (!^S 19)
  170. (!^T 20)
  171. (!^U 21)
  172. (!^V 22)
  173. (!^W 23)
  174. (!^X 24)
  175. (!^Y 25)
  176. (!^Z 26)
  177. (!^![ 8#33)
  178. (!^!\ 8#34)
  179. (!^!] 8#35)
  180. (!^!^ 8#36)
  181. (!^!~ 8#36) % for telerays...
  182. (!^!_ 8#37)
  183. (!^!/ 8#37) % for telerays...
  184. (!^!? 8#177))
  185. 'charconst)
  186. )
  187. (commentoutcode
  188. % It has been suggested that nice names for printing characters would be good,
  189. % too, so here are some. I don't really see that they're all that much use,
  190. % but I guess they don't do any harm. I doubt I'll ever use them, though.
  191. % If this isn't "creeping featurism" I don't know what is....
  192. (foreach u in
  193. '((BANG !!)
  194. (EXCLAMATION !!)
  195. (AT !@)
  196. (ATSIGN !@)
  197. (SHARP !#)
  198. (POUND !#)
  199. (NUMBER !#)
  200. (NUMBER-SIGN !#)
  201. (HASH !#)
  202. (NOT-EQUAL !#) % For Algol 60 fans...
  203. (DOLLAR !$)
  204. (PERCENT !%)
  205. (CARET !^)
  206. (UPARROW !^)
  207. (AND !&)
  208. (AMPERSAND !&)
  209. (STAR !*)
  210. (TIMES !*)
  211. (LPAREN !( )
  212. (LEFT-PARENTHESIS !( )
  213. (LEFT-PAREN !( )
  214. (LPAR !( )
  215. (OPEN !( )
  216. (RPAREN !) )
  217. (RIGHT-PARENTHESIS !) )
  218. (RIGHT-PAREN !) )
  219. (RPAR !) )
  220. (CLOSE !) )
  221. (MINUS !-)
  222. (DASH !-)
  223. (UNDERSCORE !_)
  224. (UNDERLINE !_)
  225. (BACKARROW !_)
  226. (PLUS !+)
  227. (EQUAL !=)
  228. (EQUALS !=)
  229. (TILDE !~)
  230. (BACKQUOTE !`)
  231. (LBRACE !{)
  232. (LEFT-BRACE !{)
  233. (RBRACE !})
  234. (RIGHT-BRACE !})
  235. (LBRACKET ![)
  236. (LEFT-BRACKET ![)
  237. (LBRA ![)
  238. (RBRACKET !])
  239. (RIGHT-BRACKET !])
  240. (RBRA !])
  241. (APOSTROPHE !')
  242. (SINGLE-QUOTE !')
  243. (QUOTE-MARK !')
  244. (DOUBLE-QUOTE !")
  245. (STRING-MARK !")
  246. % (QUOTE should this be ' or " -- I'll play it safe and not use either
  247. (COLON !:)
  248. (SEMI !;)
  249. (SEMICOL !;)
  250. (SEMICOLON !;)
  251. (QUESTION !?)
  252. (QUESTION-MARK !?)
  253. (QUESTIONMARK !?)
  254. (LESS !<)
  255. (LESS-THAN !<)
  256. (LANGLE !<)
  257. (LEFT-ANGLE !<)
  258. (LEFT-ANGLE-BRACKET !<)
  259. (GREATER !>)
  260. (GREATER-THAN !>)
  261. (GRTR !>)
  262. (RANGLE !>)
  263. (RIGHT-ANGLE !>)
  264. (RIGHT-ANGLE-BRACKET !>)
  265. (COMMA !,)
  266. (DOT !.)
  267. (PERIOD !.)
  268. (FULL-STOP !.) % For the English among us...
  269. (SLASH !/)
  270. (SOLIDUS !/)
  271. (DIVIDE !/)
  272. (BACKSLASH !\)
  273. (BAR !|)
  274. (VERTICAL !|)
  275. (VETICAL-BAR !|)
  276. (ZERO !0)
  277. (NAUGHT !0) % For the English among us...
  278. (ONE !1)
  279. (TWO !2)
  280. (THREE !3)
  281. (FOUR !4)
  282. (FIVE !5)
  283. (SIX !6)
  284. (SEVEN !7)
  285. (EIGHT !8)
  286. (NINE !9))
  287. do (put (car u) 'charconst (dochar (cadr u))))
  288. )