rairlab/Spectra
1
0
Fork 0
mirror of https://github.com/RAIRLab/Spectra.git synced 2025-10-05 22:21:20 +00:00
Code Issues Projects Releases Packages Wiki Activity

First commits.

Browse source
This commit is contained in:
Naveen Sundar Govindarajulu 2017-01-14 22:08:51 -05:00
parent ecd7c00454
commit 8c78a2f8e5
237 changed files with 36267 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

105
snark-20120808r02/src/infix-operators.lisp Normal file
View file

@ -0,0 +1,105 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-infix-reader -*-
;;; File: infix-operators.lisp
;;; The contents of this file are subject to the Mozilla Public License
;;; Version 1.1 (the "License"); you may not use this file except in
;;; compliance with the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS"
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
;;; License for the specific language governing rights and limitations
;;; under the License.
;;;
;;; The Original Code is SNARK.
;;; The Initial Developer of the Original Code is SRI International.
;;; Portions created by the Initial Developer are Copyright (C) 1981-2011.
;;; All Rights Reserved.
;;;
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
(in-package :snark-infix-reader)
(defvar *infix-operators* nil)
(defvar *prefix-operators* nil)
(defvar *postfix-operators* nil)
(defparameter infix-types '(:xfx :xfy :yfx :yfy))
(defparameter prefix-types '(:fx :fy))
(defparameter postfix-types '(:xf :yf))
(defstruct (operator
(:copier nil))
(input-string nil :read-only t)
(type nil :read-only t)
(precedence nil :read-only t)
(output-symbol nil :read-only t))
(definline infix-operator-p (op)
(and (operator-p op) (member (operator-type op) infix-types)))
(definline prefix-operator-p (op)
(and (operator-p op) (member (operator-type op) prefix-types)))
(definline postfix-operator-p (op)
(and *postfix-operators* (operator-p op) (member (operator-type op) postfix-types)))
(defun initialize-operator-syntax ()
(setf *infix-operators* nil)
(setf *prefix-operators* nil)
(setf *postfix-operators* nil))
(definline operator-lookup0 (input-string list)
(dolist (op list nil)
(when (string= input-string (operator-input-string op))
(return op))))
(definline infix-operator-lookup (input-string)
(operator-lookup0 input-string *infix-operators*))
(definline prefix-operator-lookup (input-string)
(operator-lookup0 input-string *prefix-operators*))
(definline postfix-operator-lookup (input-string)
(operator-lookup0 input-string *postfix-operators*))
(defun update-operator-syntax (input-string op listname)
(let ((l (remove input-string (symbol-value listname) :key #'operator-input-string :test #'string=)))
(setf (symbol-value listname) (if op (cons op l) l))))
(defun declare-operator-syntax (input-string type &optional (precedence nil precedence-supplied) (output-symbol input-string))
;; (declare-operator-syntax "<=>" :xfy 505) declares <=> as a type xfy operator with precedence 505
;; (declare-operator-syntax "<=>" :xfy nil) undeclares <=> as a type xfy operator
;; (declare-operator-syntax "<=>" nil) undeclares <=> as any kind of operator
(if (null type)
(cl:assert (null precedence))
(progn
(cl:assert (or (member type infix-types) (member type prefix-types) (member type postfix-types)))
(cl:assert precedence-supplied)
(cl:assert (implies precedence (integerp precedence)))))
(unless (stringp input-string)
(setf input-string (string input-string)))
(unless (implies (and type precedence) (symbolp output-symbol))
(setf output-symbol (intern (string output-symbol))))
(let ((op (and type precedence (make-operator :input-string input-string :type type :precedence precedence :output-symbol output-symbol))))
(cond
((member type infix-types)
(update-operator-syntax input-string op '*infix-operators*))
((member type prefix-types)
(update-operator-syntax input-string op '*prefix-operators*))
((member type postfix-types)
(update-operator-syntax input-string op '*postfix-operators*))
(t
(update-operator-syntax input-string op '*infix-operators*)
(update-operator-syntax input-string op '*prefix-operators*)
(update-operator-syntax input-string op '*postfix-operators*)))
op))
(definline reduce-before? (op1 op2)
(let ((p1 (operator-precedence op1))
(p2 (operator-precedence op2)))
(or (< p1 p2)
(and (eql p1 p2)
(member (operator-type op2) '(:yfx :yfy :yf))
(member (operator-type op1) '(:xfx :yfx :fx))))))
;;; infix-operators.lisp EOF