Zander671/truth-table
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make web server

Browse Source
This commit is contained in:
Alexander Rosenberg
2024-09-05 14:46:05 -07:00
parent 9e35fed164
commit c6cadc3123
11 changed files with 525 additions and 142 deletions
Download Patch File Download Diff File Expand all files Collapse all files

144
parse.lisp
View File

@ -258,79 +258,83 @@ found variables."
(operands '())
(oper-poses '())
(last-was-operand nil))
(dotokens (token token-pos str)
(:multi-char-names multi-char-names)
(destructuring-bind (type value) (interpret-token token)
(cond
;; unknown type
((not type)
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "unknown token"))
;; operand
((eq type 'operand)
(when last-was-operand
;; two operands next to each other often means "and" implicitly
(unless implicit-and
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "expected operator, found operand"))
(flet ((push-operator (value pos)
(multiple-value-bind (new-oper new-opan pop-count)
(apply-lower-precedent (operator-precedence 'and)
operators operands str token-pos)
(apply-lower-precedent (operator-precedence value)
operators operands str pos)
(setq operators new-oper
operands new-opan)
(dotimes (i pop-count)
(pop oper-poses)))
(push 'and operators)
(push value operators)
(push pos oper-poses)))
(dotokens (token token-pos str)
(:multi-char-names multi-char-names)
(destructuring-bind (type value) (interpret-token token)
(cond
;; unknown type
((not type)
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "unknown token"))
;; operand
((eq type 'operand)
(when last-was-operand
;; two operands next to each other often means "and" implicitly
(unless implicit-and
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "expected operator, found operand"))
(push-operator 'and token-pos))
(unless (member value '(true false))
(pushnew value found-vars :test 'equal))
(push value operands)
(setq last-was-operand t))
((eq value 'open-paren)
(when last-was-operand
;; an open parenthesis directly following an operator is also a
;; signal of an implicit "and"
(unless implicit-and
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "expected operator, found open parenthesis"))
(push-operator 'and token-pos)
(setq last-was-operand nil))
(push value operators)
(push token-pos oper-poses))
(unless (member value '(true false))
(pushnew value found-vars :test 'equal))
(push value operands)
(setq last-was-operand t))
;; open and close paren don't touch `last-was-operand'
((eq value 'open-paren)
(push value operators)
(push token-pos oper-poses))
((eq value 'close-paren)
(loop while (not (eq (car operators) 'open-paren))
when (null operators) do
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "no matching open parenthesis")
do
(setf (values operators operands)
(apply-one-operator operators operands
str token-pos))
(pop oper-poses))
;; remove the open-paren
(pop operators)
(pop oper-poses))
;; operator
(t
(multiple-value-bind (new-oper new-opan pop-count)
(apply-lower-precedent (operator-precedence value)
operators operands str token-pos)
(setq operators new-oper
operands new-opan)
(dotimes (i pop-count)
(pop oper-poses)))
(push value operators)
(push token-pos oper-poses)
(setq last-was-operand nil)))))
(loop while operators
for oper-pos = (pop oper-poses)
when (eq (car operators) 'open-paren) do
(error 'proposition-parse-error
:message "no matching closing parenthesis"
:proposition str
:position oper-pos)
do
(setf (values operators operands)
(apply-one-operator operators operands
str oper-pos)))
;; return variables in the order we found them
(values (car operands) (nreverse found-vars))))
;; close paren doesn't touch `last-was-operand'
((eq value 'close-paren)
(loop while (not (eq (car operators) 'open-paren))
when (null operators) do
(error 'proposition-parse-error
:position token-pos
:proposition str
:message "no matching open parenthesis")
do
(setf (values operators operands)
(apply-one-operator operators operands
str token-pos))
(pop oper-poses))
;; remove the open-paren
(pop operators)
(pop oper-poses))
;; operator
(t
(push-operator value token-pos)
(setq last-was-operand nil)))))
(loop while operators
for oper-pos = (pop oper-poses)
when (eq (car operators) 'open-paren) do
(error 'proposition-parse-error
:message "no matching closing parenthesis"
:proposition str
:position oper-pos)
do
(setf (values operators operands)
(apply-one-operator operators operands
str oper-pos)))
;; return variables in the order we found them
(values (car operands) (nreverse found-vars)))))