Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
parenscript
parenscript
Commits
e12e1abb
Verified
Commit
e12e1abb
authored
Oct 24, 2018
by
Vladimir Sedach
Browse files
Got rid of the unnecessary crud around optimizing away .call(this)
parent
c202f5d0
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/compiler.lisp
View file @
e12e1abb
...
...
@@ -63,14 +63,18 @@
(
list
"break"
"case"
"catch"
"continue"
"default"
"delete"
"do"
"else"
"finally"
"for"
"function"
"if"
"in"
"instanceof"
"new"
"return"
"switch"
"this"
"throw"
"try"
"typeof"
"var"
"void"
"while"
"with"
"abstract"
"boolean"
"byte"
"char"
"class"
"const"
"debugger"
"double"
"enum"
"export"
"extends"
"final"
"float"
"goto"
"implements"
"import"
"int"
"interface"
"long"
"native"
"package"
"private"
"protected"
"public"
"short"
"static"
"super"
"synchronized"
"throws"
"transient"
"volatile"
"{}"
"true"
"false"
"null"
"undefined"
))
(
defvar
*lambda-wrappable-statements*
;; break, return, continue not included
'
(
throw
switch
for
for-in
while
try
block
))
"abstract"
"boolean"
"byte"
"char"
"class"
"const"
"debugger"
"double"
"enum"
"export"
"extends"
"final"
"float"
"goto"
"implements"
"import"
"int"
"interface"
"long"
"native"
"package"
"private"
"protected"
"public"
"short"
"static"
"super"
"synchronized"
"throws"
"transient"
"volatile"
"{}"
"true"
"false"
"null"
"undefined"
))
(
defvar
*lambda-wrappable-statements*
'
(
throw
switch
for
for-in
while
try
block
)
"Statement special forms that can be wrapped in a lambda to make
them into expressions. Control transfer forms like BREAK, RETURN,
and CONTINUE need special treatment, and are not included."
)
(
defun
reserved-symbol-p
(
symbol
)
(
find
(
string-downcase
(
string
symbol
))
*reserved-symbol-names*
:test
#'
string=
))
...
...
@@ -102,7 +106,9 @@
(
or
(
gethash
(
car
form
)
*special-expression-operators*
)
(
gethash
(
car
form
)
*special-statement-operators*
))))
;;; scoping and lexical environment
;;; naming, scoping, and lexical environment
(
defvar
*ps-gensym-counter*
0
)
(
defvar
*vars-needing-to-be-declared*
()
"This special variable is expected to be bound to a fresh list by
...
...
@@ -265,20 +271,6 @@ return NIL."
(
values
(
ps-macroexpand
form1
)
t
)
form1
)))
;;; lambda wrapping
(
defvar
*ps-gensym-counter*
0
)
(
defvar
this-in-lambda-wrapped-form?
nil
)
(
defun
lambda-wrap
(
form
)
(
let
((
this-in-lambda-wrapped-form?
:query
)
(
*ps-gensym-counter*
*ps-gensym-counter*
))
(
ps-compile
form
)
(
if
(
eq
this-in-lambda-wrapped-form?
:yes
)
`
(
chain
(
lambda
()
,
form
)
(
call
this
))
`
((
lambda
()
,
form
)))))
;;;; compiler interface
(
defparameter
*compilation-level*
:toplevel
...
...
@@ -300,37 +292,41 @@ form, FORM, returns the new value for *compilation-level*."
(
define-condition
compile-expression-error
(
error
)
((
form
:initarg
:form
:reader
error-form
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"The Parenscript form ~A cannot be compiled into an expression."
(
error-form
condition
)))))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"The Parenscript form ~A cannot be compiled into an expression."
(
error-form
condition
)))))
(
defun
compile-special-form
(
form
)
(
let*
((
op
(
car
form
))
(
statement-impl
(
gethash
op
*special-statement-operators*
))
(
let*
((
op
(
car
form
))
(
statement-impl
(
gethash
op
*special-statement-operators*
))
(
expression-impl
(
gethash
op
*special-expression-operators*
)))
(
cond
(
(
or
(
not
compile-expression?
)
this-in-lambda-wrapped-form?
)
(
cond
((
not
compile-expression?
)
(
apply
(
or
statement-impl
expression-impl
)
(
cdr
form
)))
(
expression-impl
(
apply
expression-impl
(
cdr
form
)))
((
member
op
*lambda-wrappable-statements*
)
(
compile-expression
(
lambda-wrap
form
)))
(
t
(
error
'compile-expression-error
:form
form
)))))
(
compile-expression
(
with-lambda-scope
form
)))
(
t
(
error
'compile-expression-error
:form
form
)))))
(
defun
ps-compile
(
form
)
(
macrolet
((
try-expanding
(
form
&body
body
)
`
(
multiple-value-bind
(
expansion
expanded?
)
(
ps-macroexpand
,
form
)
(
if
expanded?
(
ps-compile
expansion
)
(
progn
,@
body
)))))
(
macrolet
((
try-expanding
(
form
&body
body
)
`
(
multiple-value-bind
(
expansion
expanded?
)
(
ps-macroexpand
,
form
)
(
if
expanded?
(
ps-compile
expansion
)
,@
body
))))
(
typecase
form
((
or
null
number
string
character
)
form
)
(
vector
(
ps-compile
`
(
quote
,
(
coerce
form
'list
))))
(
symbol
(
try-expanding
form
(
when
(
and
(
eq
form
'this
)
(
eq
this-in-lambda-wrapped-form?
:query
))
(
setq
this-in-lambda-wrapped-form?
:yes
))
form
))
(
try-expanding
form
form
))
(
cons
(
try-expanding
form
(
let
((
*compilation-level*
...
...
src/function-definition.lisp
View file @
e12e1abb
...
...
@@ -167,7 +167,8 @@ of (declare ...) forms, and the remaining body."
(
collapsed-body
(
collapse-function-return-blocks
body
))
(
suppress-values?
(
find
'values
(
flatten
body
)))
;; probably buggy; this should be done after macroexpansion
(
tree-find
'values
collapsed-body
))
(
*dynamic-return-tags*
(
append
(
mapcar
(
lambda
(
x
)
(
cons
x
nil
))
*function-block-names*
)
...
...
@@ -238,7 +239,7 @@ of (declare ...) forms, and the remaining body."
`
(
ps-js:lambda
,
args1
,
body-block
)))
(
defmacro
local-functions
(
special-op
&body
bindings
)
`
(
if
(
or
in-function-scope?
this-in-lambda-wrapped-form?
)
`
(
if
in-function-scope?
(
let*
((
fn-renames
(
collect-function-names
fn-defs
))
,@
bindings
)
`
(
,
(
if
compile-expression?
'ps-js:
|,|
'ps-js:block
)
...
...
src/lib/ps-loop.lisp
View file @
e12e1abb
...
...
@@ -453,5 +453,5 @@
,@
(
awhen
(
accum-var
state
)
(
list
it
))))
(
full
`
(
block
,
(
name
state
)
,@
(
prologue-wrap
(
prologue
state
)
main
))))
(
if
(
accum-var
state
)
(
lambda-
wrap
full
)
(
with-
lambda-
scope
full
)
full
))))
src/special-operators.lisp
View file @
e12e1abb
...
...
@@ -198,7 +198,7 @@
body
))
(
define-statement-operator
block
(
name
&rest
body
)
(
if
(
or
in-function-scope?
this-in-lambda-wrapped-form?
)
(
if
in-function-scope?
(
let*
((
name
(
or
name
'nilBlock
))
(
in-loop-scope?
(
if
name
in-loop-scope?
nil
))
(
*dynamic-return-tags*
(
cons
(
cons
name
nil
)
*dynamic-return-tags*
))
...
...
@@ -206,7 +206,7 @@
(
compiled-body
(
wrap-for-dynamic-return
(
list
name
)
(
compile-statement
`
(
progn
,@
body
)))))
(
if
(
tree-
search
`
(
ps-js:break
,
name
)
compiled-body
)
(
if
(
tree-
find
`
(
ps-js:break
,
name
)
compiled-body
)
`
(
ps-js:label
,
name
,
compiled-body
)
compiled-body
))
(
ps-compile
(
with-lambda-scope
`
(
block
,
name
,@
body
)))))
...
...
@@ -333,7 +333,7 @@ invocations or not.")
,@
(
when
in-case?
`
((
t
(
return-from
,
tag
nil
))))))
(
if
(
if
(
and
(
try-expressionizing-if?
form
)
(
not
(
find
'values
(
flatten
form
))
)
(
not
(
tree-
find
'values
form
))
(
let
((
used-up-names
*used-up-names*
)
(
*lambda-wrappable-statements*
()))
(
handler-case
(
compile-expression
form
)
...
...
@@ -463,9 +463,13 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(
member
x
symbols-in-bindings
))
(
ps-gensym
(
symbol-name
x
))))
(
defun
with-lambda-scope
(
body
)
(
prog1
(
lambda-wrap
body
)
(
setf
*vars-needing-to-be-declared*
())))
(
defun
with-lambda-scope
(
form
)
(
prog1
(
if
(
tree-find
'this
(
let
((
*ps-gensym-counter*
*ps-gensym-counter*
))
(
ps-compile
`
(
lambda
()
,
form
))))
`
(
funcall
(
getprop
(
lambda
()
,
form
)
'call
)
this
)
`
((
lambda
()
,
form
)))
(
setf
*vars-needing-to-be-declared*
())))
(
define-expression-operator
let
(
bindings
&body
body
)
(
with-declaration-effects
(
body
body
)
...
...
@@ -534,9 +538,7 @@ Parenscript now implements implicit return, update your code! Things like (lambd
dynamic-bindings
)))))
renamed-body
))))
(
ps-compile
(
cond
((
or
in-function-scope?
this-in-lambda-wrapped-form?
(
null
bindings
))
(
cond
((
or
in-function-scope?
(
null
bindings
))
let-body
)
;; HACK
((
find-if
...
...
src/utils.lisp
View file @
e12e1abb
...
...
@@ -118,11 +118,11 @@ Use GETPROP, @, or CHAIN instead."
((
atom
x
)
(
cons
x
acc
))
(
t
(
flatten
(
car
x
)
(
flatten
(
cdr
x
)
acc
)))))
(
defun
tree-
search
(
A
tree
)
(
defun
tree-
find
(
A
tree
)
(
or
(
equal
A
tree
)
(
when
(
consp
tree
)
(
loop
for
x
on
tree
thereis
;; fucking dotted lists
(
or
(
tree-
search
A
(
car
x
))
(
loop
for
x
on
tree
thereis
(
or
(
tree-
find
A
(
car
x
))
(
unless
(
listp
(
cdr
x
))
(
equal
A
(
cdr
x
))))))))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment