From 48f85cd0f651d269dfc1c641befe1fb1e4c50486 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Mon, 25 May 2009 21:33:06 +0000
Subject: 	* interp/sys-constants.boot ($OperatorFunctionNames): New. 
 * interp/metalex.lisp (|PARSE-OperatorFunctionName|): New. Use it. 	*
 interp/fnewmeta.lisp (|PARSE-Category|): Handle operator 	function
 names.

---
 src/interp/fnewmeta.lisp      | 3 ++-
 src/interp/metalex.lisp       | 7 +++++++
 src/interp/newaux.lisp        | 2 +-
 src/interp/sys-constants.boot | 9 +++++++++
 4 files changed, 19 insertions(+), 2 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index 3a0ffa89..c819222d 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -420,7 +420,8 @@
                          (CONS (POP-STACK-2)
                                (APPEND (POP-STACK-1) NIL)))))
           (AND (ACTION (SETQ G1 (LINE-NUMBER CURRENT-LINE)))
-               (|PARSE-Application|)
+               (OR (|PARSE-Application|)
+		   (|PARSE-OperatorFunctionName|))
                (MUST (OR (AND (MATCH-ADVANCE-STRING ":")
                               (MUST (|PARSE-Expression|))
                               (PUSH-REDUCTION '|PARSE-Category|
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index aebd2aaa..f89ebf6e 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -636,6 +636,13 @@ as keywords.")
 (defun-parse-token KEYWORD)
 (defun-parse-token ARGUMENT-DESIGNATOR)
 
+(defun |PARSE-OperatorFunctionName| ()
+  (let ((tok (match-current-token 'keyword)))
+    (when (and tok (member (token-symbol tok) |$OperatorFunctionNames|))
+      (Push-Reduction 'IDENTIFIER-TOKEN
+		      (copy-tree (token-symbol tok)))
+      (action (advance-token)))))
+
 ; Meta tokens fall into the following categories:
 ;
 ;               Number
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index 3d328de7..d8ac603e 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -205,7 +205,7 @@
 ;; is `+' for Integers.
  
 (mapcar #'(lambda (x) (MAKEPROP X 'GENERIC 'TRUE))
-        '(- = * |rem| |mod| |quo| |div| / ** |exquo| + - < > <= >= ^= ))
+        '(- = * |rem| |mod| |quo| |div| / ** |exquo| + - < > <= >= ~= ))
 
 (defun SPECIALCASESYNTAX () (OR (AND (char= TOK '#\#) (DIGITP CHR))))
  
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index ab119c84..b50e1d56 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -731,3 +731,12 @@ $KillLispSystem == 14
 
 $SpadReaderTag ==
   "SPAD__READER"
+
+--%
+
+++ List of operator names that can be overloaded in libraries.
+$OperatorFunctionNames ==
+  ["**", "^", "*", "/", "rem", "quo", "mod", "div", "exquo",
+    "+", "-", ">", ">=", "=", "~=", "<", "<=", "~", "not",
+     "case", "and", "or", "<<", ">>" ]
+
-- 
cgit v1.2.3