src/r7rs.ebnf

@@ -8,18 +8,20 @@ right-paren = ')' <intertoken-space>
 dot = '.' <intertoken-space>
 
 (* datum *)
-<datum> = simple-datum | compound-datum
+datum-start = <intertoken-space> datum
+
+datum = simple-datum | compound-datum
 <simple-datum> = boolean | symbol | number | string
 <compound-datum> = any-list
 
 (* list *)
-<any-list> = proper-list | improper-list
-proper-list = <left-paren> datum* <right-paren>
+<any-list> = list | improper-list
+list = <left-paren> datum* <right-paren>
 improper-list = <left-paren> datum+ <dot> datum <right-paren>
 
 (* symbol *)
 symbol = ordinary-symbol <intertoken-space>
-<ordinary-symbol> = #"[\P{Lu}\P{Ll}\P{Lt}\P{Lm}\P{Lo}\P{Nl}\P{No}\P{Pd}\P{Pc}\P{Sc}\P{Po}\P{Sm}\P{Sk}\P{So}\P{Co}\u200c\u200d&&[^;|\".,#]][\P{Lu}\P{Ll}\P{Lt}\P{Lm}\P{Lo}\P{Nl}\P{No}\P{Pd}\P{Pc}\P{Sc}\P{Po}\P{Sm}\P{Sk}\P{So}\P{Co}\u200c\u200d\P{Nd}\P{Me}\P{Mc}.&&[^;|\",#]]*"
+<ordinary-symbol> = #"[\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{No}\p{Pd}\p{Pc}\p{Sc}\p{Po}\p{Sm}\p{Sk}\p{So}\p{Co}\u200c\u200d&&[^;|\".,#]][\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}\p{No}\p{Pd}\p{Pc}\p{Sc}\p{Po}\p{Sm}\p{Sk}\p{So}\p{Co}\u200c\u200d\p{Nd}\p{Me}\p{Mc}.&&[^;|\",#]]*"
 
 (* number *)
 number = num-10 <intertoken-space>

src/scm.clj

@@ -2,34 +2,36 @@
   (:require [instaparse.core :as insta]
             [clojure.java.io :as io]
             [clojure.core.match :refer [match]]
-            [clojure.string :as str])
+            [clojure.string :as str]
+            [clojure.spec.alpha :as s])
+  (:import clojure.lang.ILookup)
   (:refer-clojure :exclude [read]))
 
 
 ;;; syntax objects
 
-(defprotocol IStx
+(defprotocol ISyntax
   (stx-datum [this])
   (stx-context [this]))
 
 (defn syntax? [x]
-  (instance? IStx x))
+  (instance? ISyntax x))
 
-(deftype Stx [datum ctx]
+(deftype Syntax [datum ctx]
   Object
   (equals [x y]
     (or (identical? x y)
-        (and (instance? IStx y)
+        (and (instance? ISyntax y)
              (.equals datum (stx-datum y))
              (.equals ctx (stx-context y)))))
-  IStx
+  ISyntax
   (stx-datum [this] datum)
   (stx-context [this] ctx))
 
 (def ^:dynamic *print-ctx?* true)
 
 ;; does not respect `*print-dup*` lol
-(defmethod print-method Stx [this writer]
+(defmethod print-method Syntax [this writer]
   (binding [*out* writer]
     (pr (tagged-literal
          'scm/stx
@@ -37,7 +39,7 @@
            [(stx-datum this) (stx-context this)]
            (stx-datum this))))))
 
-(defmethod clojure.pprint/simple-dispatch Stx [x]
+(defmethod clojure.pprint/simple-dispatch Syntax [x]
   (clojure.pprint/simple-dispatch
    (tagged-literal
     'scm/stx
@@ -46,32 +48,97 @@
       (stx-datum x)))))
 
 (defn stx-reader [[datum ctx]]
-  (->Stx datum ctx))
+  (->Syntax datum ctx))
+
+(defn datum->syntax
+  ([datum]
+   (->Syntax datum nil))
+  ([datum ctxt-donor]
+   (->Syntax datum (stx-context ctxt-donor))))
+
+
+;;; improper list
+
+(deftype ImproperList [initial dot]
+  Object
+  (equals [x y]
+    (or (identical? x y)
+        (and (instance? ImproperList y)
+             (.equals initial (:initial y))
+             (.equals dot (:dot y)))))
+  clojure.lang.ILookup
+  (valAt [this k]
+    (.valAt this k nil))
+  (valAt [this k not-found]
+    (case k
+      :initial initial
+      :dot dot
+      not-found)))
+
+(defn improper-list? [x]
+  (instance? ImproperList x))
+
+(defn improper-list [& xs]
+  (assert (<= 2 (count xs))
+          "improper list에는 최소 두 개 이상의 요소가 있어야 합니다")
+  (->ImproperList (butlast xs) (last xs)))
+
+;; does not respect `*print-dup*` lol
+(defmethod print-method ImproperList [this writer]
+  (print-method (concat (:initial this)
+                        (list '. (:dot this)))
+                writer))
+
+(defmethod clojure.pprint/simple-dispatch ImproperList [this]
+  (clojure.pprint/simple-dispatch
+   (concat (:initial this)
+           (list '. (:dot this)))))
 
 
 ;;; r⁷rs reader
 
 (insta/defparser r7rs-parser (io/resource "r7rs.ebnf"))
 
-(defn read [s & {:as opts}]
-  (->> (insta/parse r7rs-parser s opts)
-       (insta/transform
-        {:boolean (fn [x]
-                    [:boolean
-                     (match x
-                       (:or "#t" "#true") true
-                       (:or "#f" "#false") false)])
-         :string (fn [& els]
-                   (apply str
-                          (for [e els]
-                            (match e
-                              "\\\\" "\\"
-                              "\\\"" "\""
-                              "\\n" "\n"
-                              _ e))))
-         :sign (fn
-                 ([] identity)
-                 ([x] (match x "-" - "+" identity)))
-         :num-10 (fn [sign digits]
-                   (sign (parse-long digits)))})))
+(defn read
+  "`read` 작업의 결과로 생성된 콘텍스트 필드는 초기에 비어 있다. 이후
+  `expand/expand` 작업을 통해 콘택스트 필드를 패울 수 있다."
+  [& {:keys [syntax? instaparse]
+      :or {syntax? false
+           instaparse {}}}]
+  (let [r (insta/parse r7rs-parser (slurp *in*)
+                       :start :datum-start
+                       instaparse)]
+    (if (insta/failure? r)
+      r
+      (insta/transform
+       {:boolean (fn [x]
+                   (match x
+                     (:or "#t" "#true") true
+                     (:or "#f" "#false") false))
+        :datum-start identity
+        ;; 그라머에 datum을 감추지 않은 고러서 대신 여기 모든 datum을
+        ;; 과정할 수 있었더다. 작업 한 개만으로 syntax object들 다
+        ;; 만들 수 있어서 이럼은 더 좋다.
+        :datum (fn [x]
+                 (->Syntax x ::no-scopes))
+        :number identity
+        :symbol symbol
+        :string (fn [& els]
+                  (apply str
+                         (for [e els]
+                           (match (into [] e)
+                             [\\ \\] \\
+                             [\\ \"] \\
+                             [\\ \n] \newline
+                             [c] c))))
+        :list list
+        :improper-list improper-list
+        :sign (fn
+                ([] identity)
+                ([x] (match x "-" - "+" identity)))
+        :num-10 (fn [sign digits]
+                  (sign (parse-long digits)))}
+       r))))
 
+(defn read-syntax [& {:as opts}]
+  (read (merge {:syntax? true} opts)))