maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

style(3p/lisp): expand tabs in npg, mime4cl and sclf

Browse source 
Done using

    find third_party/lisp/{sclf,mime4cl,npg} \
      -name '*.lisp' -or -name '*.asd' \
      -exec bash -c 'expand -i -t 8 "$0" | sponge "$0"' {} \;

Change-Id: If84afac9c1d5cbc74e137a5aa0ae61472f0f1e90
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5066
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
This commit is contained in:
sterni 2022-01-19 14:39:58 +01:00
parent 40014c70b3
commit 25cb0ad32f
25 changed files with 2467 additions and 2467 deletions
Download patch file Download diff file Expand all files Collapse all files

366
third_party/lisp/npg/src/define.lisp vendored
View file

@ -37,13 +37,13 @@ those that are not declared as strings in the grammar.")
the list of variables for the function reducing this production, those
that are non static and their unambiguous user-friendly names."
(flet ((unique (sym list)
(if (not (assoc sym list))
sym
(loop
for i of-type fixnum from 2
for x = (intern (format nil "~:@(~A~)~A" sym i))
while (assoc x list)
finally (return x)))))
(if (not (assoc sym list))
sym
(loop
for i of-type fixnum from 2
for x = (intern (format nil "~:@(~A~)~A" sym i))
while (assoc x list)
finally (return x)))))
(loop
for tok in tokens
for i of-type fixnum from 1
@ -54,8 +54,8 @@ that are non static and their unambiguous user-friendly names."
and when (symbolp tok)
collect (list (unique tok named-vars) arg) into named-vars
when (and (listp tok)
(symbolp (cadr tok)))
collect (list (unique (cadr tok) named-vars) arg) into named-vars
(symbolp (cadr tok)))
collect (list (unique (cadr tok) named-vars) arg) into named-vars
finally
(return (values args vars named-vars)))))
@ -63,56 +63,56 @@ that are non static and their unambiguous user-friendly names."
"Create a function with name NAME, arguments derived from TOKENS and
body ACTION. Return it's definition."
(let ((function
(multiple-value-bind (args vars named-vars)
(make-action-arguments tokens)
`(lambda ,args
(declare (ignorable ,@args))
(let (($vars (list ,@vars))
($all (list ,@args))
,@named-vars
($alist (list ,@(mapcar #'(lambda (v)
`(cons ',(intern (symbol-name (car v)))
,(cadr v)))
named-vars))))
(declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars)))
(flet ((make-object (&optional type args)
(apply #'make-instance (or type ',name)
(append args $alist))))
,action))))))
(multiple-value-bind (args vars named-vars)
(make-action-arguments tokens)
`(lambda ,args
(declare (ignorable ,@args))
(let (($vars (list ,@vars))
($all (list ,@args))
,@named-vars
($alist (list ,@(mapcar #'(lambda (v)
`(cons ',(intern (symbol-name (car v)))
,(cadr v)))
named-vars))))
(declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars)))
(flet ((make-object (&optional type args)
(apply #'make-instance (or type ',name)
(append args $alist))))
,action))))))
(when *compile-print*
(if *compile-verbose*
(format t "; Compiling ~S:~% ~S~%" name function)
(format t "; Compiling ~S~%" name)))
(format t "; Compiling ~S:~% ~S~%" name function)
(format t "; Compiling ~S~%" name)))
(compile name function)))
(defun define-rule (name productions)
"Accept a rule in EBNF-like syntax, translate it into a sexp and a
call to INSERT-RULE-IN-CURRENT-GRAMMAR."
(flet ((transform (productions)
(loop
for tok in productions
with prod = nil
with action = nil
with phase = nil
with new-prods = nil
while tok
do (cond ((eq tok :=)
(push (list (nreverse prod) action) new-prods)
(setf prod nil
action nil
phase :prod))
((eq tok :reduce)
(setf phase :action))
((eq tok :tag)
(setf phase :tag))
((eq phase :tag)
(setf action `(cons ,tok $vars)))
((eq phase :action)
(setf action tok))
((eq phase :prod)
(push tok prod)))
finally
(return (cdr (nreverse (cons (list (nreverse prod) action) new-prods)))))))
(loop
for tok in productions
with prod = nil
with action = nil
with phase = nil
with new-prods = nil
while tok
do (cond ((eq tok :=)
(push (list (nreverse prod) action) new-prods)
(setf prod nil
action nil
phase :prod))
((eq tok :reduce)
(setf phase :action))
((eq tok :tag)
(setf phase :tag))
((eq phase :tag)
(setf action `(cons ,tok $vars)))
((eq phase :action)
(setf action tok))
((eq phase :prod)
(push tok prod)))
finally
(return (cdr (nreverse (cons (list (nreverse prod) action) new-prods)))))))
(insert-rule-in-current-grammar name (transform productions))))
(defmacro defrule (name &rest productions)
@ -124,9 +124,9 @@ call to INSERT-RULE-IN-CURRENT-GRAMMAR."
return it."
(insert-rule-in-current-grammar
(gensym (concatenate 'string "OPT-"
(if (rule-p token)
(symbol-name (rule-name token))
(string-upcase token))))
(if (rule-p token)
(symbol-name (rule-name token))
(string-upcase token))))
`(((,token)) (()))))
(defun make-alternative-rule (tokens)
@ -134,24 +134,24 @@ return it."
(insert-rule-in-current-grammar
(gensym "ALT")
(mapcar #'(lambda (alternative)
`((,alternative)))
tokens)))
`((,alternative)))
tokens)))
(defun make-nonempty-list-rule (token &optional separator)
"Make a rule for a non-empty list (+ syntax) and return it."
(let ((rule-name (gensym (concatenate 'string "NELST-"
(if (rule-p token)
(symbol-name (rule-name token))
(string-upcase token))))))
(if (rule-p token)
(symbol-name (rule-name token))
(string-upcase token))))))
(insert-rule-in-current-grammar
rule-name
(if separator
`(((,token ,separator ,rule-name)
(cons $1 $3))
((,token) ,#'list))
`(((,token ,rule-name)
(cons $1 $2))
((,token) ,#'list))))))
`(((,token ,separator ,rule-name)
(cons $1 $3))
((,token) ,#'list))
`(((,token ,rule-name)
(cons $1 $2))
((,token) ,#'list))))))
(defun make-list-rule (token &optional separator)
"Make a rule for a possibly empty list (* syntax) return it."
@ -166,14 +166,14 @@ return it."
or (* NAME) or (+ NAME). This is used by the DEFRULE macro."
(if (symbolp tok)
(let* ((name (symbol-name tok))
(last (char name (1- (length name))))
;; this looks silly but we need to make sure that we
;; return symbols interned in this package, no one else
(op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *))))))
(if (and (> (length name) 1) op)
(list op
(intern (subseq name 0 (1- (length name)))))
tok))
(last (char name (1- (length name))))
;; this looks silly but we need to make sure that we
;; return symbols interned in this package, no one else
(op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *))))))
(if (and (> (length name) 1) op)
(list op
(intern (subseq name 0 (1- (length name)))))
tok))
tok))
(defun EBNF-to-SEBNF (tokens)
@ -184,10 +184,10 @@ EBNF syntax into a sexp-based EBNF syntax or SEBNF."
for token = (expand-production-token tok)
with new-tokens = '()
do (cond ((member token '(* + ?))
(setf (car new-tokens)
(list token (car new-tokens))))
(t
(push token new-tokens)))
(setf (car new-tokens)
(list token (car new-tokens))))
(t
(push token new-tokens)))
finally (return (nreverse new-tokens))))
(defun SEBNF-to-BNF (tokens)
@ -195,21 +195,21 @@ EBNF syntax into a sexp-based EBNF syntax or SEBNF."
it into BNF. The production is simplified but the current grammar is
populated with additional rules."
(flet ((make-complex-token-rule (tok)
(ecase (car tok)
(* (apply #'make-list-rule (cdr tok)))
(+ (apply #'make-nonempty-list-rule (cdr tok)))
(? (make-optional-rule (cadr tok)))
(or (make-alternative-rule (cdr tok))))))
(ecase (car tok)
(* (apply #'make-list-rule (cdr tok)))
(+ (apply #'make-nonempty-list-rule (cdr tok)))
(? (make-optional-rule (cadr tok)))
(or (make-alternative-rule (cdr tok))))))
(loop
for token in tokens
with new-tokens = '()
with keywords = '()
do (cond ((listp token)
(push (make-complex-token-rule token) new-tokens))
(t
(push token new-tokens)
(when (const-terminal-p token)
(push token keywords))))
(push (make-complex-token-rule token) new-tokens))
(t
(push token new-tokens)
(when (const-terminal-p token)
(push token keywords))))
finally (return (values (nreverse new-tokens) keywords)))))
(defun make-default-action-function (name tokens)
@ -220,28 +220,28 @@ list and in case only a variable token is available that one is
returned (not included in a list). If all the tokens are
constant, then all of them are returned in a list."
(cond ((null tokens)
;; if the production matched the empty list (no tokens) we
;; return always nil, that is the function LIST applied to no
;; arguments
#'list)
((null (cdr tokens))
;; if the production matches just one token we simply return
;; that
#'identity)
(*smart-default-reduction*
;; If we are required to be "smart" then create a function
;; that simply returns the non static tokens of the
;; production. If the production doesn't have nonterminal,
;; then return all the tokens. If the production has only
;; one argument then return that one only.
(make-action-function name tokens '(cond
((null $vars) $all)
((null (cdr $vars)) (car $vars))
(t $vars))))
(t
;; in all the other cases we return all the token matching
;; the production
#'list)))
;; if the production matched the empty list (no tokens) we
;; return always nil, that is the function LIST applied to no
;; arguments
#'list)
((null (cdr tokens))
;; if the production matches just one token we simply return
;; that
#'identity)
(*smart-default-reduction*
;; If we are required to be "smart" then create a function
;; that simply returns the non static tokens of the
;; production. If the production doesn't have nonterminal,
;; then return all the tokens. If the production has only
;; one argument then return that one only.
(make-action-function name tokens '(cond
((null $vars) $all)
((null (cdr $vars)) (car $vars))
(t $vars))))
(t
;; in all the other cases we return all the token matching
;; the production
#'list)))
(defun make-production-from-descr (name production-description)
"Take a production NAME and its description in the form of a sexp
@ -250,28 +250,28 @@ keywords."
(destructuring-bind (tokens &optional action) production-description
(let ((expanded-tokens (EBNF-to-SEBNF tokens)))
(multiple-value-bind (production-tokens keywords)
(sebnf-to-bnf expanded-tokens)
(sebnf-to-bnf expanded-tokens)
(let ((funct
(cond ((not action)
(make-default-action-function name expanded-tokens))
((or (listp action)
;; the case when the action is simply to
;; return a token (ie $2) or a constant value
(symbolp action))
(make-action-function name expanded-tokens action))
((functionp action)
action)
(t ; action is a constant
#'(lambda (&rest args)
(declare (ignore args))
action)))))
(values
;; Make a promise instead of actually resolving the
;; nonterminals. This avoids endless recursion.
(make-production :tokens production-tokens
:tokens-length (length production-tokens)
:action funct)
keywords))))))
(cond ((not action)
(make-default-action-function name expanded-tokens))
((or (listp action)
;; the case when the action is simply to
;; return a token (ie $2) or a constant value
(symbolp action))
(make-action-function name expanded-tokens action))
((functionp action)
action)
(t ; action is a constant
#'(lambda (&rest args)
(declare (ignore args))
action)))))
(values
;; Make a promise instead of actually resolving the
;; nonterminals. This avoids endless recursion.
(make-production :tokens production-tokens
:tokens-length (length production-tokens)
:action funct)
keywords))))))
(defun remove-immediate-left-recursivity (rule)
"Turn left recursive rules of the type
@ -281,7 +281,7 @@ into
A2 -> x A2 | E
where E is the empty production."
(let ((name (rule-name rule))
(productions (rule-productions rule)))
(productions (rule-productions rule)))
(loop
for prod in productions
for tokens = (prod-tokens prod)
@ -291,40 +291,40 @@ where E is the empty production."
else
collect prod into non-left-recursive
finally
;; found any left recursive production?
(when left-recursive
(warn "rule ~S is left recursive" name)
(let ((new-rule (make-rule :name (gensym "REWRITE"))))
;; A -> y A2
(setf (rule-productions rule)
(mapcar #'(lambda (p)
(let ((tokens (prod-tokens p))
(action (prod-action p)))
(make-production :tokens (append tokens (list new-rule))
:tokens-length (1+ (prod-tokens-length p))
:action #'(lambda (&rest args)
(let ((f-A2 (car (last args)))
(head (butlast args)))
(funcall f-A2 (apply action head)))))))
non-left-recursive))
;; A2 -> x A2 | E
(setf (rule-productions new-rule)
(append
(mapcar #'(lambda (p)
(let ((tokens (prod-tokens p))
(action (prod-action p)))
(make-production :tokens (append (cdr tokens) (list new-rule))
:tokens-length (prod-tokens-length p)
:action #'(lambda (&rest args)
(let ((f-A2 (car (last args)))
(head (butlast args)))
#'(lambda (x)
(funcall f-A2 (apply action x head))))))))
left-recursive)
(list
(make-production :tokens nil
:tokens-length 0
:action #'(lambda () #'(lambda (arg) arg)))))))))))
;; found any left recursive production?
(when left-recursive
(warn "rule ~S is left recursive" name)
(let ((new-rule (make-rule :name (gensym "REWRITE"))))
;; A -> y A2
(setf (rule-productions rule)
(mapcar #'(lambda (p)
(let ((tokens (prod-tokens p))
(action (prod-action p)))
(make-production :tokens (append tokens (list new-rule))
:tokens-length (1+ (prod-tokens-length p))
:action #'(lambda (&rest args)
(let ((f-A2 (car (last args)))
(head (butlast args)))
(funcall f-A2 (apply action head)))))))
non-left-recursive))
;; A2 -> x A2 | E
(setf (rule-productions new-rule)
(append
(mapcar #'(lambda (p)
(let ((tokens (prod-tokens p))
(action (prod-action p)))
(make-production :tokens (append (cdr tokens) (list new-rule))
:tokens-length (prod-tokens-length p)
:action #'(lambda (&rest args)
(let ((f-A2 (car (last args)))
(head (butlast args)))
#'(lambda (x)
(funcall f-A2 (apply action x head))))))))
left-recursive)
(list
(make-production :tokens nil
:tokens-length 0
:action #'(lambda () #'(lambda (arg) arg)))))))))))
(defun remove-left-recursivity-from-rules (rules)
(loop
@ -338,9 +338,9 @@ where E is the empty production."
(loop
for rule being each hash-value in rules
do (loop
for production in (rule-productions rule)
do (setf (prod-tokens production)
(resolve-nonterminals (prod-tokens production) rules)))))
for production in (rule-productions rule)
do (setf (prod-tokens production)
(resolve-nonterminals (prod-tokens production) rules)))))
(defun make-rule-productions (rule-name production-descriptions)
"Return a production object that belongs to RULE-NAME made according
@ -352,12 +352,12 @@ to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR."
with productions = '()
with keywords = '()
do (progn
(multiple-value-bind (production keyws)
(make-production-from-descr prod-name descr)
(push production productions)
(setf keywords (append keyws keywords))))
(multiple-value-bind (production keyws)
(make-production-from-descr prod-name descr)
(push production productions)
(setf keywords (append keyws keywords))))
finally (return
(values (nreverse productions) keywords))))
(values (nreverse productions) keywords))))
(defun create-rule (name production-descriptions)
"Return a new rule object together with a list of keywords making up
@ -365,7 +365,7 @@ the production definitions."
(multiple-value-bind (productions keywords)
(make-rule-productions name production-descriptions)
(values (make-rule :name name :productions productions)
keywords)))
keywords)))
(defun insert-rule-in-current-grammar (name productions)
"Add rule to the current grammar and its keywords to the keywords
@ -384,18 +384,18 @@ instead."
"Given a list of production tokens, try to expand the nonterminal
ones with their respective rule from the the RULES pool."
(flet ((resolve-symbol (sym)
(or (find-rule sym rules)
sym)))
(or (find-rule sym rules)
sym)))
(mapcar #'(lambda (tok)
(if (symbolp tok)
(resolve-symbol tok)
tok))
tokens)))
(if (symbolp tok)
(resolve-symbol tok)
tok))
tokens)))
(defun reset-grammar ()
"Empty the current grammar from any existing rule."
(setf *rules* (make-rules-table)
*keywords* (make-keywords-table)))
*keywords* (make-keywords-table)))
(defun generate-grammar (&optional (equal-p #'string-equal))
"Return a GRAMMAR structure suitable for the PARSE function, using
@ -404,5 +404,5 @@ match the input tokens; it defaults to STRING-EQUAL."
(resolve-all-nonterminals *rules*)
(remove-left-recursivity-from-rules *rules*)
(make-grammar :rules *rules*
:keywords *keywords*
:equal-p equal-p))
:keywords *keywords*
:equal-p equal-p))