ECO-CANON-2: RED witness for semantic callable identity

crates/my-lisp-cli/tests/uk_surface_audit_projection.rs

@@ -0,0 +1,29 @@
+use std::path::{Path, PathBuf};
+use std::process::Command;
+
+fn repo_root() -> PathBuf {
+    PathBuf::from(env!("CARGO_MANIFEST_DIR")).join("../..")
+}
+
+fn my_lisp(cwd: &Path) -> Command {
+    let mut command = Command::new(env!("CARGO_BIN_EXE_my-lisp"));
+    command.current_dir(cwd);
+    command
+}
+
+#[test]
+fn uk_surface_audit_generator_runs_through_real_my_lisp_cli() {
+    let root = repo_root();
+    let script = root.join("scripts/generate-uk-surface-audit.my");
+    let output = my_lisp(&root)
+        .arg(&script)
+        .output()
+        .expect("UK surface audit generator should run through the real my-lisp CLI");
+
+    assert!(
+        output.status.success(),
+        "language-owned UK surface audit generator must run successfully\nstdout:\n{}\nstderr:\n{}",
+        String::from_utf8_lossy(&output.stdout),
+        String::from_utf8_lossy(&output.stderr)
+    );
+}

crates/my-lisp/src/eval/special_forms/core.rs

@@ -161,5 +161,13 @@ pub(crate) fn eq_values(left: Value, right: Value, span: Span) -> Result<Value,
             span,
         ));
     }
-    Ok(Value::truth(left == right))
+
+    // Callable identity is observed through the stable handle selected by the
+    // registry-owned Canon mapping. `Rc::ptr_eq` is only the runtime mechanism:
+    // which surfaces share that handle is decided upstream by semantic ID.
+    let same_identity = match (&left, &right) {
+        (Value::Builtin(left), Value::Builtin(right)) => Rc::ptr_eq(left, right),
+        _ => left == right,
+    };
+    Ok(Value::truth(same_identity))
 }

crates/my-lisp/tests/canonical_source_extension.rs

@@ -0,0 +1,23 @@
+use std::fs;
+use std::path::PathBuf;
+
+fn repo_root() -> PathBuf {
+    PathBuf::from(env!("CARGO_MANIFEST_DIR")).join("../..")
+}
+
+#[test]
+fn ukrainian_staging_profile_does_not_claim_a_legacy_extension_as_canonical() {
+    let profile = fs::read_to_string(
+        repo_root().join("lib/surface/український-профіль-джерела.всм"),
+    )
+    .expect("Ukrainian staging profile must be readable");
+
+    assert!(
+        profile.contains("(основне-розширення \".lisp\")"),
+        "#81 declares .lisp the canonical source extension; the Ukrainian staging profile must track that policy"
+    );
+    assert!(
+        !profile.contains("(основне-розширення \".всм\")"),
+        "legacy .всм may remain a compatibility alias, but must not be labeled the primary/canonical extension"
+    );
+}

crates/my-lisp/tests/first_class_builtins.rs

@@ -87,3 +87,40 @@ fn lexical_shadowing_of_builtin_name() {
         "6"
     );
 }
+
+#[test]
+fn canon_peer_surfaces_observe_one_semantic_callable_identity() {
+    use my_lisp::semantic_registry_export::admitted_surfaces_for_semantic_id;
+
+    let car_surfaces = admitted_surfaces_for_semantic_id("0005");
+    assert!(
+        car_surfaces.len() >= 2,
+        "0005 must admit multiple surfaces for the identity witness"
+    );
+
+    for left in &car_surfaces {
+        for right in &car_surfaces {
+            let source = format!("(eq {} {})", left.name, right.name);
+            assert_eq!(
+                eval_source(&source),
+                "t",
+                "peer surfaces {}:{} and {}:{} share semantic ID 0005 and must be eq by semantic identity",
+                left.namespace,
+                left.name,
+                right.namespace,
+                right.name
+            );
+        }
+    }
+
+    let cdr_surface = admitted_surfaces_for_semantic_id("0006")
+        .into_iter()
+        .next()
+        .expect("0006 must admit at least one surface");
+    let source = format!("(eq {} {})", car_surfaces[0].name, cdr_surface.name);
+    assert_eq!(
+        eval_source(&source),
+        "()",
+        "different semantic IDs 0005 and 0006 must remain observably distinct"
+    );
+}

lib/surface/український-профіль-джерела.всм

@@ -22,7 +22,7 @@
 
   (політика
     (основна-людська-мова українська)
-    (основне-розширення ".всм")
+    (основне-розширення ".lisp")
     (повні-слова t)
     (програмістські-скорочення заборонені-за-замовчуванням)
     (кодування utf-8-nfc)

scripts/generate-uk-surface-audit.my

@@ -0,0 +1,205 @@
+; scripts/generate-uk-surface-audit.my — generated Ukrainian surface inventory
+; for my-lisp#85. This is an AUDIT PROJECTION, never semantic authority.
+;
+; Authority path:
+;   semantic-registry.wsm
+;       -> scripts/generate-function-table.my
+;       -> lib/generated/function-table.wsm
+;       -> this audit projection
+;
+; Candidate evidence path:
+;   lib/surface/український-профіль-джерела.всм
+; Candidate spellings remain proposals. `lib/generated/function-table.wsm`
+; is a checked projection, not a second semantic authority. This generator
+; MUST NOT promote staging candidates into that current `full-uk` projection.
+;
+; Output:
+;   lib/generated/uk-surface-audit.wsm
+;
+; Usage from repo root:
+;   cargo run -p my-lisp-cli --bin my-lisp -- scripts/generate-uk-surface-audit.my
+
+(def str+
+  (lambda args (reduce (lambda (acc s) (string-append acc s)) "" args)))
+
+(def pad4
+  (lambda (n)
+    (let ((s (number->string n)))
+      (cond
+        ((eq (string-length s) 1) (string-append "000" s))
+        ((eq (string-length s) 2) (string-append "00" s))
+        ((eq (string-length s) 3) (string-append "0" s))
+        (t s)))))
+
+(def second (lambda (xs) (car (cdr xs))))
+(def third (lambda (xs) (car (cdr (cdr xs)))))
+(def fourth (lambda (xs) (car (cdr (cdr (cdr xs))))))
+(def fifth (lambda (xs) (car (cdr (cdr (cdr (cdr xs)))))))
+(def sixth (lambda (xs) (car (cdr (cdr (cdr (cdr (cdr xs))))))))
+(def seventh (lambda (xs) (car (cdr (cdr (cdr (cdr (cdr (cdr xs)))))))))
+(def eighth (lambda (xs) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr xs))))))))))
+(def ninth (lambda (xs) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr xs)))))))))))
+
+(def join-newline-onto
+  (lambda (strings acc)
+    (cond
+      ((atom strings) acc)
+      ((eq acc "") (join-newline-onto (cdr strings) (car strings)))
+      (t (join-newline-onto (cdr strings) (str+ acc "\n" (car strings)))))))
+(def join-newline (lambda (strings) (join-newline-onto strings "")))
+
+; Function-table rows have the generated schema:
+; (id formal (uk word status) (full-uk word status) (en word status)
+;     (sa word status) (sym word status) primary-status authority)
+(def ft-form (car (read-all (read-file "lib/generated/function-table.wsm"))))
+(def ft-rows (cdr ft-form))
+
+(def profile-form
+  (car (read-all (read-file "lib/surface/український-профіль-джерела.всм"))))
+
+(def find-section
+  (lambda (name sections)
+    (cond
+      ((atom sections) (quote ()))
+      ((and (not (atom (car sections))) (eq (car (car sections)) name))
+       (car sections))
+      (t (find-section name (cdr sections))))))
+
+(def candidate-section (find-section (quote назви) (cdr profile-form)))
+(def candidate-rows
+  (cond
+    ((atom candidate-section) (quote ()))
+    (t (cdr candidate-section))))
+
+(def find-candidate-row
+  (lambda (sid rows)
+    (cond
+      ((atom rows) (quote ()))
+      ((eq (car (car rows)) sid) (car rows))
+      (t (find-candidate-row sid (cdr rows))))))
+
+(def surface-word (lambda (surface) (second surface)))
+(def surface-status (lambda (surface) (third surface)))
+
+(def missing-surface?
+  (lambda (surface)
+    (or (eq (surface-status surface) (quote missing))
+        (eq (surface-word surface) (quote —)))))
+
+; Classification here is intentionally conservative. The audit may report a
+; candidate, but only an explicit later review may classify it as compact,
+; ambiguous, etc. We therefore never infer linguistic facts from spelling.
+(def audit-class
+  (lambda (uk candidate)
+    (cond
+      ((eq (surface-status uk) (quote compatibility-only)) (quote compatibility-only))
+      ((missing-surface? uk) (quote needs-research))
+      ((atom candidate) (quote needs-research))
+      ((eq (second candidate) (third candidate)) (quote full))
+      (t (quote needs-research)))))
+
+(def candidate-full-word
+  (lambda (candidate)
+    (cond ((atom candidate) (quote —))
+          (t (third candidate)))))
+
+(def candidate-evidence-status
+  (lambda (candidate)
+    (cond ((atom candidate) (quote no-staging-evidence))
+          (t (fourth candidate)))))
+
+; `candidate-compact-uk` belongs to #86/#89. #85 must expose the empty slot,
+; not invent abbreviations while performing an inventory.
+(def candidate-compact-word (lambda () (quote —)))
+
+(def ambiguity-status
+  (lambda (candidate)
+    (cond
+      ((atom candidate) (quote needs-research))
+      (t (quote not-yet-assessed)))))
+
+(def render-row
+  (lambda (row)
+    (let* ((sid (car row))
+           (uk (third row))
+           (full-authority (fourth row))
+           (en (fifth row))
+           (sa (sixth row))
+           (sym (seventh row))
+           (primary (eighth row))
+           (candidate (find-candidate-row sid candidate-rows))
+           (class (audit-class uk candidate))
+           (candidate-full (candidate-full-word candidate))
+           (candidate-status (candidate-evidence-status candidate))
+           (ambiguity (ambiguity-status candidate)))
+      (str+
+        "  (row " (pad4 sid)
+        " (current-uk " (write-to-string (surface-word uk)) " "
+                         (write-to-string (surface-status uk)) ")"
+        " (authoritative-full-uk " (write-to-string (surface-word full-authority)) " "
+                                  (write-to-string (surface-status full-authority)) ")"
+        " (en " (write-to-string (surface-word en)) " "
+                 (write-to-string (surface-status en)) ")"
+        " (sa " (write-to-string (surface-word sa)) " "
+                 (write-to-string (surface-status sa)) ")"
+        " (sym " (write-to-string (surface-word sym)) " "
+                  (write-to-string (surface-status sym)) ")"
+        " (primary-status " (write-to-string primary) ")"
+        " (class " (write-to-string class) ")"
+        " (candidate-full-uk " (write-to-string candidate-full) ")"
+        " (candidate-full-status " (write-to-string candidate-status) ")"
+        " (candidate-compact-uk " (write-to-string (candidate-compact-word)) ")"
+        " (ambiguity " (write-to-string ambiguity) ")"
+        " (evidence generated-function-table staging-profile))"))))
+
+(def count-class
+  (lambda (wanted rows acc)
+    (cond
+      ((atom rows) acc)
+      (t
+       (let* ((sid (car (car rows)))
+              (uk (third (car rows)))
+              (candidate (find-candidate-row sid candidate-rows))
+              (class (audit-class uk candidate)))
+         (count-class wanted (cdr rows)
+           (cond ((eq class wanted) (+ acc 1))
+                 (t acc))))))))
+
+(def count-candidates
+  (lambda (rows acc)
+    (cond
+      ((atom rows) acc)
+      (t
+       (count-candidates (cdr rows)
+         (cond ((atom (find-candidate-row (car (car rows)) candidate-rows)) acc)
+               (t (+ acc 1))))))))
+
+(def total (length ft-rows))
+(def full-count (count-class (quote full) ft-rows 0))
+(def compatibility-count (count-class (quote compatibility-only) ft-rows 0))
+(def needs-research-count (count-class (quote needs-research) ft-rows 0))
+(def candidate-count (count-candidates ft-rows 0))
+
+(def header
+  (list
+    "; GENERATED — DO NOT EDIT BY HAND"
+    "; Semantic authority: lib/surface/semantic-registry.wsm via lib/generated/function-table.wsm"
+    "; Candidate evidence only: lib/surface/український-профіль-джерела.всм"
+    "; Generator: scripts/generate-uk-surface-audit.my (my-lisp#85)"
+    "; candidate-full-uk is NOT automatically promoted into authoritative full-uk"
+    ""
+    "(uk-surface-audit/1"
+    (str+ "  (summary (total " (number->string total) ")"
+          " (full " (number->string full-count) ")"
+          " (already-compact 0)"
+          " (ambiguous 0)"
+          " (needs-research " (number->string needs-research-count) ")"
+          " (compatibility-only " (number->string compatibility-count) ")"
+          " (staging-evidence " (number->string candidate-count) "))")
+    "  (rows"))
+
+(def body (join-newline (append header (map render-row ft-rows))))
+(def output (str+ body "\n  )\n)\n"))
+
+(write-file "lib/generated/uk-surface-audit.wsm" output)
+(print (str+ "uk-surface-audit: " (number->string total) " identities written"))