Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
786 lines (605 sloc) 19.2 KB
\ lisp.fs --- A straighforward dynamically-scoped Lisp interpreter
\ Copyright 2012 (C) David Vazquez
\ This file is part of Eulex.
\ Eulex is free software: you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.
\ Eulex is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with Eulex. If not, see <http://www.gnu.org/licenses/>.
vocabulary lisp
get-current
also eulex
also lisp definitions
\ : DEBUG ;
' postpone alias `` immediate
' compile-only alias c/o
: imm-c/o immediate compile-only ;
3 constant tag-bits
1 tag-bits lshift 1 - constant tag-mask
%000 constant even-fixnum-tag
%001 constant cons-tag
%010 constant symbol-tag
%011 constant subr-tag
%100 constant odd-fixnum-tag
\ %101 constant reserved
\ %110 constant reserved
%111 constant forward-tag
: tag tag-mask and ;
: tagged or ;
: ?tagged swap dup 0= if nip else swap tagged then ;
: untag tag-mask invert and ;
\ Memory management and garbage collection
\ ( Cheney's algorithm )
\ A stack of pinned objects. Use it to protect shadown symbol values
\ and other Lisp objects which could not to be accesible from Lisp
\ temporarly.
4096 constant pinned-size
create pinned pinned-size zallot
variable pinned-count
: >p
pinned-count @ pinned-size = if abort" Too depth recursion." endif
pinned pinned-count @ cells + ! pinned-count 1+! ;
: pdrop pinned-count 1-! ;
: pinargs ( arg1 ... argn n -- arg1 ... argn n )
dup 0 ?do i 1+ pick >p loop ;
: unpinargs ( n -- )
0 ?do pdrop loop ;
65536 constant dynamic-space
: initvar variable latestxt execute ! ;
\ From space
dynamic-space allocate throw initvar fromsp-base
fromsp-base @ dynamic-space + initvar fromsp-limit
\ To space
dynamic-space allocate throw initvar tosp-base
tosp-base @ dynamic-space + initvar tosp-limit
variable &alloc
variable &scan
\ These functions receive a Lisp object and return a reference to the
\ new object in the to space. It allocates the object if it is
\ required, marking it with a forward pointer.
create copy-functions 1 tag-bits lshift cells zallot
: copy-method! ( xt tag -- )
cells copy-functions + ! ;
: copy-method ( obj -- xt )
tag cells copy-functions + @ ;
: swap-cells ( addr1 addr2 -- )
dup @ -rot >r dup @ r> ! ! ;
: swap-spaces
fromsp-base tosp-base swap-cells
fromsp-limit tosp-limit swap-cells
tosp-base @ dup &alloc ! &scan ! ; latestxt execute
: >tosp ( addr n -- addr* )
tuck &alloc @ swap move
&alloc @ swap &alloc +! ;
: forward-reference ( old -- new|0 )
dup tag swap untag @ ( tag cell )
dup tag forward-tag = if untag tagged else 2drop 0 endif ;
: markgc! ( old new -- )
untag forward-tag tagged swap untag ! ;
: valid-obj? ( obj -- )
fromsp-base @ swap untag fromsp-limit @ between ;
: copy ( x -- x* )
dup copy-method over valid-obj? and if
dup forward-reference ?dup if
else
dup dup copy-method execute tuck markgc!
endif
endif ;
defer copy-root-symbols
: copy-pinned
pinned-count @ 0 ?do
pinned i cells +
dup @ copy swap !
loop ;
: gc
[IFDEF] DEBUG CR ." Garbage collecting..." [ENDIF]
swap-spaces
copy-root-symbols copy-pinned
begin
&scan @ &alloc @ u< while
&scan @ dup @ copy swap !
&scan @ cell+ &scan !
repeat ;
: alloc-obj ( n -- obj f )
dup &alloc @ + tosp-limit @ >= if gc endif
dup &alloc @ + tosp-limit @ >= if abort" Out of memory" endif
&alloc @ swap &alloc +! 0 ;
[IFDEF] DEBUG
: .debug
CR
." From space: "
fromsp-base @ dynamic-space dump CR
." ALLOC = " &alloc @ print-hex-number CR
." SCAN = " &scan @ print-hex-number CR
." To space: "
tosp-base @ dynamic-space dump CR ;
[ENDIF]
\ Errors
: void-variable 1 throw ;
: void-function 2 throw ;
: wrong-type-argument 3 throw ;
: wrong-number-of-arguments 4 throw ;
: parse-error 5 throw ;
: quit-condition 6 throw ;
: eof-condition 7 throw ;
\ Defered words
defer eval-lisp-obj
defer read-lisp-obj
\ Symbols
\ We write the lisp package system upon wordlists. The PF of the words
\ contains the symbol value and the symbol function parameters aligned
\ to a double cell size.
wordlist constant lisp-package
: in-lisp-package:
lisp-package 1 set-order ;
: create-in-lisp-package
get-order get-current in-lisp-package: definitions
create set-current set-order ;
: find-cname-in-lisp-package ( c-addr -- nt|0 )
>r get-order in-lisp-package: r>
find-cname >r set-order r> ;
: create-symbol
create-in-lisp-package latest 2align , does> 2aligned symbol-tag tagged ;
: ::unbound
[ here 2aligned symbol-tag tagged ]L ;
: declare-symbol
create-symbol ::unbound , ::unbound , ;
create-symbol t latestxt execute , ::unbound ,
create-symbol nil latestxt execute , ::unbound ,
declare-symbol quote
declare-symbol progn
declare-symbol lambda
declare-symbol macro
declare-symbol if
declare-symbol backquote
declare-symbol comma
: find-symbol ( c-addr -- symbol|0 )
find-cname-in-lisp-package dup if nt>xt execute endif ;
: intern-symbol ( c-addr -- symbol )
dup find-symbol ?dup if nip else
count nextname create-symbol ::unbound , ::unbound ,
latestxt execute
then ;
: '' parse-cname find-symbol ;
: [''] '' `` literal ; immediate
\ #DOSYMBOLS...#ENDSYMBOLS
\
\ Iterate across the symbols in the package. The body is executed with
\ a symbol in the TOS each time. The body must drop the symbol from
\ the stack.
: #dosymbols
`` lisp-package
`` DOWORDS
`` dup `` >r
`` nt>xt `` execute
; imm-c/o
: #endsymbols
`` r>
`` ENDWORDS
; imm-c/o
'' t constant t
'' nil constant nil
: >bool if t else nil then ;
: bool> nil = if 0 else -1 then ;
: #symbolp tag symbol-tag = >bool ;
\ Check if X is a symbol object. If not, it signals an error.
: check-symbol ( x -- x )
dup #symbolp nil = if wrong-type-argument then ;
: symbol-name ( symbol -- caddr )
check-symbol untag @ ;
: safe-symbol-value check-symbol untag cell+ @ ;
: safe-symbol-function check-symbol untag 2 cells + @ ;
: #symbol-value ( symbol -- value )
safe-symbol-value dup ::unbound = if void-variable endif ;
: #symbol-function ( symbol -- value )
safe-symbol-function dup ::unbound = if void-function endif ;
\ Don't forget that #SET and #FSET words return the newly assigned
\ value, so if you are not going to use that value, drop it.
: #set ( symb value -- value )
tuck swap check-symbol untag cell+ ! ;
: #fset ( symbol definition -- definition )
tuck swap check-symbol untag 2 cells + ! ;
:noname
#dosymbols
dup
dup safe-symbol-value copy #set drop
dup safe-symbol-function copy #fset drop
#endsymbols
; is copy-root-symbols
\ Lisp basic conditional. It runs the true-branch if the top of the
\ stack is non-nil. It is compatible with `else' and `then' words.
: nil/= nil = not ;
: #if `` nil/= `` if ; imm-c/o
: #while `` nil/= `` while ; imm-c/o
: #until `` nil/= `` until ; imm-c/o
\ CONSes
variable allocated-conses
:noname
untag 2 cells >tosp cons-tag tagged
; cons-tag copy-method!
: #cons ( x y -- cons )
2 cells alloc-obj throw
tuck cell+ ! tuck ! cons-tag tagged
allocated-conses 1+! ;
: #consp tag cons-tag = >bool ;
: check-cons
dup #consp nil = if wrong-type-argument endif ;
: #car dup #if check-cons untag @ endif ;
: #cdr dup #if check-cons untag cell + @ endif ;
\ Return the cdr of a cons. If the result is NIL, signals an error.
: assert-cdr
#cdr dup nil = if parse-error endif ;
: #dolist
`` begin
`` dup `` #while
`` dup `` >r
`` #car
; imm-c/o
: #repeat
`` r>
`` #cdr
`` repeat
`` drop
; imm-c/o
\ SUBRS (primitive functions)
: special-subr? untag @ 0= ;
: subr>xt cell+ ;
-1 constant infinite
: unlist ( list -- arg1 arg2 .. argn n )
0 swap #dolist swap 1+ #repeat ;
: check-number-of-arguments ( n min max )
>r over r> between if else wrong-number-of-arguments endif ;
' unlist alias non-eval-args
: eval-and-unlist ( list -- )
0 swap #dolist eval-lisp-obj swap 1+ #repeat ;
: eval-funcall-args
eval-and-unlist ;
\ Create a subr object (a primitive function to the Lisp system),
\ which accepts between MIN and MAX arguments, checks that the number
\ of arguments is correct and then call to the execution token XT.
: create-subr ( min max evaluated xt -- subr )
2align here >r
swap ,
-rot swap 2dup `` literal `` literal `` check-number-of-arguments
( min max ) = if `` drop endif
`` literal `` execute
return
r> subr-tag tagged ;
: register-subr ( min max evaluated xt parse:name -- )
create-subr parse-cname intern-symbol swap #fset drop ;
2 2 true ' #cons register-subr cons
1 1 true ' #consp register-subr consp
1 1 true ' #car register-subr car
1 1 true ' #cdr register-subr cdr
1 1 true ' #symbolp register-subr symbolp
1 1 true ' #symbol-value register-subr symbol-value
1 1 true ' #symbol-function register-subr symbol-function
2 2 true ' #set register-subr set
2 2 true ' #fset register-subr fset
: exactly dup ;
: or-more infinite ;
: noargs 0 exactly ;
: unary 1 exactly ;
: binary 2 exactly ;
: function: true latestxt register-subr ;
: #subrp tag subr-tag = >bool ;
unary function: subrp
: execute-subr ( arg1 arg2 .. argn n subr -- ... )
untag subr>xt execute ;
: #eq = >bool ;
binary function: eq
: #functionp ( x -- bool )
dup #symbolp #if safe-symbol-function endif
dup #subrp #if
special-subr? not >bool
else
dup #consp #if
#car [''] lambda #eq
else
nil
endif
endif ;
unary function: functionp
\ Integers
: >fixnum 2* 2* ;
: fixnum> 2/ 2/ ;
: #fixnump 3 and 0= >bool ; unary function: fixnump
' #fixnump alias #integerp unary function: integerp
: check-integer ( x -- x )
dup #integerp nil = if wrong-type-argument endif ;
: 2-check-integers
check-integer swap check-integer swap ;
: #= 2-check-integers = >bool ; binary function: =
: #< 2-check-integers < >bool ; binary function: <
: #> 2-check-integers > >bool ; binary function: >
: #<= 2-check-integers <= >bool ; binary function: <=
: #>= 2-check-integers >= >bool ; binary function: >=
: #/= 2-check-integers = not >bool ; binary function: >=
: #+ 2-check-integers + ; binary function: +
: #- 2-check-integers - ; binary function: -
: #* 2-check-integers fixnum> * ; binary function: *
: #/ 2-check-integers / >fixnum ; binary function: /
: #list ( x1 x2 ... xn n -- list )
nil swap 0 ?do #cons loop
; 0 or-more function: list
: #length ( list -- n )
0 swap #dolist drop 1+ #repeat >fixnum ;
unary function: length
\ Misc
: #not #if nil else t endif ; unary function: not
' #not alias #null unary function: null
: #get-internal-run-time
get-internal-run-time >fixnum
; noargs function: get-internal-run-time
: #terpri cr nil ; noargs function: terpri
: #quit quit-condition ;
noargs function: quit
\ Reader
: digit-char? ( ch -- bool )
[char] 0 swap [char] 9 between ;
: digit-value ( ch -- d )
[char] 0 - ;
: whitespace-char? ( ch -- bool )
case
32 of true endof
10 of true endof
08 of true endof
false swap
endcase ;
: close-parent? [char] ) = ;
: discard-char
parse-char drop ;
: skip-whitespaces
begin peek-char whitespace-char? while discard-char repeat ;
: peek-conforming-char
skip-whitespaces peek-char ;
: assert-char
parse-char = invert if parse-error endif ;
: read-' discard-char [''] quote read-lisp-obj 2 #list ;
: read-` discard-char [''] backquote read-lisp-obj 2 #list ;
: read-, discard-char [''] comma read-lisp-obj 2 #list ;
: read-(... recursive
peek-conforming-char case
[char] ) of discard-char nil endof
[char] . of
discard-char read-lisp-obj
skip-whitespaces [char] ) assert-char
endof
read-lisp-obj read-(... #cons swap
endcase ;
: read-(
discard-char peek-conforming-char [char] ) = if discard-char nil else
read-lisp-obj read-(... #cons
endif ;
: discard-line
begin parse-char 10 = until ;
: read-;
begin peek-conforming-char [char] ; = while discard-line repeat
read-lisp-obj ;
32 constant token-buffer-size
create token-buffer token-buffer-size allot
: token-terminal-char? ( ch -- bool )
dup whitespace-char? swap close-parent? or ;
: token-size
token-buffer c@ ;
: full-token-buffer? ( -- bool )
token-size token-buffer-size >= ;
: push-token-char ( ch -- )
full-token-buffer? if drop else
token-buffer 1+ token-size + c!
token-size 1+ token-buffer c!
endif ;
: read-token
0 token-buffer c!
begin parse-char push-token-char
peek-char token-terminal-char? until
token-buffer dup c@ 0= if parse-error endif ;
: try-unumber ( addr u -- d f )
dup 0= if 2drop 0 0 exit then
0 -rot
0 ?do ( d addr )
dup I + c@ digit-char? if
swap 10 * over I + c@ digit-value + swap
else
unloop drop false exit
endif
loop
drop true ;
: trim0 ( addr u -- addr+1 u-1 )
dup if 1- swap 1+ swap endif ;
: try-number ( addr u -- d f )
over c@ case
[char] - of trim0 try-unumber swap negate swap endof
[char] + of trim0 try-unumber endof
drop try-unumber 0
endcase ;
: >sym/num ( c-addr -- x )
dup count try-number if
nip >fixnum
else
drop intern-symbol
endif ;
: #read ( -- x )
peek-conforming-char case
[char] ( of read-( endof
[char] ' of read-' endof
[char] ` of read-` endof
[char] , of read-, endof
[char] ; of read-; endof
[char] . of parse-error endof
0 of eof-condition endof
drop read-token >sym/num 0
endcase ;
' #read is read-lisp-obj
noargs function: read
\ Printer
defer print-lisp-obj
: print-integer fixnum> print-number ;
: print-symbol symbol-name count type ;
: print-list
[char] ( emit
dup #car print-lisp-obj #cdr
begin dup #consp #while
space dup #car print-lisp-obj #cdr
repeat
\ Trailing element
dup #if
." . " print-lisp-obj ." )"
else
drop [char] ) emit
endif ;
: #print ( x -- x )
dup
dup #symbolp #if print-symbol exit endif
dup #integerp #if print-integer exit endif
dup #consp #if print-list exit endif
\ Unreadable objects
dup #subrp #if drop ." #<subr object>" exit endif
drop wrong-type-argument ;
unary function: print
:noname #print drop ; is print-lisp-obj
\ Interpreter
: eval-progn-list ( list -- x )
nil swap #dolist nip eval-lisp-obj #repeat ;
\ Funcalls
: lambda-args assert-cdr #car ;
: lambda-nargs lambda-args #length fixnum> ;
: lambda-body assert-cdr #cdr ;
\ Swap the values of the cell pointed by ADDR and the value of SYMBOL.
: cell<->symbol ( addr symbol -- )
dup safe-symbol-value -rot over @ #set drop ! ;
\ Iterate on the arguments of the lambda, swapping the argument in the
\ stack by the value slot of the symbol.
: stack<->symbols ( a1 a2 ... an n symbs -- v1 v2 ... vn n symbs )
2dup 2>r swap 1+ cells sp + swap
#dolist 2dup cell<->symbol drop cell - #repeat
drop 2r> ;
: eval-with-bindings ( arg1 arg2 ... argn n symbols body -- x )
>r stack<->symbols >r pinargs r>
r> eval-progn-list
>r stack<->symbols drop dup unpinargs ndrop r> ;
: funcall-lambda ( arg1 arg2 ... argn n lambda -- x )
2dup lambda-nargs = not if wrong-number-of-arguments then
dup lambda-args swap lambda-body eval-with-bindings ;
: funcall ( arg1 ... argn n function -- x)
>r pinargs r> over >r
dup #symbolp #if #symbol-function endif
dup #subrp #if execute-subr else funcall-lambda endif
r> unpinargs ;
: #funcall ( function arg1 arg2 ... argn n+1 --- x )
1- dup >r roll r> swap funcall ;
1 or-more function: funcall
\ is X a macro?
: macro? ( x -- bool)
dup #symbolp #if safe-symbol-function endif
dup #consp #not #if drop false exit endif
#car [''] macro = ;
: macroexpand-1*
dup >r #cdr non-eval-args r>
#car #symbol-function #cdr funcall ;
: #macroexpand-1 ( list -- x )
dup #consp #not #if exit endif
dup #car macro? if
macroexpand-1*
endif ;
unary function: macroexpand-1
\ Non-atoms
: special: ( n parse:name -- )
false latestxt register-subr ;
: #quote ( form -- form )
; unary special: quote
: ##if ( cond true false n -- form )
2 = if nil endif
rot eval-lisp-obj #if drop else nip endif eval-lisp-obj
; 2 3 special: if
: #progn ( expr1 expr2 expr3 ... exprn n -- )
#list eval-progn-list
; 0 or-more special: progn
: #%let ( symbols values expr1 ... exprn n+2 -- )
2- #list swap -rot 2>r eval-and-unlist 2r> eval-with-bindings
; 2 or-more special: %let
: eval-list-form
dup #car macro? if
#macroexpand-1 eval-lisp-obj
else
dup #car
dup #symbolp #if #symbol-function endif
dup special-subr? if
>r #cdr non-eval-args r> execute-subr
else
>r #cdr eval-funcall-args r> funcall
endif
endif ;
variable eval-depth
-1 eval-depth !
: eval-indent eval-depth @ 3 * spaces ;
: eval-form ( x -- y )
dup #integerp #if exit endif
dup #symbolp #if #symbol-value exit endif
dup #consp #if eval-list-form exit endif
wrong-type-argument ;
: #eval ( x -- y )
\ eval-depth 1+!
\ ." ;; " eval-indent ." Evaluating " dup #print CR
eval-form
\ ." ;; " eval-indent ." => " dup #print CR
\ eval-depth 1-!
; ' #eval is eval-lisp-obj
unary function: eval
\ REPL
defer repl-function
: repl-iteration #read #eval ;
: user-repl-iteration ." * " query #read #eval >r attr red r> print-lisp-obj attr! CR ;
: process-toplevels
begin repl-function again ;
\ Process Lisp forms until an error is signaled.
: repl-loop ( repl-iteration-word -- )
['] process-toplevels catch case
0 of endof
1 of ." ERROR: void variable" CR endof
2 of ." ERROR: void function" CR endof
3 of ." ERROR: wrong type of argument" CR endof
4 of ." ERROR: wrong number of arguments" CR endof
5 of ." ERROR: parsing error" CR endof
\ 6 of endof EXIT
\ 7 of endof EOF
throw
endcase ;
\ Process forms until EXIT or EOF conditions.
: toplevel
['] user-repl-iteration is repl-function
begin
['] repl-loop catch case
6 of exit endof
7 of exit endof
endcase
again ;
@lisp/core.lisp buffer>string
:noname
['] repl-iteration is repl-function
['] repl-loop catch case
6 of endof
7 of endof
endcase
; execute-parsing
: run-lisp
attr page 0 0 at-xy white ." RUNNING EULEX LISP." attr! CR CR
refill-silent? on
get-order get-current
in-lisp-package: definitions
end-newline-p on
toplevel
end-newline-p off
set-current set-order
refill-silent? off
CR ." GOOD BYE!" CR CR ;
\ Provide RUN-LISP in the system vocabulary
set-current
' run-lisp alias run-lisp
previous previous
\ lisp.fs ends here
Something went wrong with that request. Please try again.