Go to start of banner

# Lisp Interpreter in ABAP

Author: JNN
Submitted: 28.07.2015

# Lambda the Ultimate

Lispers go gaga over lambda, the fundamental command in a Lisp system (Conrad Barski's Land of LISP chapter 6.5). When Martin Ceronio published a LISP interpreter in ABAP I was curious to understand code evaluation. After converting the tests to an automated regression suite in ABAP Unit , I could safely explore the code. I learned more about Scheme (now we have a symbol for false #f that is not nil) and ended up with the following additions:

• more validation to avoid dumps from incorrect syntax
• a workbench that makes it easier to play with the interpreter
• Comments using the ; delimiter
• native operations: set!, let (no named let yet), let*, letrec, cond, and, or, reverse, append!
• predicates: number? string? symbol? hash? procedure? list? zero? positive? negative? odd? even? eq?
• trigonometric functions: sin cos tan sinh cosh tanh asin acos atan asinh acosh atanh
• math: quotient remainder modulo abs floor ceiling truncate round expt exp sqrt
• display / newline - are not working properly yet

The original functions:

FunctionArgumentsFirst-class*Description
+, -, *, /1-nYesBasic arithmetic functions
appendnYesCreates a new list by append the last element to the concatenation of all previous lists
list1-nYesMakes a list out of all given arguments
length1YesLength of the given list
car1YesReturns the first item in a list, or nil given an empty list (or nil)
cdr1YesReturns the tail of a list, which will be a list, or nil, given an empty list (or nil)
cons2YesConstructs a new list, making the first element the head and the second input (usually a list) the tail (like prepending, almost)
nil?, null?1YesTests if the input is nil or not (null? is an alias added for compatibility with Scheme-based tests)
>, >=, <, <=1-nYesComparison operators
equal?2YesTests if the given arguments are equal (either by symbol or number) or, in the case of a list, whether it is the same list.
quote1NoReturns the argument verbatim, without evaluating it
if2-3NoEvaluates the first argument. If true, the second argument is evaluated. If not, a third argument is evaluated, otherwise nil (false) is returned
define2No

(define <variable> <expression>) binds one identifier to an expression. (define (<variable>> <formal>) <body>) defines a function

lambda2NoDefines an anonymous function; first input is a list of formal parameters; second is the body to be evaluated
begin0-nNoEvaluates all arguments as expressions in turn; a nice way to string a lot of expressions together to be executed
and0-nNo
or0-nNo
set!1No

There are many ways to improve, a challenge would be a simple macro system that can do define-syntax.

### How to implement Workbench

Double click on the source to select, then copy and paste to generate the report ZZ_LISP_IDE from the sources

• Report ZZ_LISP_IDE - Main report
• Include YY_LIB_LISP - Custom version of ABAP LISP
• Include YY_LISP_AUNIT - ABAP Unit tests

Create an empty screen 0100, then define the OK code

• G_OK_CODE

and the flow logic:

Error rendering macro 'code': Invalid value specified for parameter 'com.atlassian.confluence.ext.code.render.InvalidValueException'
```PROCESS BEFORE OUTPUT.
MODULE status_0100.

PROCESS AFTER INPUT.
MODULE cancel_0100 AT EXIT-COMMAND.
MODULE user_command_0100.```

Create a GUI Status STATUS_100 with

Application Toolbar

• EXECUTE - Execute / Evaluate - F8 - ICON_EXECUTE_OBJECT
• CLEAR - Delete / Delete Source - Shift-F2 - ICON_REFRESH

Function Keys

• BACK (F3) Exit-Command
• EXIT (Shift-F3) Exit-Command
• CANCEL (F12) Exit-Command

Create a GUI Title
TITLE_100 - ABAP LISP Workbench

Activate and try it out!

Error rendering macro 'code': Invalid value specified for parameter 'com.atlassian.confluence.ext.code.render.InvalidValueException'
```REPORT zz_lisp_ide.

INCLUDE yy_lib_lisp.
INCLUDE yy_lisp_aunit.

*----------------------------------------------------------------------*
*       CLASS lcl_container DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_container DEFINITION.
PUBLIC SECTION.
METHODS constructor.
METHODS free_controls.
DATA mo_input TYPE REF TO cl_gui_container READ-ONLY.
DATA mo_output TYPE REF TO cl_gui_container READ-ONLY.
DATA mo_log TYPE REF TO cl_gui_container READ-ONLY.
DATA mo_alv TYPE REF TO cl_gui_container READ-ONLY.
PRIVATE SECTION.
DATA mo_splitter_h TYPE REF TO cl_gui_splitter_container.
DATA mo_splitter_v TYPE REF TO cl_gui_splitter_container.
DATA mo_splitter_v_h TYPE REF TO cl_gui_splitter_container.
DATA mo_left TYPE REF TO cl_gui_container.
DATA mo_right TYPE REF TO cl_gui_container.
ENDCLASS.                    "lcl_container DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_editor DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_editor DEFINITION INHERITING FROM cl_gui_textedit.
PUBLIC SECTION.
CONSTANTS c_comments_string TYPE char01 VALUE ';'.

METHODS constructor IMPORTING io_container TYPE REF TO cl_gui_container
iv_toolbar TYPE flag DEFAULT abap_false.
METHODS append_source IMPORTING iv_text TYPE string.
METHODS append_to IMPORTING io_editor TYPE REF TO lcl_editor.
METHODS to_string RETURNING value(rv_text) TYPE string.
METHODS update_status IMPORTING iv_string TYPE string.
METHODS append_string IMPORTING iv_text TYPE string.
PRIVATE SECTION.
DATA mv_counter TYPE i.

METHODS format_input IMPORTING code TYPE string
RETURNING value(rv_text) TYPE string.
ENDCLASS.                    "lcl_editor DEFINITION

*----------------------------------------------------------------------*
*       INTERFACE lif_unit_test IMPLEMENTATION
*----------------------------------------------------------------------*
INTERFACE lif_unit_test.
ENDINTERFACE.                    "lif_unit_test IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_ide DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_ide DEFINITION CREATE PRIVATE.
PUBLIC SECTION.
CLASS-METHODS: main,
free,
pbo,
pai IMPORTING iv_code        TYPE syucomm
RETURNING value(rv_flag) TYPE flag.
METHODS first_output.

INTERFACES lif_port.
PRIVATE SECTION.
CLASS-DATA go_ide TYPE REF TO lcl_ide.
DATA mv_first TYPE flag VALUE abap_true.
DATA mo_cont TYPE REF TO lcl_container.
DATA mo_int TYPE REF TO lcl_lisp_profiler. "The Lisp interpreter

DATA mo_source TYPE REF TO lcl_editor.
DATA mo_output TYPE REF TO lcl_editor.
DATA mo_log TYPE REF TO lcl_editor.
DATA mo_alv TYPE REF TO cl_salv_table.

METHODS:
constructor,
evaluate,
refresh,
free_controls,
user_command IMPORTING iv_code        TYPE syucomm
RETURNING value(rv_flag) TYPE flag.
METHODS welcome RETURNING value(text) TYPE string.

ENDCLASS.                    "lcl_ide DEFINITION

DATA g_ok_code TYPE syucomm.

START-OF-SELECTION.
lcl_ide=>main( ).

*----------------------------------------------------------------------*
*       CLASS lcl_ide IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_ide IMPLEMENTATION.

METHOD constructor.
CREATE OBJECT:
mo_cont,

mo_source
EXPORTING
io_container = mo_cont->mo_input
iv_toolbar = abap_true,
mo_output
EXPORTING
io_container = mo_cont->mo_output
iv_toolbar = abap_true,
mo_log
EXPORTING
io_container = mo_cont->mo_log.
refresh( ).
ENDMETHOD.                    "constructor

METHOD main.
CREATE OBJECT go_ide.
CALL SCREEN 100.
ENDMETHOD.                    "main

METHOD refresh.
mo_source->delete_text( ).
mo_output->delete_text( ).
mo_log->delete_text( ).
CREATE OBJECT mo_int   " LISP Interpreter
EXPORTING ii_port = me.
ENDMETHOD.                    "refresh

METHOD lif_port~write.
FIELD-SYMBOLS <lt_table> TYPE STANDARD TABLE.
DATA lx_error TYPE REF TO cx_root.
DATA lo_functions TYPE REF TO cl_salv_functions.

CASE element->type.
WHEN lcl_lisp=>type_abap_table.
TRY.
ASSIGN element->data->* TO <lt_table>.
cl_salv_table=>factory(
EXPORTING r_container    = mo_cont->mo_alv
IMPORTING r_salv_table   = mo_alv
CHANGING  t_table        = <lt_table> ).

lo_functions = mo_alv->get_functions( ).
lo_functions->set_all( abap_true ).
mo_alv->display( ).

CATCH cx_root INTO lx_error.
lcl_lisp=>throw( lx_error->get_text( ) ).
ENDTRY.

WHEN OTHERS.
ENDCASE.
ENDMETHOD.                    "lif_console~write

METHOD welcome.
text = |==> Welcome to ABAP List Processing!\n|.
ENDMETHOD.                    "welcome

METHOD first_output.
CHECK mv_first EQ abap_true.
CLEAR mv_first.
cl_gui_textedit=>set_focus( mo_source ).
mo_log->append_string( |{ welcome( ) }\n| ).
ENDMETHOD.                    "first_output

METHOD evaluate.
DATA code TYPE string.
DATA response TYPE string.
DATA lx_root TYPE REF TO cx_root.

TRY.
code = mo_source->to_string( ).
response = mo_int->eval_repl( code ).

mo_output->append_source( code ).

mo_source->delete_text( ).
mo_source->update_status( |[ { mo_int->runtime } µs ] { response }| ).

CATCH cx_root INTO lx_root.
response = lx_root->get_text( ).
mo_source->update_status( |{ response }| ).
ENDTRY.
mo_log->append_string( |{ code }\n=> { response }\n| ).
ENDMETHOD.                    "evaluate

METHOD free.
go_ide->free_controls( ).
ENDMETHOD.                    "free

METHOD free_controls.
FREE mo_alv.
mo_log->free( ).
mo_output->free( ).
mo_source->free( ).
mo_cont->free_controls( ).
ENDMETHOD.                    "free_controls

METHOD pbo.
SET PF-STATUS 'STATUS_100'.
SET TITLEBAR  'TITLE_100'.
go_ide->first_output( ).
ENDMETHOD.                    "pbo

METHOD pai.
rv_flag = go_ide->user_command( iv_code ).
ENDMETHOD.                    "pai

METHOD user_command.
rv_flag = abap_false.

CASE iv_code.
WHEN 'EXECUTE'.
evaluate( ).
WHEN 'CLEAR'.
refresh( ).
WHEN OTHERS.
RETURN.
ENDCASE.

rv_flag = abap_true.
ENDMETHOD.                    "user_command

ENDCLASS.                    "lcl_ide IMPLEMENTATION

*----------------------------------------------------------------------*
*  MODULE status_0100 OUTPUT
*----------------------------------------------------------------------*
MODULE status_0100 OUTPUT.
lcl_ide=>pbo( ).
ENDMODULE.                    "status_0100 OUTPUT

*----------------------------------------------------------------------*
*  MODULE cancel_0100 INPUT
*----------------------------------------------------------------------*
MODULE cancel_0100 INPUT.
lcl_ide=>free( ).
LEAVE PROGRAM.
ENDMODULE.                    "cancel_0100 INPUT

*----------------------------------------------------------------------*
*  MODULE user_command_0100
*----------------------------------------------------------------------*
MODULE user_command_0100.
CHECK lcl_ide=>pai( g_ok_code ) EQ abap_true.
CLEAR g_ok_code.
ENDMODULE.                    "user_command_0100

*----------------------------------------------------------------------*
*       CLASS lcl_container IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_container IMPLEMENTATION.

METHOD constructor.
*   Splitter Container
CREATE OBJECT mo_splitter_h
EXPORTING
parent     = cl_gui_container=>screen0
rows       = 1
columns    = 2.
mo_splitter_h->set_border( border = cl_gui_cfw=>false ).

mo_splitter_h->set_column_mode( mode = mo_splitter_h->mode_absolute ).
mo_splitter_h->set_column_width( id = 1
width = 750 ).
mo_left = mo_splitter_h->get_container( row = 1
column = 1 ).
mo_right = mo_splitter_h->get_container( row = 1
column = 2 ).
CREATE OBJECT mo_splitter_v_h
EXPORTING
parent  = mo_right
rows    = 2
columns = 1.
mo_splitter_v_h->set_border( border = cl_gui_cfw=>false ).
mo_splitter_v_h->set_row_mode( mode = mo_splitter_v_h->mode_relative ).

mo_output  = mo_splitter_v_h->get_container( row = 1 column = 1 ).
mo_alv = mo_splitter_v_h->get_container( row = 2 column = 1 ).

CREATE OBJECT mo_splitter_v
EXPORTING
parent  = mo_left
rows    = 2
columns = 1.
mo_splitter_v->set_border( border = cl_gui_cfw=>false ).
mo_splitter_v->set_row_mode( mode = mo_splitter_v->mode_relative ).

mo_input  = mo_splitter_v->get_container( row = 1 column = 1 ).
mo_log = mo_splitter_v->get_container( row = 2 column = 1 ).
ENDMETHOD.                    "constructor

METHOD free_controls.
FREE: mo_input,
mo_output,
mo_log,
mo_alv.
FREE mo_left.
FREE mo_splitter_h.
FREE mo_splitter_v.
FREE mo_splitter_v_h.
ENDMETHOD.                    "free_controls

ENDCLASS.                    "lcl_container IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_editor IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_editor IMPLEMENTATION.

METHOD constructor.
DATA mode TYPE i.
io_container->set_visible( abap_true ).
super->constructor( io_container ).
IF iv_toolbar EQ abap_true.
mode = 1.
ELSE.
mode = 0.
ENDIF.
set_toolbar_mode( mode ).
cl_gui_cfw=>flush( ).

mode = 0.
ELSE.
mode = 1.
ENDIF.
set_statusbar_mode( mode ).
*   Work around to avoid NO DATA dump on first read
delete_text( ).
ENDMETHOD.                    "constructor

METHOD append_string.
set_textstream( |{ to_string( ) }{ iv_text }| ).
ENDMETHOD.                    "append_string

METHOD format_input.
rv_text = |\${ mv_counter }> { code }\n|.
ENDMETHOD.                    "format_input

METHOD append_source.
append_string( format_input( iv_text ) ).
ENDMETHOD.                    "append_string

METHOD append_to.
io_editor->append_string( to_string( ) ).
ENDMETHOD.                    "append_to

METHOD to_string.
get_textstream( IMPORTING text = rv_text ).
cl_gui_cfw=>flush( ).
ENDMETHOD.                    "to_string

METHOD update_status.
DATA lv_status_text TYPE char72.

lv_status_text = iv_string.
set_status_text( lv_status_text ).
ENDMETHOD.                    "update_status

ENDCLASS.                    "lcl_editor IMPLEMENTATION
```
Error rendering macro 'code': Invalid value specified for parameter 'com.atlassian.confluence.ext.code.render.InvalidValueException'
```
*&---------------------------------------------------------------------*
*&  Include           YY_LIB_LISP
*& https://github.com/mydoghasworms/abap-lisp
*& Lisp interpreter written in ABAP
*& Copy and paste this code into a type I (include) program
*&---------------------------------------------------------------------*
*& Martin Ceronio, martin.ceronio@infosize.co.za
*& June 2015
*& Updated by Jacques Nomssi Nzali, www.informatik-dv.com Sept. 2015
*&---------------------------------------------------------------------*
*
*  Copyright (c) 2015 Martin Ceronio
*
*  Permission is hereby granted, free of charge, to any person obtaining a copy
*  of this software and associated documentation files (the "Software"), to deal
*  in the Software without restriction, including without limitation the rights
*  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
*  copies of the Software, and to permit persons to whom the Software is
*  furnished to do so, subject to the following conditions:
*
*  The above copyright notice and this permission notice shall be included in
*  all copies or substantial portions of the Software.
*
*  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
*  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
*  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
*  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
*  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
*  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
*  THE SOFTWARE.

* Macro to simplify the definition of a native procedure
DEFINE _proc_meth.
methods &1
importing list type ref to lcl_lisp
returning value(result) type ref to lcl_lisp
raising lcx_lisp_eval_err.
END-OF-DEFINITION.

DEFINE validate_number.
if &1->type ne lcl_lisp=>type_number.
throw( |{ &1->to_string( ) } is not a number | && &2 ).
endif.
END-OF-DEFINITION.

DEFINE validate_integer.
if &1->type ne lcl_lisp=>type_number or frac( &1->number ) ne 0.
throw( |{ &1->to_string( ) } is not an integer | && &2 ).
endif.
END-OF-DEFINITION.

*  Macro that implements the logic for the comparison native
*  procedures, where only the comparison operator differs
DEFINE _comparison.
data cell type ref to lcl_lisp.
data carry type decfloat34.

result = false.
validate: list, list->car.
validate_number list->car &2.
cell = list->cdr.
carry = list->car->number.
while cell ne nil.
validate cell->car.
validate_number list->car &2.
if carry &1 cell->car->number.
return.
endif.
carry = cell->car->number.
cell = cell->cdr.
endwhile.
result = true.
END-OF-DEFINITION.

DEFINE _sign.
data carry type decfloat34.

result = false.
validate: list, list->car.
validate_number list->car &2.
carry = list->car->number.
if sign( carry ) NE &1.
return.
endif.
result = true.
END-OF-DEFINITION.

DEFINE _is_type.
result = false.
check list is bound AND list->car is bound.
if list->car->type eq lcl_lisp=>type_&1.
result = true.
endif.
END-OF-DEFINITION.

DEFINE _is_last_param.
if &1->cdr ne nil.
throw( |{ &1->to_string( ) } Parameter mismatch| ).
endif.
END-OF-DEFINITION.

DEFINE _catch_arithmetic_error.
data lx_error type ref to cx_root.
catch cx_sy_arithmetic_error into lx_error.
throw( lx_error->get_text( ) ).
END-OF-DEFINITION.

* Macro that implements the logic for call of ABAP math statements
DEFINE _math.
result = nil.
validate: list, list->car.
validate_number list->car &2.
_is_last_param list.
try.
result = lcl_lisp=>new_number( &1( list->car->number ) ).
_catch_arithmetic_error.
endtry.
END-OF-DEFINITION.

DEFINE _trigonometric.
data carry type f.

result = nil.
validate: list, list->car.
validate_number list->car &2.
_is_last_param list.
try.
carry = list->car->number.
result = lcl_lisp=>new_number( &1( carry ) ).
_catch_arithmetic_error.
endtry.
END-OF-DEFINITION.

DEFINE validate.
if &1 is not bound.
lcl_lisp=>throw( |Incorrect input| ).
endif.
END-OF-DEFINITION.

*--------------------------------------------------------------------*
* EXCEPTIONS
*--------------------------------------------------------------------*

*----------------------------------------------------------------------*
*  CLASS lcx_lisp_exception DEFINITION
*----------------------------------------------------------------------*
*  General Lisp exception
*----------------------------------------------------------------------*
CLASS lcx_lisp_exception DEFINITION INHERITING FROM cx_dynamic_check.
PUBLIC SECTION.
METHODS constructor IMPORTING message TYPE string OPTIONAL.
METHODS get_text REDEFINITION.
PROTECTED SECTION.
DATA mv_area TYPE string.
DATA message TYPE string.
ENDCLASS.                    "lcx_lisp_exception DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcx_lisp_exception IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcx_lisp_exception IMPLEMENTATION.
METHOD constructor.
super->constructor( ).
me->message = message.
ENDMETHOD.                    "constructor

METHOD get_text.
result = message.
IF result IS INITIAL.
result = |Error in processing|.
ENDIF.
IF mv_area IS NOT INITIAL.
result = |{ mv_area }: { result }|.
ENDIF.
ENDMETHOD.                    "get_text

ENDCLASS.                    "lcx_lisp_exception IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcx_lisp_parse_err DEFINITION
*----------------------------------------------------------------------*
* Parse exception
*----------------------------------------------------------------------*
CLASS lcx_lisp_parse_err DEFINITION INHERITING FROM lcx_lisp_exception.
PUBLIC SECTION.
METHODS constructor IMPORTING message TYPE string OPTIONAL.
ENDCLASS.                    "lcx_lisp_parse_err DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcx_lisp_parse_err IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS lcx_lisp_parse_err IMPLEMENTATION.

METHOD constructor.
super->constructor( message ).
mv_area = |Parse|.
ENDMETHOD.                    "constructor

ENDCLASS.                    "lcx_lisp_parse_err IMPLEMENTATION
*----------------------------------------------------------------------*
*       CLASS lcx_lisp_eval_err DEFINITION
*----------------------------------------------------------------------*
* Evaluation exception
*----------------------------------------------------------------------*
CLASS lcx_lisp_eval_err DEFINITION INHERITING FROM lcx_lisp_exception.
PUBLIC SECTION.
METHODS constructor IMPORTING message TYPE string OPTIONAL.
ENDCLASS.                    "lcx_lisp_eval_err DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcx_lisp_eval_err IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcx_lisp_eval_err IMPLEMENTATION.

METHOD constructor.
super->constructor( message ).
mv_area = |Eval|.
ENDMETHOD.                    "constructor

ENDCLASS.                    "lcx_lisp_eval_err IMPLEMENTATION

CLASS lcl_lisp_environment DEFINITION DEFERRED.

* Single element that will capture cons cells, atoms etc.
*----------------------------------------------------------------------*
*       CLASS lcl_lisp DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_lisp DEFINITION.
PUBLIC SECTION.
TYPES tv_type TYPE char1.

DATA type TYPE char1.
DATA value TYPE string.
DATA number TYPE decfloat34.
DATA data TYPE REF TO data.            " for ABAP integration

*      Type definitions for the various elements
CONSTANTS:
type_symbol   TYPE tv_type VALUE 'S',
type_number   TYPE tv_type VALUE 'N',
type_string   TYPE tv_type VALUE '"',
type_conscell TYPE tv_type VALUE 'C',
type_lambda   TYPE tv_type VALUE 'λ',
type_native   TYPE tv_type VALUE 'P',
type_hash     TYPE tv_type VALUE 'H'.
*      Types for ABAP integration:
CONSTANTS:
type_abap_data     TYPE tv_type VALUE 'D',
type_abap_table    TYPE tv_type VALUE 'T',
type_abap_function TYPE tv_type VALUE 'F',
type_abap_class    TYPE tv_type VALUE 'R',
type_abap_method   TYPE tv_type VALUE 'M'.
CONSTANTS:
c_open_paren   TYPE char1 VALUE '(',
c_close_paren  TYPE char1 VALUE ')'.

CLASS-METHODS class_constructor.

CLASS-DATA nil TYPE REF TO   lcl_lisp READ-ONLY.
CLASS-DATA false TYPE REF TO  lcl_lisp READ-ONLY.
CLASS-DATA true TYPE REF TO  lcl_lisp READ-ONLY.

*      Specifically for cons cells:
DATA car TYPE REF TO lcl_lisp. "Contents of Address portion of Register
DATA cdr TYPE REF TO lcl_lisp. "Contents of Decrement portion of Register

*      Specifically for lambdas:
DATA environment TYPE REF TO lcl_lisp_environment.
*      Format
METHODS to_string RETURNING value(str) TYPE string
RAISING   lcx_lisp_eval_err.
*      Utilities
METHODS first RETURNING value(ro_car) TYPE REF TO lcl_lisp.
METHODS rest RETURNING value(ro_cdr) TYPE REF TO lcl_lisp.

*      Factories
CLASS-METHODS new_atom IMPORTING value          TYPE any
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.
CLASS-METHODS new_symbol IMPORTING value          TYPE any
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.
CLASS-METHODS new_number IMPORTING value          TYPE any
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.
CLASS-METHODS new_string IMPORTING value          TYPE any
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.

CLASS-METHODS new_elem IMPORTING type           TYPE tv_type
value          TYPE any
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.
CLASS-METHODS new_data IMPORTING ref            TYPE REF TO data OPTIONAL
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.
CLASS-METHODS new_table IMPORTING ref            TYPE REF TO data OPTIONAL
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.
CLASS-METHODS new_cons IMPORTING io_car         TYPE REF TO lcl_lisp OPTIONAL
io_cdr         TYPE REF TO lcl_lisp OPTIONAL
RETURNING value(ro_cons) TYPE REF TO lcl_lisp.
CLASS-METHODS new_lambda IMPORTING io_car           TYPE REF TO lcl_lisp
io_cdr           TYPE REF TO lcl_lisp
io_env           TYPE REF TO lcl_lisp_environment
RETURNING value(ro_lambda) TYPE REF TO lcl_lisp.

CLASS-METHODS throw IMPORTING message TYPE string
RAISING   lcx_lisp_eval_err.
PROTECTED SECTION.
CLASS-METHODS new IMPORTING type           TYPE tv_type
io_car         TYPE REF TO lcl_lisp DEFAULT nil
io_cdr         TYPE REF TO lcl_lisp DEFAULT nil
RETURNING value(ro_elem) TYPE REF TO lcl_lisp.

METHODS list_to_string RETURNING value(str) TYPE string
RAISING   lcx_lisp_eval_err.
ENDCLASS.                    "lcl_lisp DEFINITION

INTERFACE lif_port.
METHODS write IMPORTING element TYPE REF TO lcl_lisp.
ENDINTERFACE.

CLASS lcl_console DEFINITION.
PUBLIC SECTION.
INTERFACES lif_port.
ALIASES write FOR lif_port~write.
ENDCLASS.                    "lcl_console DEFINITION

CLASS lcl_console IMPLEMENTATION.

METHOD write.
ENDMETHOD.

ENDCLASS.                    "lcl_console DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_iterator DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_lisp_iterator DEFINITION CREATE PRIVATE.
PUBLIC SECTION.
CLASS-METHODS new IMPORTING io_elem        TYPE REF TO lcl_lisp
RETURNING value(ro_iter) TYPE REF TO lcl_lisp_iterator
RAISING   lcx_lisp_eval_err.
METHODS has_next RETURNING value(rv_flag) TYPE flag.
METHODS next RETURNING value(ro_elem) TYPE REF TO lcl_lisp
RAISING   cx_dynamic_check.
PRIVATE SECTION.
DATA first TYPE flag VALUE abap_true.
DATA elem TYPE REF TO lcl_lisp.
ENDCLASS.                    "lcl_lisp_iterator DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_hash DEFINITION
*----------------------------------------------------------------------*
* Hash is a specialized ABAP Lisp type for quick lookup of elements
* using a symbol or string key (backed by an ABAP hash table)
*----------------------------------------------------------------------*
CLASS lcl_lisp_hash DEFINITION INHERITING FROM lcl_lisp.
PUBLIC SECTION.

CLASS-METHODS new_hash IMPORTING list           TYPE REF TO lcl_lisp
RETURNING value(ro_elem) TYPE REF TO lcl_lisp_hash
RAISING   lcx_lisp_exception.
CLASS-METHODS from_list IMPORTING list           TYPE REF TO lcl_lisp
msg            TYPE string
RETURNING value(ro_hash) TYPE REF TO lcl_lisp_hash
RAISING   lcx_lisp_exception.

METHODS get IMPORTING list          TYPE REF TO lcl_lisp
RETURNING value(result) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_exception.
METHODS insert IMPORTING list          TYPE REF TO lcl_lisp
RETURNING value(result) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_exception.
METHODS delete IMPORTING list          TYPE REF TO lcl_lisp
RETURNING value(result) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_exception.
METHODS get_hash_keys RETURNING value(result) TYPE REF TO lcl_lisp.

PROTECTED SECTION.
TYPES: BEGIN OF ts_hash,
key     TYPE string,
element TYPE REF TO lcl_lisp,
END OF ts_hash.
TYPES tt_hash TYPE HASHED TABLE OF ts_hash WITH UNIQUE KEY key.
DATA hash TYPE tt_hash.

ENDCLASS.                    "lcl_lisp_hash DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_abapfunction DEFINITION
*----------------------------------------------------------------------*
* Specialized element representing an ABAP function module that can
* be called
*----------------------------------------------------------------------*
CLASS lcl_lisp_abapfunction DEFINITION INHERITING FROM lcl_lisp.
PUBLIC SECTION.
CLASS-METHODS new_function
IMPORTING list           TYPE REF TO lcl_lisp
RETURNING value(ro_func) TYPE REF TO lcl_lisp_abapfunction
RAISING   lcx_lisp_exception.

METHODS call IMPORTING list           TYPE REF TO lcl_lisp
RETURNING value(ro_elem) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_exception.

METHODS get_function_parameter IMPORTING identifier TYPE REF TO lcl_lisp
RETURNING value(rdata) TYPE REF TO data
RAISING   lcx_lisp_eval_err.
PROTECTED SECTION.
TYPES tt_rsexc TYPE STANDARD TABLE OF rsexc WITH DEFAULT KEY.   " Exceptions
TYPES tt_rsexp TYPE STANDARD TABLE OF rsexp WITH DEFAULT KEY.   " Exporting
TYPES tt_rsimp TYPE STANDARD TABLE OF rsimp WITH DEFAULT KEY.   " Importing
TYPES tt_rscha TYPE STANDARD TABLE OF rscha WITH DEFAULT KEY.   " Changing
TYPES tt_rstbl TYPE STANDARD TABLE OF rstbl WITH DEFAULT KEY.   " Tables

TYPES: BEGIN OF ts_interface,
exc TYPE tt_rsexc,
exp TYPE tt_rsexp,
imp TYPE tt_rsimp,
cha TYPE tt_rscha,
tbl TYPE tt_rstbl,
enh_exp TYPE tt_rsexp,
enh_imp TYPE tt_rsimp,
enh_cha TYPE tt_rscha,
enh_tbl TYPE tt_rstbl,
REMOTE_CALL TYPE RS38L-REMOTE,
END OF ts_interface.

DATA parameters TYPE abap_func_parmbind_tab.
DATA exceptions TYPE abap_func_excpbind_tab.
DATA interface TYPE ts_interface.

METHODS read_interface IMPORTING iv_name TYPE csequence
RETURNING VALUE(function_name) TYPE rs38l-name
RAISING   lcx_lisp_exception.
METHODS create_parameters IMPORTING list TYPE REF TO lcl_lisp
RAISING   lcx_lisp_exception.
METHODS create_exceptions.

METHODS error_message RETURNING VALUE(rv_message) TYPE string.
PRIVATE SECTION.
CONSTANTS c_error_message TYPE i VALUE 99.

TYPES: BEGIN OF ts_params,
PARAMETER TYPE PARAMETER,
DBFIELD   TYPE LIKEFIELD,
TYP       TYPE RS38L_TYP,

DEFAULT  TYPE DEFAULT__3,
OPTIONAL TYPE RS38L_OPTI,
END OF ts_params.
TYPES tt_params TYPE STANDARD TABLE OF ts_params.
DATA parameters_generated TYPE flag.

METHODS create_table_params IMPORTING it_table TYPE tt_rstbl.
METHODS create_params IMPORTING it_table TYPE STANDARD TABLE
iv_kind TYPE i.
ENDCLASS.                    "lcl_lisp_abapfunction DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_environment DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_lisp_environment DEFINITION CREATE PRIVATE.
PUBLIC SECTION.

*      Reference to outer (parent) environment:
DATA outer TYPE REF TO lcl_lisp_environment.

CLASS-METHODS
new IMPORTING io_outer      TYPE REF TO lcl_lisp_environment OPTIONAL
RETURNING value(ro_env) TYPE REF TO lcl_lisp_environment.

METHODS:
find IMPORTING symbol     TYPE any
RETURNING value(env) TYPE REF TO lcl_lisp_environment
RAISING   lcx_lisp_eval_err,
lookup IMPORTING symbol      TYPE any
RETURNING value(cell) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_eval_err,
define IMPORTING symbol  TYPE string
element TYPE REF TO lcl_lisp,
*        Convenience method to add a value and create the cell
define_value IMPORTING symbol         TYPE string
type           TYPE lcl_lisp=>tv_type
value          TYPE any OPTIONAL
RETURNING value(element) TYPE REF TO lcl_lisp.

METHODS parameters_to_symbols IMPORTING io_pars       TYPE REF TO lcl_lisp
io_args       TYPE REF TO lcl_lisp
RETURNING value(ro_env) TYPE REF TO lcl_lisp_environment
RAISING   lcx_lisp_eval_err.
PROTECTED SECTION.

TYPES: BEGIN OF ts_map,
symbol TYPE string,
value  TYPE REF TO lcl_lisp,
END OF ts_map.
TYPES tt_map TYPE HASHED TABLE OF ts_map WITH UNIQUE KEY symbol.

DATA map TYPE tt_map.

METHODS unbound_symbol IMPORTING symbol TYPE any
RAISING lcx_lisp_eval_err.
ENDCLASS.                    "lcl_lisp_environment DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_parser DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_parser DEFINITION.
PUBLIC SECTION.
TYPES tt_element TYPE STANDARD TABLE OF REF TO lcl_lisp WITH DEFAULT KEY.

METHODS:
constructor,
parse IMPORTING code            TYPE clike
RETURNING value(elements) TYPE tt_element
RAISING   lcx_lisp_parse_err.
PRIVATE SECTION.
CONSTANTS:
c_escape_char  TYPE char1 VALUE '\',
c_text_quote   TYPE char1 VALUE '"',
c_lisp_quote   TYPE char1 VALUE '''', "LISP single quote = QUOTE
c_lisp_comment TYPE char1 VALUE ';'.
DATA code TYPE string.
DATA length TYPE i.
DATA index TYPE i.
DATA char TYPE char1.

DATA mv_eol TYPE char1.
DATA mv_whitespace TYPE char04.
DATA mv_delimiters TYPE char05.

METHODS:
next_char RAISING lcx_lisp_parse_err,
skip_whitespace
RETURNING value(rv_has_next) TYPE flag
RAISING lcx_lisp_parse_err,
parse_list RETURNING value(result) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_parse_err,
parse_token RETURNING value(element) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_parse_err.
METHODS match_string CHANGING cv_val TYPE string.
METHODS run_to_delimiter CHANGING cv_val TYPE string.
ENDCLASS.                    "lcl_parser DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_interpreter DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_lisp_interpreter DEFINITION INHERITING FROM lcl_parser.

PUBLIC SECTION.
DATA env TYPE REF TO lcl_lisp_environment. "Global environment
DATA nil TYPE REF TO lcl_lisp READ-ONLY.
DATA false TYPE REF TO lcl_lisp READ-ONLY.
DATA true TYPE REF TO lcl_lisp READ-ONLY.

METHODS constructor IMPORTING ii_port TYPE REF TO lif_port OPTIONAL.

*      Methods for evaluation
METHODS:
eval
IMPORTING element       TYPE REF TO lcl_lisp
environment   TYPE REF TO lcl_lisp_environment
RETURNING value(result) TYPE  REF TO lcl_lisp
RAISING   lcx_lisp_eval_err,
* To enable a REPL, the following convenience method wraps parsing and evaluating
* and stringifies the response/error
eval_source
IMPORTING code            TYPE clike
RETURNING value(response) TYPE string,
eval_repl
IMPORTING code            TYPE clike
RETURNING value(response) TYPE string
RAISING   lcx_lisp_eval_err.

* Functions for dealing with lists:
_proc_meth:
proc_append,   ##called
proc_append_unsafe,   ##called
proc_reverse,  ##called
proc_car,      ##called
proc_cdr,      ##called
proc_cons,     ##called

proc_memq,     ##called
proc_memv,     ##called
proc_member,   ##called
proc_assq,     ##called
proc_assv,     ##called
proc_assoc,    ##called

proc_length,   ##called
proc_list,     ##called
proc_nilp.     ##called

* Native functions:
_proc_meth:
proc_subtract, ##called
proc_multiply, ##called
proc_divide,   ##called
proc_gt,       ##called
proc_gte,      ##called
proc_lt,       ##called
proc_lte,      ##called
proc_eql,      ##called
proc_eqv,      ##called

proc_is_number,     ##called
proc_is_string,     ##called
proc_is_symbol,     ##called
proc_is_hash,       ##called
proc_is_type,       ##called
proc_is_procedure,  ##called
proc_is_list,       ##called
proc_is_alist,      ##called

* Math
proc_abs,      ##called
proc_quotient, ##called
proc_sin,      ##called
proc_cos,      ##called
proc_tan,      ##called
proc_asin,     ##called
proc_acos,     ##called
proc_atan,     ##called
proc_sinh,     ##called
proc_cosh,     ##called
proc_tanh,     ##called
proc_asinh,    ##called
proc_acosh,    ##called
proc_atanh,    ##called
proc_exp,      ##called
proc_expt,     ##called
proc_log,      ##called
proc_sqrt,     ##called

proc_is_zero,      ##called
proc_is_positive,  ##called
proc_is_negative,  ##called
proc_is_odd,       ##called
proc_is_even,      ##called

proc_floor,        ##called
proc_ceiling,      ##called
proc_truncate,     ##called
proc_round,        ##called

proc_remainder,    ##called
proc_modulo,       ##called
* Not in the spec: Just adding it anyway
proc_eq,           ##called
proc_equal.        ##called

* Functions for dealing with hashes:
_proc_meth:
proc_make_hash,    ##called "Create new hash
proc_hash_get,     ##called "Get an element from a hash
proc_hash_insert,  ##called "Insert a new element into a hash
proc_hash_remove,  ##called "Delete an item from a hash
proc_hash_keys.    ##called "Delete an item from a hash

* Built-in functions for ABAP integration:
_proc_meth:
proc_abap_data,          ##called
proc_abap_function,      ##called
proc_abap_table,         ##called
proc_abap_append_row,    ##called
proc_abap_delete_row,    ##called
proc_abap_get_row,       ##called
proc_abap_get_value,     ##called
proc_abap_set_value,     ##called
proc_abap_set,           ##called
proc_abap_get,           ##called
* Called internally only:
proc_abap_function_call. ##called

PROTECTED SECTION.
METHODS assign_symbol
IMPORTING element       TYPE REF TO lcl_lisp
environment   TYPE REF TO lcl_lisp_environment
RETURNING value(result) TYPE  REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.

METHODS re_assign_symbol
IMPORTING element       TYPE REF TO lcl_lisp
environment   TYPE REF TO lcl_lisp_environment
RETURNING value(result) TYPE  REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.

*----  ABAP Integration support functions; mapping -----
METHODS:
*        Convert ABAP data to Lisp element
data_to_element IMPORTING value(data)    TYPE any
RETURNING value(element) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_eval_err,
*        Convert Lisp element to ABAP Data
element_to_data IMPORTING value(element) TYPE REF TO lcl_lisp
CHANGING  value(data)    TYPE any "ref to data
RAISING   lcx_lisp_eval_err,
*        Determine an ABAP data component from an element and an identifier
get_element IMPORTING list         TYPE REF TO lcl_lisp
RETURNING value(rdata) TYPE REF TO data
RAISING   lcx_lisp_eval_err.

METHODS console IMPORTING io_elem TYPE REF TO lcl_lisp
RETURNING VALUE(result) TYPE REF TO lcl_lisp.

DATA mi_port TYPE REF TO lif_port.

PRIVATE SECTION.
METHODS throw IMPORTING message TYPE string
RAISING   lcx_lisp_eval_err.

METHODS proc_equivalence IMPORTING a TYPE REF TO lcl_lisp
b TYPE REF TO lcl_lisp
RETURNING VALUE(result) TYPE REF TO lcl_lisp
RAISING lcx_lisp_eval_err.
METHODS proc_compare IMPORTING a TYPE REF TO lcl_lisp
b TYPE REF TO lcl_lisp
RETURNING VALUE(result) TYPE REF TO lcl_lisp
RAISING lcx_lisp_eval_err.
METHODS create_element_from_data
IMPORTING ir_data       TYPE REF TO data
RETURNING value(result) TYPE REF TO lcl_lisp.

METHODS structure_to_element IMPORTING value(struct)  TYPE any
RETURNING value(element) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.
METHODS get_structure_field IMPORTING element           TYPE REF TO lcl_lisp
value(identifier) TYPE REF TO lcl_lisp
RETURNING value(rdata)      TYPE REF TO data
RAISING   lcx_lisp_eval_err.
METHODS get_table_row_with_key IMPORTING element           TYPE REF TO lcl_lisp
value(identifier) TYPE REF TO lcl_lisp
RETURNING value(rdata)      TYPE REF TO data
RAISING   lcx_lisp_eval_err.
METHODS get_index_table_row IMPORTING element           TYPE REF TO lcl_lisp
value(identifier) TYPE REF TO lcl_lisp
RETURNING value(rdata)      TYPE REF TO data
RAISING   lcx_lisp_eval_err.

METHODS evaluate_parameters IMPORTING io_list        TYPE REF TO lcl_lisp
environment    TYPE REF TO lcl_lisp_environment
RETURNING value(ro_args) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.
METHODS eval_function IMPORTING io_head       TYPE REF TO lcl_lisp
io_args       TYPE REF TO lcl_lisp
environment   TYPE REF TO lcl_lisp_environment
RETURNING value(result) TYPE  REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.

METHODS extract_arguments IMPORTING io_head TYPE REF TO lcl_lisp
EXPORTING eo_pars TYPE REF TO lcl_lisp
eo_args TYPE REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.
METHODS evaluate_list IMPORTING io_head       TYPE REF TO lcl_lisp
io_env        TYPE REF TO lcl_lisp_environment
RETURNING value(result) TYPE REF TO lcl_lisp
RAISING   lcx_lisp_eval_err.

METHODS evaluate_in_sequence IMPORTING io_pars  TYPE REF TO lcl_lisp
io_args  TYPE REF TO lcl_lisp
io_env   TYPE REF TO lcl_lisp_environment
RAISING   lcx_lisp_eval_err.
METHODS init_letrec IMPORTING io_pars TYPE REF TO lcl_lisp
io_env        TYPE REF TO lcl_lisp_environment
RAISING   lcx_lisp_eval_err.
METHODS init_named_let IMPORTING io_pars TYPE REF TO lcl_lisp
io_env        TYPE REF TO lcl_lisp_environment
RAISING   lcx_lisp_eval_err.
ENDCLASS.                    "lcl_lisp_interpreter DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_parser IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_parser IMPLEMENTATION.

METHOD constructor.
*      End of line value
mv_eol = cl_abap_char_utilities=>newline.
*      Whitespace values
CLEAR mv_whitespace.
mv_whitespace+0(1) = ' '.
mv_whitespace+1(1) = cl_abap_char_utilities=>newline.
mv_whitespace+2(1) = cl_abap_char_utilities=>cr_lf(1).
mv_whitespace+3(1) = cl_abap_char_utilities=>horizontal_tab.
*      Delimiters value
mv_delimiters = mv_whitespace.
mv_delimiters+3(1) = lcl_lisp=>c_close_paren.
mv_delimiters+4(1) = lcl_lisp=>c_open_paren.
ENDMETHOD.                    "constructor

METHOD skip_whitespace.
WHILE char CA mv_whitespace AND index LT length.
next_char( ).
ENDWHILE.
rv_has_next = boolc( index LT length ).
CHECK char EQ c_lisp_comment AND rv_has_next EQ abap_true.
*      skip until end of line
WHILE char CN mv_eol AND index LT length.
next_char( ).
ENDWHILE.
rv_has_next = skip_whitespace( ).
ENDMETHOD.                    "skip_whitespace

METHOD next_char.
index = index + 1.
IF index < length.
char = code+index(1).
ELSEIF index = length.
char = space.
ELSEIF index > length.
*        Unexpected end
RAISE EXCEPTION TYPE lcx_lisp_parse_err.
ENDIF.
ENDMETHOD.                    "next_char

METHOD parse.
*      Entry point for parsing code. This is not thread-safe, but as an ABAP
*      process does not have the concept of threads, we are safe :-)
me->code = code.
length = strlen( code ).
IF length = 0.
APPEND lcl_lisp=>nil TO elements.
RETURN.
ENDIF.

index = 0.
char = code+index(1).           "Kick off things by reading first char
WHILE skip_whitespace( ) EQ abap_true.
IF char = lcl_lisp=>c_open_paren.
APPEND parse_list( ) TO elements.
ELSEIF index < length.
APPEND parse_token( ) TO elements.
ENDIF.
ENDWHILE.
ENDMETHOD.                    "parse

METHOD parse_list.
DATA lo_cell TYPE REF TO lcl_lisp.
DATA lv_empty_list TYPE boole_d VALUE abap_true.

*      Set pointer to start of list
lo_cell = result = lcl_lisp=>new_cons( ).

next_char( ).                 " Skip past opening paren
WHILE skip_whitespace( ) EQ abap_true.
IF char = lcl_lisp=>c_close_paren.
IF lv_empty_list = abap_true.
result = lcl_lisp=>nil.           " Result = empty list
ELSE.
lo_cell->cdr = lcl_lisp=>nil.     " Terminate list
ENDIF.
next_char( ).              " Skip past closing paren
RETURN.
ENDIF.
IF lv_empty_list = abap_false.
*          On at least the second item; add new cell and move pointer
lo_cell = lo_cell->cdr = lcl_lisp=>new_cons( ).
ENDIF.
lv_empty_list = abap_false. " Next char was not closing paren
lo_cell->car = parse_token( ).
ENDWHILE.
ENDMETHOD.                    "parse_list

METHOD match_string.
DATA pchar TYPE char1.

next_char( ).                 " Skip past opening quote
WHILE index < length
AND NOT ( char = c_text_quote AND pchar NE c_escape_char ).
*         cv_val = |{ cv_val }{ char }|.
CONCATENATE cv_val char INTO cv_val RESPECTING BLANKS.
pchar = char.
next_char( ).
ENDWHILE.
next_char( ).                 "Skip past closing quote
ENDMETHOD.                    "match_string

METHOD run_to_delimiter.
WHILE index < length.
cv_val = |{ cv_val }{ char }|.
next_char( ).
CHECK char CA mv_delimiters.
EXIT.
ENDWHILE.
CONDENSE cv_val.
IF cv_val = cl_abap_char_utilities=>newline.
cv_val = space.
ENDIF.
ENDMETHOD.                    "run_to_delimiter

METHOD parse_token.
DATA sval TYPE string.

skip_whitespace( ).
*      create object cell.
CASE char.
WHEN lcl_lisp=>c_open_paren.
element = parse_list( ).

WHEN c_lisp_quote.
* ' is just a shortcut for QUOTE, so we wrap the consecutive element in a list starting with the quote symbol
* so that when it is evaluated later, it returns the quote elements unmodified
next_char( ).            " Skip past single quote
element = lcl_lisp=>new_cons( io_car = lcl_lisp=>new_symbol( 'quote' )
io_cdr = lcl_lisp=>new_cons( io_cdr = lcl_lisp=>nil
io_car = parse_token( ) ) ).
WHEN c_text_quote.
match_string( CHANGING cv_val = sval ).
element = lcl_lisp=>new_string( sval ).

WHEN OTHERS.
run_to_delimiter( CHANGING cv_val = sval ).
IF sval IS INITIAL.
element = lcl_lisp=>nil.
ELSE.
element = lcl_lisp=>new_atom( sval ).
ENDIF.

ENDCASE.

ENDMETHOD.                    "parse_token

ENDCLASS.                    "lcl_parser IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_interpreter IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp_interpreter IMPLEMENTATION.

METHOD constructor.
super->constructor( ).

IF ii_port IS BOUND.
mi_port = ii_port.
ELSE.
CREATE OBJECT mi_port TYPE lcl_console.
ENDIF.

env = lcl_lisp_environment=>new( ).

*      Create symbols for nil, true and false values
nil = lcl_lisp=>nil.
true = lcl_lisp=>true.
false = lcl_lisp=>false.
env->define( symbol = 'nil'  element = nil ).
env->define( symbol = '#f' element = false ).
env->define( symbol = '#t' element = true ).

*      Add native functions to environment
env->define_value( symbol = '+'       type = lcl_lisp=>type_native value   = 'PROC_ADD' ).
env->define_value( symbol = '-'       type = lcl_lisp=>type_native value   = 'PROC_SUBTRACT' ).
env->define_value( symbol = '*'       type = lcl_lisp=>type_native value   = 'PROC_MULTIPLY' ).
env->define_value( symbol = '/'       type = lcl_lisp=>type_native value   = 'PROC_DIVIDE' ).
env->define_value( symbol = 'append'  type = lcl_lisp=>type_native value   = 'PROC_APPEND' ).
env->define_value( symbol = 'append!' type = lcl_lisp=>type_native value   = 'PROC_APPEND_UNSAFE' ).
env->define_value( symbol = 'list'    type = lcl_lisp=>type_native value   = 'PROC_LIST' ).
env->define_value( symbol = 'length'  type = lcl_lisp=>type_native value   = 'PROC_LENGTH' ).
env->define_value( symbol = 'reverse' type = lcl_lisp=>type_native value   = 'PROC_REVERSE' ).

env->define_value( symbol = 'memq'    type = lcl_lisp=>type_native value   = 'PROC_MEMQ' ).
env->define_value( symbol = 'memv'    type = lcl_lisp=>type_native value   = 'PROC_MEMV' ).
env->define_value( symbol = 'member'  type = lcl_lisp=>type_native value   = 'PROC_MEMBER' ).

env->define_value( symbol = 'assq'    type = lcl_lisp=>type_native value   = 'PROC_ASSQ' ).
env->define_value( symbol = 'assv'    type = lcl_lisp=>type_native value   = 'PROC_ASSV' ).
env->define_value( symbol = 'assoc'   type = lcl_lisp=>type_native value   = 'PROC_ASSOC' ).

env->define_value( symbol = 'car'     type = lcl_lisp=>type_native value   = 'PROC_CAR' ).
env->define_value( symbol = 'cdr'     type = lcl_lisp=>type_native value   = 'PROC_CDR' ).
env->define_value( symbol = 'cons'    type = lcl_lisp=>type_native value   = 'PROC_CONS' ).
env->define_value( symbol = 'nil?'    type = lcl_lisp=>type_native value   = 'PROC_NILP' ).
env->define_value( symbol = 'null?'   type = lcl_lisp=>type_native value   = 'PROC_NILP' ).
env->define_value( symbol = '>'       type = lcl_lisp=>type_native value   = 'PROC_GT' ).
env->define_value( symbol = '>='      type = lcl_lisp=>type_native value   = 'PROC_GTE' ).
env->define_value( symbol = '<'       type = lcl_lisp=>type_native value   = 'PROC_LT' ).
env->define_value( symbol = '<='      type = lcl_lisp=>type_native value   = 'PROC_LTE' ).
env->define_value( symbol = '='       type = lcl_lisp=>type_native value   = 'PROC_EQL' ). "Math equal
env->define_value( symbol = 'eq?'     type = lcl_lisp=>type_native value   = 'PROC_EQ' ).
env->define_value( symbol = 'eqv?'    type = lcl_lisp=>type_native value   = 'PROC_EQV' ).
env->define_value( symbol = 'equal?'  type = lcl_lisp=>type_native value   = 'PROC_EQUAL' ).
*      Hash-related functions
env->define_value( symbol = 'make-hash'   type = lcl_lisp=>type_native value   = 'PROC_MAKE_HASH' ).
env->define_value( symbol = 'hash-get'    type = lcl_lisp=>type_native value   = 'PROC_HASH_GET' ).
env->define_value( symbol = 'hash-insert' type = lcl_lisp=>type_native value   = 'PROC_HASH_INSERT' ).
env->define_value( symbol = 'hash-remove' type = lcl_lisp=>type_native value   = 'PROC_HASH_REMOVE' ).
env->define_value( symbol = 'hash-keys'   type = lcl_lisp=>type_native value   = 'PROC_HASH_KEYS' ).
*      Functions for type:
env->define_value( symbol = 'string?'     type = lcl_lisp=>type_native value = 'PROC_IS_STRING' ).
env->define_value( symbol = 'hash?'       type = lcl_lisp=>type_native value = 'PROC_IS_HASH' ).
env->define_value( symbol = 'number?'     type = lcl_lisp=>type_native value = 'PROC_IS_NUMBER' ).
env->define_value( symbol = 'list?'       type = lcl_lisp=>type_native value = 'PROC_IS_LIST' ).
env->define_value( symbol = 'alist?'      type = lcl_lisp=>type_native value = 'PROC_IS_ALIST' ).
env->define_value( symbol = 'procedure?'  type = lcl_lisp=>type_native value = 'PROC_IS_PROCEDURE' ).
env->define_value( symbol = 'symbol?'     type = lcl_lisp=>type_native value = 'PROC_IS_SYMBOL' ).
env->define_value( symbol = 'type'        type = lcl_lisp=>type_native value = 'PROC_IS_TYPE' ).

*      Math
env->define_value( symbol = 'abs' type = lcl_lisp=>type_native value = 'PROC_ABS' ).
env->define_value( symbol = 'sin' type = lcl_lisp=>type_native value = 'PROC_SIN' ).
env->define_value( symbol = 'cos' type = lcl_lisp=>type_native value = 'PROC_COS' ).
env->define_value( symbol = 'tan' type = lcl_lisp=>type_native value = 'PROC_TAN' ).
env->define_value( symbol = 'asin' type = lcl_lisp=>type_native value = 'PROC_ASIN' ).
env->define_value( symbol = 'acos' type = lcl_lisp=>type_native value = 'PROC_ACOS' ).
env->define_value( symbol = 'atan' type = lcl_lisp=>type_native value = 'PROC_ATAN' ).
env->define_value( symbol = 'sinh' type = lcl_lisp=>type_native value = 'PROC_SINH' ).
env->define_value( symbol = 'cosh' type = lcl_lisp=>type_native value = 'PROC_COSH' ).
env->define_value( symbol = 'tanh' type = lcl_lisp=>type_native value = 'PROC_TANH' ).
env->define_value( symbol = 'asinh' type = lcl_lisp=>type_native value = 'PROC_ASINH' ).
env->define_value( symbol = 'acosh' type = lcl_lisp=>type_native value = 'PROC_ACOSH' ).
env->define_value( symbol = 'atanh' type = lcl_lisp=>type_native value = 'PROC_ATANH' ).
env->define_value( symbol = 'expt' type = lcl_lisp=>type_native value = 'PROC_EXPT' ).
env->define_value( symbol = 'exp' type = lcl_lisp=>type_native value = 'PROC_EXP' ).
env->define_value( symbol = 'log' type = lcl_lisp=>type_native value = 'PROC_LOG' ).
env->define_value( symbol = 'sqrt' type = lcl_lisp=>type_native value = 'PROC_SQRT' ).

env->define_value( symbol = 'floor'    type = lcl_lisp=>type_native value = 'PROC_FLOOR' ).
env->define_value( symbol = 'ceiling'  type = lcl_lisp=>type_native value = 'PROC_CEILING' ).
env->define_value( symbol = 'truncate' type = lcl_lisp=>type_native value = 'PROC_TRUNCATE' ).
env->define_value( symbol = 'round'    type = lcl_lisp=>type_native value = 'PROC_ROUND' ).

env->define_value( symbol = 'remainder' type = lcl_lisp=>type_native value = 'PROC_REMAINDER' ).
env->define_value( symbol = 'modulo'    type = lcl_lisp=>type_native value = 'PROC_MODULO' ).
env->define_value( symbol = 'quotient'  type = lcl_lisp=>type_native value = 'PROC_QUOTIENT' ).

env->define_value( symbol = 'zero?'     type = lcl_lisp=>type_native value = 'PROC_IS_ZERO' ).
env->define_value( symbol = 'positive?' type = lcl_lisp=>type_native value = 'PROC_IS_POSITIVE' ).
env->define_value( symbol = 'negative?' type = lcl_lisp=>type_native value = 'PROC_IS_NEGATIVE' ).
env->define_value( symbol = 'odd?'      type = lcl_lisp=>type_native value = 'PROC_IS_ODD' ).
env->define_value( symbol = 'even?'     type = lcl_lisp=>type_native value = 'PROC_IS_EVEN' ).

*      Native functions for ABAP integration
env->define_value( symbol = 'ab-data'       type = lcl_lisp=>type_native value   = 'PROC_ABAP_DATA' ).
env->define_value( symbol = 'ab-function'   type = lcl_lisp=>type_native value   = 'PROC_ABAP_FUNCTION' ).
env->define_value( symbol = 'ab-table'      type = lcl_lisp=>type_native value   = 'PROC_ABAP_TABLE' ).
env->define_value( symbol = 'ab-append-row' type = lcl_lisp=>type_native value   = 'PROC_ABAP_APPEND_ROW' ).
env->define_value( symbol = 'ab-delete-row' type = lcl_lisp=>type_native value   = 'PROC_ABAP_DELETE_ROW' ).
env->define_value( symbol = 'ab-get-row'    type = lcl_lisp=>type_native value   = 'PROC_ABAP_GET_ROW' ).
env->define_value( symbol = 'ab-get-value'  type = lcl_lisp=>type_native value   = 'PROC_ABAP_GET_VALUE' ).
env->define_value( symbol = 'ab-set-value'  type = lcl_lisp=>type_native value   = 'PROC_ABAP_SET_VALUE' ).

env->define_value( symbol = 'ab-get' type = lcl_lisp=>type_native value = 'PROC_ABAP_GET' ).
env->define_value( symbol = 'ab-set' type = lcl_lisp=>type_native value = 'PROC_ABAP_SET' ).

DATA lr_ref TYPE REF TO data.
*      Define a value in the environment for SYST
GET REFERENCE OF syst INTO lr_ref.
env->define( symbol = 'ab-sy' element = lcl_lisp=>new_data( lr_ref ) ).
ENDMETHOD.                    "constructor

METHOD throw.
RAISE EXCEPTION TYPE lcx_lisp_eval_err
EXPORTING
message = message.
ENDMETHOD.                    "throw

METHOD assign_symbol.
CASE element->car->type.
WHEN lcl_lisp=>type_symbol.
environment->define( symbol  = element->car->value
element = eval( element = element->cdr->car
environment = environment ) ).
result = lcl_lisp=>new_symbol( element->car->value ).
*        Function shorthand (define (id arg ... ) body ...+)
WHEN lcl_lisp=>type_conscell.
*         define's function shorthand allows us to define a function by specifying a list as the
*         first argument where the first element is a symbol and consecutive elements are arguments
result = lcl_lisp=>new_lambda( io_car = element->car->cdr  "List of params following function symbol
io_cdr = element->cdr
io_env = environment ).
*          Add function to the environment with symbol
environment->define( symbol  = element->car->car->value
element = result ).
*          TODO: Here and above: Scheme does not return a value for define; should we?
result = lcl_lisp=>new_symbol( element->car->car->value ).
WHEN OTHERS.
throw( |{ element->car->to_string( ) } cannot be a variable identifier| ).
ENDCASE.
ENDMETHOD.                    "assign_symbol

METHOD re_assign_symbol.
DATA lo_env TYPE REF TO lcl_lisp_environment.

result = element->car.
CASE result->type.
WHEN lcl_lisp=>type_symbol.
lo_env = environment->find( result->value ).
*          re-define in the original environment LO_ENV, but
*          evaluate parameters in the current ENVIRONMENT
lo_env->define( symbol  = result->value
element = eval( element = element->cdr->car
environment = environment ) ).
WHEN OTHERS.
throw( |{ result->to_string( ) } must be a symbol| ).
ENDCASE.
ENDMETHOD.                    "re_assign_symbol

METHOD evaluate_parameters.
*      Before execution of the procedure or lambda, all parameters must be evaluated
DATA lo_arg TYPE REF TO lcl_lisp.
DATA lo_iter TYPE REF TO lcl_lisp_iterator.

ro_args = nil.
CHECK io_list NE nil AND io_list->car NE nil.

lo_arg = ro_args = lcl_lisp=>new_cons( ).

lo_iter = lcl_lisp_iterator=>new( io_list ).
WHILE lo_iter->has_next( ) EQ abap_true.
lo_arg->car = eval( element = lo_iter->next( )
environment = environment ).
IF lo_iter->has_next( ) EQ abap_false.
lo_arg->cdr = nil.
EXIT.
ENDIF.
lo_arg = lo_arg->cdr = lcl_lisp=>new_cons( ).
ENDWHILE.
ENDMETHOD.                    "evaluate_parameters

METHOD eval_function.
*      The function (LAMBDA) receives its own local environment in which to execute,
*      where parameters become symbols that are mapped to the corresponding arguments
DATA lo_args TYPE REF TO lcl_lisp.
DATA lo_env TYPE REF TO lcl_lisp_environment.

lo_args = evaluate_parameters( io_list = io_args           " Pointer to arguments
environment = environment ).
lo_env->parameters_to_symbols( io_args = lo_args
io_pars = io_head->first( ) ).   " Pointer to formal parameters
io_env = lo_env ).
ENDMETHOD.                    "eval_function

METHOD evaluate_list.
DATA lo_iter TYPE REF TO lcl_lisp_iterator.
*      Evaluate lambda
result = nil.
WHILE lo_iter->has_next( ) EQ abap_true.
result = eval( element = lo_iter->next( )
environment = io_env ).
ENDWHILE.
ENDMETHOD.                    "evaluate_list

METHOD extract_arguments.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_pair TYPE REF TO lcl_lisp.
DATA lo_par TYPE REF TO lcl_lisp.
DATA lo_arg TYPE REF TO lcl_lisp.

eo_args = eo_pars = nil.                "list of parameters

validate lo_ptr->car.
eo_pars = lcl_lisp=>new_cons( io_car = lo_ptr->car ).
IF lo_ptr->cdr IS BOUND AND lo_ptr->cdr NE nil.
eo_args = lcl_lisp=>new_cons( io_car = lo_ptr->cdr->car ).
ENDIF.
lo_par = eo_pars.
lo_arg = eo_args.
WHILE lo_ptr->cdr IS BOUND AND lo_ptr->cdr NE nil.
lo_ptr = lo_ptr->cdr.
*        Rest of list, pick head
lo_pair = lo_ptr->car.
IF lo_pair IS BOUND AND lo_pair->car NE nil.
lo_par = lo_par->cdr = lcl_lisp=>new_cons( io_car = lo_pair->car ).
ENDIF.
IF lo_pair->cdr IS BOUND AND lo_pair->cdr NE nil.
lo_arg = lo_arg->cdr = lcl_lisp=>new_cons( io_car = lo_pair->cdr->car ).
ENDIF.
ENDWHILE.
lo_par->cdr = lo_arg->cdr = nil.

*     Debug help: DATA lv_debug TYPE string.
*      lv_debug = |params { eo_pars->to_string( ) }\n arg { eo_args->to_string( ) }\n|.
ENDMETHOD.                    "extract_arguments

* A letrec expression is equivalent to a let where the bindings are initialized with dummy values,
* and then the initial values are computed and assigned into the bindings.
* letrec lets us create an environment before evaluating the initial value expressions, so that the
* initial value computions execute inside the new environment.
*
*(define (some-procedure...)
*   (letrec ((helper (lambda (x)
*                       ...
*                       (if some-test?
*                           (helper ...))))) ; recursive call
*     ...
*     (helper ...)  ; call to recursive local procedure
*     ...))
* Note the procedure helper can "see its own name," since the lambda expression is evaluated in the
* environment where helper is bound. The above example is equivalent to:
*
*(define (some-procedure ...)
*   (let ((helper '*dummy-value*))
*      (set! helper (lambda (x)
*                      ...
*                      (if some-test?
*                          (helper ...))))) ; recursive call
*     ...
*     (helper ...)  ; call to recursive local procedure
*     ...))
METHOD init_letrec.
*       Before evaluating the parameter, we create them all with dummy values
DATA lo_par TYPE REF TO lcl_lisp. " Parameter
DATA lo_dummy TYPE REF TO lcl_lisp.

lo_dummy = lcl_lisp=>new_string( '*letrec-dummy*' ).
lo_par = io_pars.                         " Pointer to formal parameters
WHILE lo_par IS BOUND AND lo_par NE nil.  " Nil means no parameters to map
io_env->define( symbol = lo_par->car->value
element = lo_dummy ).
lo_par = lo_par->cdr.
ENDWHILE.
ENDMETHOD.

*Here's an example loop, which prints out the integers from 0 to 9:
* (  let loop ((i 0))
*     (display i)
*     (if (< i 10)
*         (loop (+ i 1))))
*
*The example is exactly equivalent to:
*  (letrec ((loop (lambda (i)      ; define a recursive
*                    (display i)   ; procedure whose body
*                    (if (< i 10)  ; is the loop body
*                        (loop (+ i 1))))))
*     (loop 0)) ; start the recursion with 0 as arg i
METHOD init_named_let.
ENDMETHOD.

METHOD evaluate_in_sequence.
*      Before execution of the procedure or lambda, all parameters must be evaluated
DATA lo_iter_arg TYPE REF TO lcl_lisp_iterator.
DATA lo_iter_par TYPE REF TO lcl_lisp_iterator.

DATA lo_par TYPE REF TO lcl_lisp.

lo_iter_arg = lcl_lisp_iterator=>new( io_args ).
lo_iter_par = lcl_lisp_iterator=>new( io_pars ).

WHILE lo_iter_arg->has_next( ) EQ abap_true
AND lo_iter_par->has_next( ) EQ abap_true.

lo_par = lo_iter_par->next( ).
CHECK lo_par NE nil.        " Nil would mean no parameters to map
*        Assign argument to its corresponding symbol in the newly created environment
*        NOTE: element of the argument list is evaluated before being defined in the environment
io_env->define( symbol = lo_par->value
element = eval( element = lo_iter_arg->next( )
environment = io_env ) ).
ENDWHILE.
ENDMETHOD.                    "environment_from_sequence

**********************************************************************
*
*------------------------------- EVAL( ) ----------------------------
*; eval takes an expression and an environment to a value
*;(define (eval e env) (cond
*;  ((symbol? e)       (cadr (assq e env)))
*;  ((eq? (car e) 'λ)  (cons e env))
*;  (else              (apply (eval (car e) env) (eval (cadr e) env)))))
**********************************************************************
METHOD eval.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_clause TYPE REF TO lcl_lisp.
validate element.
*      Return predefined symbols as themselves to save having to look them up in the environment
IF element = nil. result = nil. RETURN. ENDIF.
IF element = true. result = true. RETURN. ENDIF.
IF element = false. result = false. RETURN. ENDIF.

CASE element->type.
WHEN lcl_lisp=>type_number OR lcl_lisp=>type_string.
result = element.  "Number or string evaluates to itself

WHEN lcl_lisp=>type_symbol. "Symbol
result = environment->lookup( element->value ).

*---     ### EVAL LIST
WHEN lcl_lisp=>type_conscell. "Cons Cell = List
*          To evaluate list, we must first evaluate head value
DATA lr_head TYPE REF TO lcl_lisp.
DATA lr_tail TYPE REF TO lcl_lisp.
*          Evaluate first element of list to determine if it is a native procedure or lambda
lr_tail = element->cdr.

WHEN 'quote'. " Return the argument to quote unevaluated
IF lr_tail->cdr NE nil.
throw( |QUOTE can only take a single argument| ).
ENDIF.
result = lr_tail->car.

WHEN 'newline'.
result = lcl_lisp=>new_string( |\n| ).

WHEN 'display'.
result = console( eval( element = lr_tail->car
environment = environment )  ).

WHEN 'if'.
IF eval( element = lr_tail->car
environment = environment  ) NE false.
result = eval( element = lr_tail->cdr->car
environment = environment  ).
ELSEIF lr_tail->cdr->cdr = nil.
result = false.
ELSE.
result = eval( element = lr_tail->cdr->cdr->car
environment = environment ).
ENDIF.

WHEN 'and'.
result = true.
lo_ptr = lr_tail.
WHILE lo_ptr IS BOUND AND lo_ptr NE nil AND result NE false.
result = eval( element = lo_ptr->car
environment = environment ).
lo_ptr = lo_ptr->cdr.
ENDWHILE.

WHEN 'or'.
result = false.
lo_ptr = lr_tail.
WHILE lo_ptr IS BOUND AND lo_ptr NE nil AND result EQ false.
result = eval( element = lo_ptr->car
environment = environment ).
lo_ptr = lo_ptr->cdr.
ENDWHILE.

WHEN 'cond'.
lo_ptr = lr_tail.
WHILE lo_ptr NE nil.
lo_clause = lo_ptr->car.
IF lo_clause->car->value EQ 'else'
OR eval( element = lo_clause->car
environment = environment ) NE false.
result = evaluate_list( io_head = lo_clause->cdr
io_env = environment ).
EXIT.
ENDIF.
lo_ptr = lo_ptr->cdr.
ENDWHILE.

WHEN 'define'.
result = assign_symbol( element = lr_tail
environment = environment ).

WHEN 'set!'.                        " Re-Assign symbol
result = re_assign_symbol( element     = lr_tail
environment = environment ).

WHEN 'let'.
*              (let ((x 10) (y 5)) (+ x y)) is syntactic sugar for  ( (lambda (x y) (+ x y)) 10 5)
DATA lo_pars TYPE REF TO lcl_lisp.
DATA lo_args TYPE REF TO lcl_lisp.
DATA lo_env TYPE REF TO lcl_lisp_environment.

IMPORTING eo_pars = lo_pars
eo_args = lo_args ).
lo_env = lcl_lisp_environment=>new( environment ).
init_named_let( io_pars = lo_pars
io_env = lo_env ).

lo_args = evaluate_parameters( io_list = lo_args           " Pointer to arguments
environment = environment ).
lo_env->parameters_to_symbols( io_args = lo_args
io_pars = lo_pars ).   " Pointer to formal parameters
result = evaluate_list( io_head = lr_tail->cdr
io_env = lo_env ).

WHEN 'letrec'.
IMPORTING eo_pars = lo_pars
eo_args = lo_args ).
lo_env = lcl_lisp_environment=>new( environment ).
init_letrec( io_pars = lo_pars
io_env = lo_env ).

lo_args = evaluate_parameters( io_list = lo_args           " Pointer to arguments
environment = lo_env ).
lo_env->parameters_to_symbols( io_args = lo_args
io_pars = lo_pars ).   " Pointer to formal parameters
result = evaluate_list( io_head = lr_tail->cdr
io_env = lo_env ).

WHEN 'let*'.
IMPORTING eo_pars = lo_pars
eo_args = lo_args ).
lo_env = lcl_lisp_environment=>new( environment ).
evaluate_in_sequence( io_args = lo_args      " Pointer to arguments e.g. (4, (+ x 4)
io_pars = lo_pars      " Pointer to formal parameters (x y)
io_env = lo_env ).
result = evaluate_list( io_head = lr_tail->cdr
io_env = lo_env ).

WHEN 'lambda'.
result = lcl_lisp=>new_lambda( io_car = lr_tail->car         " List of parameters
io_cdr = lr_tail->cdr         " Body
io_env = environment ).
WHEN 'begin'.
result = evaluate_list( io_head = lr_tail
io_env = environment ).
WHEN OTHERS.
*---           NATIVE PROCEDURES AND LAMBDAS
*              Other symbols at the start of the list must be evaluated first
*              The evaluated head must be either a native procedure or lambda
lr_head = eval( element = element->car
environment = environment ).

WHEN lcl_lisp=>type_native.
*---               NATIVE FUNCTION
*                  Evaluate native function:
EXPORTING
list   = evaluate_parameters( io_list = lr_tail
environment = environment )
RECEIVING
result = result.

WHEN lcl_lisp=>type_lambda.
io_args = lr_tail
environment = environment ).

WHEN lcl_lisp=>type_abap_function.
*>>> TEST:         Support evaluation of ABAP function directly
*                    Recompose as if calling a PROC (which we are). This is part of the test. If we make an ABAP function
*                    call first-class, then we would need to revisit evaluating the whole of ELEMENT in one shot
result = proc_abap_function_call( lcl_lisp=>new_cons( io_car = lr_head
io_cdr = lr_tail ) ).
*<<< TEST
WHEN OTHERS.
throw( |Cannot evaluate { lr_head->to_string( ) } - not a function| ).

ENDCASE.

ENDCASE.

ENDCASE.
CHECK result IS NOT BOUND.
*      this should not happen if the code is correct!
throw( |EVAL( ) came up empty-handed| ).
ENDMETHOD.                    "eval

METHOD console.
mi_port->write( io_elem ).
result = lcl_lisp=>new_string( io_elem->to_string( ) ).
ENDMETHOD.

METHOD eval_source.
DATA lx_root TYPE REF TO cx_root.
TRY.
response = eval_repl( code ).
CATCH cx_root INTO lx_root.
response = lx_root->get_text( ).
ENDTRY.
ENDMETHOD.                    "eval_source

METHOD eval_repl.
DATA lo_element TYPE REF TO lcl_lisp.
DATA lt_element TYPE tt_element.
DATA lv_value TYPE string.

lt_element = parse( code ).
LOOP AT lt_element INTO lo_element.
lv_value = eval( element = lo_element
environment = env )->to_string( ).
IF response IS INITIAL.
response = lv_value.
ELSE.
response = |{ response } { lv_value }|.
ENDIF.
ENDLOOP.
ENDMETHOD.                    "eval_source

**********************************************************************
* NATIVE PROCEDURES
**********************************************************************
METHOD proc_append.
*      All parameters execpt the last must be lists, the last must be
*      a cons cell. Creates a new list appending all parameters
DATA lo_iter TYPE REF TO lcl_lisp_iterator.

*      But if the last element in the list is not a cons cell, we cannot append
result = nil.
CHECK list IS BOUND.
validate list->car.
result = list->car.

CHECK list->cdr IS BOUND AND list->cdr NE NIL.
validate list->cdr->car.
result = list->cdr->car.

CHECK list->car NE nil.
lo_iter = lcl_lisp_iterator=>new( proc_reverse( list ) ).
WHILE lo_iter->has_next( ) EQ abap_true.
result = lcl_lisp=>new_cons( io_car = lo_iter->next( )
io_cdr = result ).
ENDWHILE.
ENDMETHOD.                    "proc_append

METHOD proc_reverse.
DATA iter TYPE REF TO lcl_lisp_iterator.
*      But if the last element in the list is not a cons cell, we cannot append
validate: list, list->car.

result = nil.
iter = lcl_lisp_iterator=>new( list->car ).
WHILE iter->has_next( ) EQ abap_true.
result = lcl_lisp=>new_cons( io_car = iter->next( )
io_cdr = result ).
ENDWHILE.
ENDMETHOD.                    "proc_reverse

METHOD proc_append_unsafe.  " append! (non functional)
*      Takes two parameters: the first must be a list, and the second can
*      be of any type. Appends the second param to the first.
DATA lo_last TYPE REF TO lcl_lisp.

*      But if the last element in the list is not a cons cell, we cannot append
validate: list, list->car, list->cdr.

IF list->car EQ nil.
result = list->cdr->car.
ELSE.
*        Get to last element in list - this can make APPEND expensive, like LENGTH
lo_last = list->car.
IF lo_last->type NE lcl_lisp=>type_conscell.
throw( |{ lo_last->to_string( ) } is not a list| ).
ENDIF.

WHILE lo_last->cdr IS BOUND AND lo_last->cdr NE nil.
lo_last = lo_last->cdr.
ENDWHILE.

IF lo_last->type NE lcl_lisp=>type_conscell.
*          If the last item is not a cons cell, return an error
throw( |{ list->car->to_string( ) } is not a proper list| ).
ENDIF.

*        Last item is a cons cell; tack on the new value
lo_last->cdr = list->cdr->car.
result = list->car.
ENDIF.
ENDMETHOD.                    "proc_append_unsafe

METHOD proc_car.
validate: list, list->car.
IF list->car = nil.
result = nil.
RETURN.
ENDIF.
result = list->car->car.
ENDMETHOD.                    "proc_car

METHOD proc_cdr.
validate: list, list->car, list->cdr.

IF list->cdr = nil AND list->car = nil.
result = nil.
RETURN.
ENDIF.
result = list->car->cdr.
ENDMETHOD.                    "proc_cdr

METHOD proc_cons.
*      Create new cell and prepend it to second parameter
validate: list, list->car, list->cdr.

result = lcl_lisp=>new_cons( io_car = list->car
io_cdr = list->cdr->car ).
ENDMETHOD.                    "proc_cons

* (defun list-length (x)
*   (do ((n 0 (+ n 2))           ;Counter.
*        (fast x (cddr fast))    ;Fast pointer: leaps by 2.
*        (slow x (cdr slow)))    ;Slow pointer: leaps by 1.
*       (nil)
*     ;; If fast pointer hits the end, return the count.
*     (when (endp fast) (return n))
*     (when (endp (cdr fast)) (return (+ n 1)))
*     ;; If fast pointer eventually equals slow pointer, then we must be stuck in a circular list.
*     ;; (A deeper property is the converse: if we are stuck in a circular list, then eventually
*     ;; the fast pointer will equal the slow pointer. That fact justifies this implementation.
*     (when (and (eq fast slow) (> n 0)) (return nil))))
METHOD proc_length.
DATA lo_elem TYPE REF TO lcl_lisp.

validate: list, list->cdr.
IF list->cdr NE nil.
throw( |LIST takes only one argument| ).
ENDIF.

result = lcl_lisp=>new_number( 0 ).
CHECK list NE nil AND ( list->car NE nil OR list->cdr NE nil ).

*      Iterate over list to count the number of items
result->number = 1.
lo_elem = list->car.
WHILE lo_elem->cdr IS BOUND AND lo_elem->cdr NE nil.
lo_elem = lo_elem->cdr.
ENDWHILE.
CHECK lo_elem->type NE lcl_lisp=>type_conscell
AND list->car->type NE lcl_lisp=>type_conscell.
*      If the last item is not a cons cell, return an error
throw( |{ list->car->to_string( ) } is not a proper list| ).
ENDMETHOD.                    "proc_length

METHOD proc_list.
*      The items given to us are already in a list and evaluated; we just need to return the head
result = list.
ENDMETHOD.                    "proc_list

METHOD proc_nilp.
validate: list, list->car.
IF list->car = nil. " or
result = true.
ELSE.
result = false.
ENDIF.
ENDMETHOD.                    "proc_nilp

* TO BE IMPLEMENTED
METHOD proc_memq.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_ref TYPE REF TO lcl_lisp.
validate: list, list->car.

result = false.
lo_ref = list->car.
CHECK list->cdr IS BOUND.

lo_ptr = list->cdr->car.
WHILE lo_ptr IS BOUND AND lo_ptr NE nil
AND lo_ptr->car->type EQ lo_ref->type.

CASE lo_ref->type.
WHEN lcl_lisp=>type_number.
IF lo_ref->number = lo_ptr->car->number.
result = lo_ptr.
RETURN.
ENDIF.

WHEN lcl_lisp=>type_symbol OR lcl_lisp=>type_string.
IF lo_ref->value = lo_ptr->car->value.
result = lo_ptr.
RETURN.
ENDIF.

WHEN OTHERS.
IF lo_ref = lo_ptr->car.
result = lo_ptr.
RETURN.
ENDIF.
ENDCASE.

lo_ptr = lo_ptr->cdr.
ENDWHILE.
ENDMETHOD.

METHOD proc_memv.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_ref TYPE REF TO lcl_lisp.
validate: list, list->car.

result = false.
lo_ref = list->car.
CHECK list->cdr IS BOUND.
lo_ptr = list->cdr->car.
WHILE lo_ptr IS BOUND AND lo_ptr NE nil.
IF proc_equivalence( a = lo_ptr->car
b = lo_ref ) NE false.
result = lo_ptr.
RETURN.
ENDIF.
lo_ptr = lo_ptr->cdr.
ENDWHILE.
ENDMETHOD.

METHOD proc_member.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_ref TYPE REF TO lcl_lisp.
validate: list, list->car.

result = false.
lo_ref = list->car.
CHECK list->cdr IS BOUND.
lo_ptr = list->cdr->car.
WHILE lo_ptr IS BOUND AND lo_ptr NE nil.
IF proc_compare( a = lo_ptr->car
b = lo_ref ) NE false.
result = lo_ptr.
RETURN.
ENDIF.
lo_ptr = lo_ptr->cdr.
ENDWHILE.
ENDMETHOD.

METHOD proc_assq.
throw( |In implementation| ).
validate: list, list->car, list->cdr.
ENDMETHOD.

METHOD proc_assv.
throw( |In implementation| ).
validate: list, list->car, list->cdr.
ENDMETHOD.

METHOD proc_assoc.
throw( |In implementation| ).
validate: list, list->car, list->cdr.
ENDMETHOD.

**********************************************************************

DATA iter TYPE REF TO lcl_lisp_iterator.
DATA cell TYPE REF TO lcl_lisp.

iter = lcl_lisp_iterator=>new( list ).
result = lcl_lisp=>new_number( 0 ).

WHILE iter->has_next( ) EQ abap_true.
cell = iter->next( ).
validate_number cell '[+]'.
ENDWHILE.

METHOD proc_subtract.
DATA iter TYPE REF TO lcl_lisp_iterator.
DATA cell TYPE REF TO lcl_lisp.

iter = lcl_lisp_iterator=>new( list ).

cell = iter->next( ).
validate cell.
result = lcl_lisp=>new_number( cell->number ).

IF iter->has_next( ) EQ abap_false.
result->number = 0 - result->number.
ELSE.
*        Subtract all consecutive numbers from the first
WHILE iter->has_next( ) EQ abap_true.
cell = iter->next( ).
validate_number cell '[-]'.
result->number = result->number - cell->number.
ENDWHILE.
ENDIF.
ENDMETHOD.                    "proc_subtract

METHOD proc_multiply.
DATA iter TYPE REF TO lcl_lisp_iterator.
DATA cell TYPE REF TO lcl_lisp.

iter = lcl_lisp_iterator=>new( list ).
cell = iter->next( ).
validate cell.
result = lcl_lisp=>new_number( cell->number ).

WHILE iter->has_next( ) EQ abap_true.
cell = iter->next( ).
validate_number cell '[*]'.
result->number = result->number * cell->number.
ENDWHILE.
ENDMETHOD.                    "proc_multiply

METHOD proc_divide.
DATA iter TYPE REF TO lcl_lisp_iterator.
DATA cell TYPE REF TO lcl_lisp.

iter = lcl_lisp_iterator=>new( list ).
cell = iter->next( ).
validate cell.
result = lcl_lisp=>new_number( cell->number ).

TRY.
IF iter->has_next( ) EQ abap_false.
result->number = 1 / result->number.
ELSE.
WHILE iter->has_next( ) EQ abap_true.
cell = iter->next( ).
validate_number cell '[/]'.
result->number = result->number / cell->number.
ENDWHILE.
ENDIF.
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_divide

**********************************************************************
METHOD proc_gt.
_comparison <= '[>]'.
ENDMETHOD.                    "proc_gt

METHOD proc_gte.
_comparison < '[>=]'.
ENDMETHOD.                    "proc_gte

METHOD proc_lt.
_comparison >= '[<]'.
ENDMETHOD.                    "proc_lt

METHOD proc_lte.
_comparison > '[<=]'.
ENDMETHOD.                    "proc_lte

METHOD proc_is_zero.
_sign 0 '[zero?]'.
ENDMETHOD.                    "proc_gt

METHOD proc_is_positive.
_sign 1 '[positive?]'.
ENDMETHOD.                    "proc_gte

METHOD proc_is_negative.
_sign -1 '[negative?]'.
ENDMETHOD.                    "proc_lt

METHOD proc_is_odd.
result = false.
validate: list, list->car.
validate_integer list->car '[odd?]'.
CHECK list->car->number mod 2 NE 0.
result = true.
ENDMETHOD.                    "proc_lte

METHOD proc_is_even.
result = false.
validate: list, list->car.
validate_integer list->car '[even?]'.
CHECK list->car->number mod 2 EQ 0.
result = true.
ENDMETHOD.                    "proc_lte

**********************************************************************
METHOD proc_eql.
DATA lo_ptr TYPE REF TO lcl_lisp.

validate: list, list->car, list->cdr.

result = nil.
lo_ptr = list.
WHILE lo_ptr->cdr NE nil.
validate_number: lo_ptr->car '[=]',
lo_ptr->cdr->car '[=]'.
IF lo_ptr->car->number = lo_ptr->cdr->car->number.
result = true.
ELSE.
result = false.
EXIT.
ENDIF.
lo_ptr = lo_ptr->cdr.
ENDWHILE.
ENDMETHOD.                    "proc_eql

METHOD proc_eq.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_ref TYPE REF TO lcl_lisp.

validate: list, list->car, list->cdr.

result = nil.
lo_ptr = list.
lo_ref = lo_ptr->car.
WHILE lo_ptr->cdr NE nil.
IF lo_ref->type NE lo_ptr->cdr->car->type.
result = false.
EXIT.
ENDIF.
CASE lo_ptr->car->type.
WHEN lcl_lisp=>type_number.
IF lo_ref->number = lo_ptr->cdr->car->number.
result = true.
ELSE.
result = false.
EXIT.
ENDIF.

WHEN lcl_lisp=>type_symbol OR lcl_lisp=>type_string.
IF lo_ref->value = lo_ptr->cdr->car->value.
result = true.
ELSE.
result = false.
EXIT.
ENDIF.
WHEN OTHERS.
IF lo_ref = lo_ptr->cdr->car.
result = true.
ELSE.
result = false.
EXIT.
ENDIF.
ENDCASE.

lo_ptr = lo_ptr->cdr.
ENDWHILE.
ENDMETHOD.                    "proc_eq

METHOD proc_equivalence.
validate: a, b.

result = false.

IF ( a EQ true AND b EQ true )
OR ( a EQ false AND b EQ false )
OR ( a EQ nil AND b EQ nil ).
result = true.
RETURN.
ENDIF.

CHECK a->type EQ b->type.

CASE a->type.
WHEN lcl_lisp=>type_number.
CHECK a->number = b->number.
WHEN lcl_lisp=>type_symbol OR lcl_lisp=>type_string.
CHECK a->value = b->value.
WHEN lcl_lisp=>type_conscell OR lcl_lisp=>type_lambda.
CHECK a->car EQ b->car AND a->cdr EQ b->cdr.
WHEN OTHERS.
CHECK a = b.
ENDCASE.
result = true.
ENDMETHOD.

METHOD proc_compare.
validate: a, b.

result = false.
CHECK a->type EQ b->type.

CASE a->type.
WHEN lcl_lisp=>type_number.
CHECK a->number = b->number.
WHEN lcl_lisp=>type_symbol OR lcl_lisp=>type_string.
CHECK a->value = b->value.
WHEN lcl_lisp=>type_conscell OR lcl_lisp=>type_lambda.
CHECK proc_compare( a = a->car
b = b->car ) NE false
AND proc_compare( a = a->cdr
b = b->cdr ) NE false.
WHEN OTHERS.
CHECK a = b.
ENDCASE.
result = true.
ENDMETHOD.

METHOD proc_equal.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_next TYPE REF TO lcl_lisp.

validate: list, list->car.
result = false.
lo_ptr = list.

WHILE lo_ptr->cdr NE nil.
lo_next = lo_ptr->cdr->car.

result = proc_compare( a = lo_next
b = lo_ptr->car ).
IF result EQ false.
EXIT.
ENDIF.
lo_ptr = lo_ptr->cdr.
ENDWHILE.

ENDMETHOD.                    "proc_equal

METHOD proc_eqv.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA lo_next TYPE REF TO lcl_lisp.

validate: list, list->car.
result = false.

lo_ptr = list.
WHILE lo_ptr->cdr NE nil.
lo_next = lo_ptr->cdr->car.

result = proc_equivalence( a = lo_next
b = lo_ptr->car ).
IF result EQ false.
EXIT.
ENDIF.
lo_ptr = lo_ptr->cdr.
ENDWHILE.

ENDMETHOD.

*--------------------------------------------------------------------*
*    Hash-related functions
METHOD proc_make_hash.
result = lcl_lisp_hash=>new_hash( list ).
ENDMETHOD.                    "proc_make_hash

*    Get an element from a hash
METHOD proc_hash_get.
result = lcl_lisp_hash=>from_list( list = list
msg = 'HASH-GET' )->get( list->cdr ).
ENDMETHOD.                    "proc_hash_get

*    Insert an element into a hash
METHOD proc_hash_insert.
result = lcl_lisp_hash=>from_list( list = list
msg = 'HASH-INSERT' )->insert( list->cdr ).
ENDMETHOD.                    "proc_hash_insert

*    Remove an element from a hash
METHOD proc_hash_remove.
result = lcl_lisp_hash=>from_list( list = list
msg = 'HASH-REMOVE' )->delete( list->cdr ).
ENDMETHOD.                    "proc_hash_delete

*    Return the keys of a hash
METHOD proc_hash_keys.
result = lcl_lisp_hash=>from_list( list = list
msg = 'HASH-KEYS' )->get_hash_keys( ).
ENDMETHOD.                    "proc_hash_keys

METHOD proc_is_string.
_is_type string.
ENDMETHOD.                    "proc_is_string

METHOD proc_is_hash.
_is_type hash.
ENDMETHOD.                    "proc_is_hash

METHOD proc_is_number.
_is_type number.
ENDMETHOD.                    "proc_is_number

METHOD proc_is_symbol.
_is_type symbol.
ENDMETHOD.

METHOD proc_is_list.
DATA lo_ptr TYPE REF TO lcl_lisp.

result = false.
CHECK list IS BOUND.

lo_ptr = list->car.
WHILE lo_ptr->cdr IS BOUND AND lo_ptr->cdr NE nil.
lo_ptr = lo_ptr->cdr.
ENDWHILE.
IF list EQ nil OR lo_ptr EQ NIL.
result = true.
RETURN.
ENDIF.
IF lo_ptr IS BOUND AND lo_ptr->cdr EQ nil
AND lo_ptr->type = lcl_lisp=>type_conscell.
result = true.
ENDIF.
ENDMETHOD.                    "proc_is_list

METHOD proc_is_procedure.
result = false.
check list is bound        " paramater (car) must not be valid
and list->car is bound.  " Body
CASE list->car->type.
WHEN lcl_lisp=>type_lambda
OR lcl_lisp=>type_native.
result = true.
endcase.
ENDMETHOD.

METHOD proc_is_alist.
result = proc_is_list( list ).
throw( |Not supported yet ALIST?| ).
ENDMETHOD.                    "proc_is_alist

METHOD proc_is_type.
throw( |Not supported yet IS_TYPE?| ).
ENDMETHOD.                    "proc_is_type

METHOD proc_abs.
_math abs '[abs]'.
ENDMETHOD.                    "proc_abs

METHOD proc_sin.
_trigonometric sin '[sin]'.
ENDMETHOD.                    "proc_sin

METHOD proc_cos.
_trigonometric cos '[cos]'.
ENDMETHOD.                    "proc_cos

METHOD proc_tan.
_trigonometric tan '[tan]'.
ENDMETHOD.                    "proc_tan

METHOD proc_asin.
_trigonometric asin '[asin]'.
ENDMETHOD.                    "proc_asin

METHOD proc_acos.
_trigonometric acos '[acos]'.
ENDMETHOD.                    "proc_acos

METHOD proc_atan.
_trigonometric atan '[atan]'.
ENDMETHOD.                    "proc_atan

METHOD proc_sinh.
_trigonometric sinh '[sinh]'.
ENDMETHOD.                    "proc_sinh

METHOD proc_cosh.
_trigonometric cosh '[acosh]'.
ENDMETHOD.                    "proc_cosh

METHOD proc_tanh.
_trigonometric tanh '[atanh]'.
ENDMETHOD.                    "proc_tanh

METHOD proc_asinh.
DATA carry TYPE f.

result = nil.
validate: list, list->car.
validate_number list->car '[asinh]'.
_is_last_param list.
TRY.
carry = list->car->number.
result = lcl_lisp=>new_number( log( carry + sqrt( carry ** 2 + 1 ) ) ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_asinh

METHOD proc_acosh.
DATA carry TYPE f.

result = nil.
validate: list, list->car.
validate_number list->car '[acosh]'.
_is_last_param list.
TRY.
carry = list->car->number.
result = lcl_lisp=>new_number( log( carry + sqrt( carry ** 2 - 1 ) ) ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_acosh

METHOD proc_atanh.
DATA carry TYPE f.

result = nil.
validate: list, list->car.
validate_number list->car '[atanh]'.
_is_last_param list.
TRY.
carry = list->car->number.
result = lcl_lisp=>new_number( ( log( 1 + carry ) - log( 1 - carry ) ) / 2 ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_atanh

METHOD proc_expt.
result = nil.
validate: list, list->car, list->cdr.
validate_number: list->car '[expt]',
list->cdr->car '[expt]'.
_is_last_param list->cdr.
TRY.
result = lcl_lisp=>new_number( list->car->number ** list->cdr->car->number ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_expt

METHOD proc_exp.
_math exp '[exp]'.
ENDMETHOD.                    "proc_exp

METHOD proc_log.
_math log '[log]'.
ENDMETHOD.                    "proc_log

METHOD proc_sqrt.
_math sqrt '[sqrt]'.
ENDMETHOD.                    "proc_sqrt

METHOD proc_floor.
_math floor '[floor]'.
ENDMETHOD.                    "proc_floor

METHOD proc_ceiling.
_math ceil '[ceil]'.
ENDMETHOD.                    "proc_ceiling

METHOD proc_truncate.
_math trunc '[truncate]'.
ENDMETHOD.                    "proc_truncate

METHOD proc_round.
result = nil.
validate: list, list->car.
validate_number list->car '[round]'.
_is_last_param list.
TRY.
result = lcl_lisp=>new_number( round( val = list->car->number dec = 0 ) ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_round

METHOD proc_remainder.
result = nil.
validate: list, list->car, list->cdr.
validate_number: list->car '[remainder]',
list->cdr->car '[remainder]'.
_is_last_param list->cdr.
TRY.
result = lcl_lisp=>new_number( list->car->number -
list->cdr->car->number * trunc( list->car->number / list->cdr->car->number ) ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_remainder

METHOD proc_modulo.
result = nil.
validate: list, list->car, list->cdr.
validate_number: list->car '[modulo]',
list->cdr->car '[modulo]'.
_is_last_param list->cdr.
TRY.
result = lcl_lisp=>new_number( list->car->number MOD list->cdr->car->number ).
IF sign( list->cdr->car->number ) LE 0.
result->number = result->number + list->cdr->car->number.
ENDIF.
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_modulo

METHOD proc_quotient.
result = nil.
validate: list, list->car, list->cdr.
validate_number: list->car '[quotient]',
list->cdr->car '[quotient]'.
_is_last_param list->cdr.
TRY.
result = lcl_lisp=>new_number( list->car->number DIV list->cdr->car->number ).
_catch_arithmetic_error.
ENDTRY.
ENDMETHOD.                    "proc_quotient

**********************************************************************
*       _                   _           _ _ _        _
*  __ _| |__   __ _ _ __   | |__  _   _(_) | |_     (_)_ __  ___
* / _` | '_ \ / _` | '_ \  | '_ \| | | | | | __|____| | '_ \/ __|
*| (_| | |_) | (_| | |_) | | |_) | |_| | | | ||_____| | | | \__ \
* \__,_|_.__/ \__,_| .__/  |_.__/ \__,_|_|_|\__|    |_|_| |_|___/
*                  |_|
**********************************************************************

METHOD proc_abap_data.
validate: list, list->car.

IF list->car = nil OR ( list->car->type NE lcl_lisp=>type_string
AND list->car->type NE lcl_lisp=>type_symbol ).
throw( |AB-DATA: String or symbol required as name of type| ).
ENDIF.

DATA lr_desc TYPE REF TO cl_abap_typedescr.
cl_abap_typedescr=>describe_by_name( EXPORTING p_name = list->car->value

RECEIVING p_descr_ref = lr_desc
EXCEPTIONS OTHERS = 1 ).
IF sy-subrc NE 0. "DESCRIBE_BY_NAME has only one exception
ENDIF.

CASE lr_desc->kind.
WHEN cl_abap_typedescr=>kind_table.
result = lcl_lisp=>new_table( ).
WHEN cl_abap_typedescr=>kind_elem OR cl_abap_typedescr=>kind_struct.
result = lcl_lisp=>new_data( ).
WHEN OTHERS.
throw( |AB-DATA: Type kind { lr_desc->kind } not supported yet| ).
ENDCASE.
*      Create data as given type
CREATE DATA result->data TYPE (list->car->value).
*      Set value if supplied as second parameter
IF list->cdr NE nil.
element_to_data(
EXPORTING
element = list->cdr->car
CHANGING
data    = result->data ).
ENDIF.
ENDMETHOD.                    "proc_abap_data

**********************************************************************
METHOD proc_abap_function.
result = lcl_lisp_abapfunction=>new_function( list ).
ENDMETHOD.                    "proc_abap_function

METHOD proc_abap_table. "Create a table data
validate: list, list->car.
*      First input: name of data type, second input: value
result = lcl_lisp=>new_table( ).
CREATE DATA result->data TYPE TABLE OF (list->car->value).
*      Set value if supplied as second parameter
IF list->cdr NE nil.
element_to_data( EXPORTING element = list->cdr->car
CHANGING data    = result->data ).
ENDIF.
ENDMETHOD.                    "proc_abap_table

**********************************************************************
METHOD proc_abap_append_row.
ENDMETHOD.                    "proc_abap_append_row

METHOD proc_abap_delete_row.
ENDMETHOD.                    "proc_abap_delete_row

METHOD proc_abap_get_row.
ENDMETHOD.                    "proc_abap_get_row

**********************************************************************
METHOD proc_abap_get_value. "Convert ABAP to Lisp data
DATA lx_root TYPE REF TO cx_root.
DATA lo_ptr TYPE REF TO lcl_lisp.
FIELD-SYMBOLS <data> TYPE any.

validate: list, list->car.
lo_ptr = list->car.
IF lo_ptr->type NE lcl_lisp=>type_abap_data AND
lo_ptr->type NE lcl_lisp=>type_abap_table.
throw( |AB-GET-VALUE requires ABAP data or table as parameter| ).
ENDIF.
TRY.
ASSIGN lo_ptr->data->* TO <data>.
result = data_to_element( <data> ).
CATCH cx_root INTO lx_root.
throw( |Mapping error: { lx_root->get_text( ) }| ).
ENDTRY.
ENDMETHOD.                    "proc_abap_get_value

METHOD proc_abap_set_value. "Convert Lisp to ABAP data
DATA lx_root TYPE REF TO cx_root.
FIELD-SYMBOLS <data> TYPE any.

validate: list, list->car.
IF list->car->type NE lcl_lisp=>type_abap_data AND
list->car->type NE lcl_lisp=>type_abap_table.
throw( |AB-SET-VALUE requires ABAP data or table as first parameter| ).
ENDIF.
TRY.
ASSIGN list->car->data->* TO <data>.
element_to_data(
EXPORTING
element = list->cdr->car
CHANGING
data    = <data> ).
CATCH cx_root INTO lx_root.
throw( |Mapping error: { lx_root->get_text( ) }| ).
ENDTRY.
result = nil. "TODO: What should we return here?
ENDMETHOD.                    "proc_abap_set_value

**********************************************************************
METHOD proc_abap_function_call. "Called internally only for execution of function module
DATA lo_func TYPE REF TO lcl_lisp_abapfunction.
DATA lx_root TYPE REF TO cx_root.

validate: list, list->car.
*      The first parameter must be a function module instance
IF list->car->type NE lcl_lisp=>type_abap_function.
throw( |{ list->car->value } is not a function module reference| ).
ENDIF.

TRY.
lo_func ?= list->car.
result = lo_func->call( list->car ).
CATCH cx_root INTO lx_root.
throw( |Function call error: { lx_root->get_text( ) }| ).
ENDTRY.
ENDMETHOD.                    "proc_abap_function_call

METHOD create_element_from_data.
DATA lo_ddesc TYPE REF TO cl_abap_typedescr.

*      Perform RTTI on determined data and generate appropriate response
lo_ddesc = cl_abap_typedescr=>describe_by_data_ref( ir_data ).
CASE lo_ddesc->kind.
WHEN cl_abap_typedescr=>kind_table.
result = lcl_lisp=>new_table( ir_data ).
WHEN cl_abap_typedescr=>kind_struct.
result = lcl_lisp=>new_data( ir_data ).
WHEN cl_abap_typedescr=>kind_elem.
*          Give back immediate value
FIELD-SYMBOLS <value> TYPE any.

ASSIGN ir_data->* TO <value>.
result = data_to_element( <value> ).
WHEN OTHERS.
throw( |AB-GET: Type kind { lo_ddesc->kind } not supported yet| ). "Can do AB-TAB-WHERE some other time
ENDCASE.
ENDMETHOD.                    "create_element_from_data

METHOD proc_abap_get.
DATA lr_data TYPE REF TO data.

*      Ensure a valid first parameter is passed
IF list->car->type NE lcl_lisp=>type_abap_data
AND list->car->type NE lcl_lisp=>type_abap_function
AND list->car->type NE lcl_lisp=>type_abap_table.
throw( |AB-GET: First parameter must be ABAP data or table or a function| ).
ENDIF.

*      Determine whether the data is elementary or not to decide if we need to get the element by identifier
IF list->car->data IS NOT INITIAL AND
cl_abap_typedescr=>describe_by_data_ref( list->car->data )->kind = cl_abap_typedescr=>kind_elem.
*        Elementary type; can return the value without mapping
lr_data = list->car->data.
ELSE.
*        Could short-cut here and provide the value right away
IF list->cdr = nil.
throw( |AB-GET: Complex type requires identifier for lookup| ).
ELSE.
lr_data = get_element( list ).
ENDIF.
ENDIF.

result = create_element_from_data( lr_data ).

ENDMETHOD. "proc_abap_get

METHOD proc_abap_set.
DATA lr_target TYPE REF TO data.              " Target data
DATA lo_source TYPE REF TO lcl_lisp.          " Source element
DATA lo_ddesc TYPE REF TO cl_abap_typedescr.
FIELD-SYMBOLS <target> TYPE any.
FIELD-SYMBOLS <source> TYPE any.

*      Ensure a valid first parameter is passed
IF list->car->type NE lcl_lisp=>type_abap_data
AND list->car->type NE lcl_lisp=>type_abap_function
AND list->car->type NE lcl_lisp=>type_abap_table.
throw( |AB-SET: First parameter must be ABAP data or table or a function| ).
ENDIF.

*      Determine whether the data is elementary or not to decide if we need to get the element by identifier
IF list->car->data IS NOT INITIAL AND cl_abap_typedescr=>describe_by_data_ref( list->car->data )->kind = cl_abap_typedescr=>kind_elem.
*        Elementary type; can return the value without mapping
lr_target = list->car->data.
lo_source = list->cdr->car.
*        lo_sdata = list->cdr->car->data. "Value to set is second argument
ELSEIF list->cdr = nil.
throw( |AB-SET: Complex type requires identifier for lookup| ).
ELSE.
lr_target = get_element( list ).
*       lr_sdata = list->cdr->cdr->car->data. "Value to set is third argument
lo_source = list->cdr->cdr->car.
ENDIF.

* Do we just assign the reference now? Probably should dereference source value
* and copy the value...
*      Perform RTTI on determined data and generate appropriate response
ASSIGN lr_target->* TO <target>.

*      For elementary types, set value from second parameter, otherwise third
IF cl_abap_typedescr=>describe_by_data( <target> )->kind = cl_abap_typedescr=>kind_elem.
*        For now, we will support setting data from a number, string or symbol
CASE lo_source->type.
WHEN lcl_lisp=>type_string OR lcl_lisp=>type_symbol.
<target> = lo_source->value.
WHEN lcl_lisp=>type_number.
<target> = lo_source->number.
ENDCASE.
ELSE.
*        Complex types will just copy the whole value across
ASSIGN lo_source->data->* TO <source>.
<target> = <source>.                        "Set the value
ENDIF.

result = nil.

ENDMETHOD. "proc_abap_set

METHOD structure_to_element.
DATA lo_conscell TYPE REF TO lcl_lisp. " Lisp-side (target)
FIELD-SYMBOLS <field> TYPE any.

lo_conscell = element = lcl_lisp=>new_cons( ).
DO.
ASSIGN COMPONENT sy-index OF STRUCTURE struct TO <field>.
IF sy-subrc NE 0.
lo_conscell->cdr = nil. "Terminate list
EXIT.
ENDIF.
IF sy-index > 1.          "Move pointer only from second field onward
lo_conscell = lo_conscell->cdr = lcl_lisp=>new_cons( ).
ENDIF.
lo_conscell->car = data_to_element( <field> ).
ENDDO.
ENDMETHOD.                    "structure_to_element

METHOD data_to_element.
*      Map ABAP Data to Lisp element
DATA lr_ddesc TYPE REF TO cl_abap_typedescr.   " RTTI
FIELD-SYMBOLS <table> TYPE ANY TABLE.          " ABAP-side (source)
DATA line TYPE REF TO data.

*      Determine type of the ABAP value
lr_ddesc = cl_abap_typedescr=>describe_by_data( data ).
CASE lr_ddesc->kind.

WHEN cl_abap_typedescr=>kind_table.
*          Table type
FIELD-SYMBOLS <line> TYPE any.

ASSIGN data TO <table>.
CREATE DATA line LIKE LINE OF <table>.
ASSIGN line->* TO <line>.

IF <table> IS INITIAL.
element = nil.
ELSE.
DATA lo_conscell TYPE REF TO lcl_lisp. " Lisp-side  (target)

*            Create list with cell for each row AND Set pointer to start of list
lo_conscell = element = lcl_lisp=>new_cons( ).
LOOP AT <table> INTO <line>.
IF sy-tabix > 1.          "Move pointer only from second line onward
lo_conscell = lo_conscell->cdr = lcl_lisp=>new_cons( ).
ENDIF.
lo_conscell->car = data_to_element( <line> ).
ENDLOOP.
lo_conscell->cdr = nil.     "Terminate list
ENDIF.

WHEN cl_abap_typedescr=>kind_struct.
element = structure_to_element( data ).

WHEN cl_abap_typedescr=>kind_elem.
*          Elementary type
IF lr_ddesc->type_kind = cl_abap_typedescr=>typekind_numeric OR
lr_ddesc->type_kind = cl_abap_typedescr=>typekind_num.
element = lcl_lisp=>new_number( data ).
ELSE.
element = lcl_lisp=>new_string( data ).
ENDIF.
ENDCASE.
ENDMETHOD.                    "data_to_element

*    Map Lisp element to ABAP Data
METHOD element_to_data.
*      RTTI-relevant:
DATA lr_ddesc TYPE REF TO cl_abap_typedescr.
DATA lr_tdesc TYPE REF TO cl_abap_tabledescr.
*      ABAP-side (target) mapping:
FIELD-SYMBOLS <field> TYPE any.
FIELD-SYMBOLS <line> TYPE any.
FIELD-SYMBOLS <table> TYPE ANY TABLE.
FIELD-SYMBOLS <sotab> TYPE SORTED TABLE.
FIELD-SYMBOLS <sttab> TYPE STANDARD TABLE.
"       DATA field TYPE REF TO data.
DATA line TYPE REF TO data.
DATA table TYPE REF TO data.
*      Lisp-side (source) mapping:
DATA lr_conscell TYPE REF TO lcl_lisp.

*      Determine type of the ABAP value
lr_ddesc = cl_abap_typedescr=>describe_by_data( data ).
CASE lr_ddesc->kind.
*        Table type
WHEN cl_abap_typedescr=>kind_table.
*          For this mapping to happen, the element must be a cons cell
IF element->type NE lcl_lisp=>type_conscell.
throw( |Mapping failed: Non-cell to table| ).
ENDIF.
*          Provide reference to table and line
lr_tdesc ?= lr_ddesc.
GET REFERENCE OF data INTO table.
ASSIGN table->* TO <table>.
IF lr_tdesc->table_kind = cl_abap_tabledescr=>tablekind_sorted OR
lr_tdesc->table_kind = cl_abap_tabledescr=>tablekind_hashed.
ASSIGN table->* TO <sotab>. "Sorted table type
CREATE DATA line LIKE LINE OF <sotab>.
ELSE.
ASSIGN table->* TO <sttab>. "Standard table type
CREATE DATA line LIKE LINE OF <sttab>.
ENDIF.
ASSIGN line->* TO <line>.

lr_conscell = element. "Set pointer to start of list
DO.
element_to_data( EXPORTING element = lr_conscell->car
CHANGING data    = <line> ).
*            Append or insert, depending on table type (what is assigned)
IF <sotab> IS ASSIGNED.
INSERT <line> INTO TABLE <sotab>.
ELSE.
APPEND <line> TO <sttab>.
ENDIF.
CLEAR <line>.
lr_conscell = lr_conscell->cdr.
IF lr_conscell = nil.
EXIT.
ENDIF.
ENDDO.

WHEN cl_abap_typedescr=>kind_struct.
*          Structure
IF element->type NE lcl_lisp=>type_conscell.
throw( |Mapping failed: Non-cell to structure| ).
ENDIF.

lr_conscell = element. "Set pointer to start of list
ASSIGN data TO <line>.
DO.
ASSIGN COMPONENT sy-index OF STRUCTURE <line> TO <field>.
IF sy-subrc NE 0.
EXIT.
ENDIF.

IF sy-index > 1. "Move cons cell pointer only from second element on
lr_conscell = lr_conscell->cdr.
ENDIF.
*            Don't map nil values
CHECK lr_conscell->car NE nil.

element_to_data( EXPORTING element = lr_conscell->car
CHANGING data    = <field> ).
ENDDO.

WHEN cl_abap_typedescr=>kind_elem.
*          Elementary type
ASSIGN data TO <field>.
IF element->type = lcl_lisp=>type_number.
<field> = element->number.
ELSE.
<field> = element->value.
ENDIF.

WHEN OTHERS.
*          Not supported yet
throw( |Mapping failed: unsupported type| ).
ENDCASE.
ENDMETHOD.                    "element_to_data

METHOD get_structure_field.
FIELD-SYMBOLS <value> TYPE any.
FIELD-SYMBOLS <struct> TYPE any.

IF identifier = nil OR
( identifier->type NE lcl_lisp=>type_string AND identifier->type NE lcl_lisp=>type_symbol ).
throw( `AB-GET: String or symbol required to access structure field` ).
ENDIF.

ASSIGN element->data->* TO <struct>.
ASSIGN COMPONENT identifier->value OF STRUCTURE <struct> TO <value>.
IF sy-subrc NE 0.
throw( |AB-GET: Structure has no component { identifier->value }| ).
ENDIF.
GET REFERENCE OF <value> INTO rdata.
ENDMETHOD.                    "get_structure_field

METHOD get_index_table_row.
*      Second input for reading an index table must be a number (row index)
FIELD-SYMBOLS <idxtab> TYPE INDEX TABLE.

IF identifier = nil OR identifier->type NE lcl_lisp=>type_number.
throw( |AB-GET: Numeric index required to read index table| ). "Can do AB-TAB-WHERE some other time
ENDIF.
ASSIGN element->data->* TO <idxtab>.
READ TABLE <idxtab> REFERENCE INTO rdata INDEX identifier->number.
CHECK sy-subrc NE 0.
throw( |AB-GET: No entry at index { identifier->number }| ). "Can do AB-TAB-WHERE some other time
ENDMETHOD.                    "get_index_table_row

METHOD get_table_row_with_key.
"" IMPORTING element    TYPE REF TO lcl_lisp
*          TODO: Read with key, which is a bit more effort
rdata = get_index_table_row( element = element
identifier = identifier ).
ENDMETHOD.                    "get_table_row_with_key

METHOD get_element.
*     RDATA <- Data reference to value pointed to
DATA element TYPE REF TO lcl_lisp.
DATA identifier TYPE REF TO lcl_lisp.
*    ELEMENT -> Lisp element containing an ABAP value (data, table or function)
*    IDENTIFIER -> Lisp element, string or symbol or index, to identify subcomponent of value
element = list->car.
identifier = list->cdr->car.

IF element->type = lcl_lisp=>type_abap_function.
*        Get function parameter by name
DATA lo_func TYPE REF TO lcl_lisp_abapfunction.

lo_func ?= element.
rdata = lo_func->get_function_parameter( identifier ).
ELSE.
DATA lo_ddesc TYPE REF TO cl_abap_typedescr.
DATA lo_tdesc TYPE REF TO cl_abap_tabledescr.

*        First parameter is not function, but table or other data; examine the data
lo_ddesc = cl_abap_typedescr=>describe_by_data_ref( element->data ).

CASE lo_ddesc->kind.
WHEN cl_abap_typedescr=>kind_struct.
*            Structure: Use second parameter as field name
rdata = get_structure_field( element = element
identifier = identifier ).
WHEN cl_abap_typedescr=>kind_elem.
*            Elementary data: No qualifier / second parameter required
rdata = element->data.

WHEN cl_abap_typedescr=>kind_table.
*            Table: Second parameter is index (std table) or key (sorted table)
lo_tdesc ?= lo_ddesc.

CASE lo_tdesc->table_kind.
WHEN cl_abap_tabledescr=>tablekind_sorted
OR cl_abap_tabledescr=>tablekind_hashed.
rdata = get_table_row_with_key( element = element
identifier = identifier ).

WHEN cl_abap_tabledescr=>tablekind_std.
"OR cl_abap_tabledescr=>tablekind_index.  - No Test data for this case yet
rdata = get_index_table_row( element = element
identifier = identifier ).
ENDCASE.

ENDCASE.

ENDIF.
ENDMETHOD. "get_element

ENDCLASS.                    "lcl_lisp_interpreter IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_abapfunction IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp_abapfunction IMPLEMENTATION.

*      Determine the parameters of the function module to populate parameter table
*  TODO: At the moment, we do not support reference types in function module interfaces
function_name = iv_name.          "Name of function module
parameters_generated = abap_false.

*      Read the function module interface
CALL FUNCTION 'FUNCTION_IMPORT_INTERFACE'
EXPORTING
funcname           = function_name  " Name of the function module
with_enhancements  = 'X'            " X = Enhancement Parameters Will Be Provided
*          ignore_switches    = SPACE           " X = Switches Are Ignored
IMPORTING
REMOTE_CALL        = interface-REMOTE_CALL
TABLES
exception_list     = interface-exc
export_parameter   = interface-exp
import_parameter   = interface-imp
changing_parameter = interface-cha
tables_parameter   = interface-tbl
ENHA_EXP_PARAMETER = interface-enh_exp
ENHA_IMP_PARAMETER = interface-enh_imp
ENHA_CHA_PARAMETER = interface-enh_cha
ENHA_TBL_PARAMETER = interface-enh_tbl
EXCEPTIONS
error_message      = 1
function_not_found = 2
invalid_name       = 3
OTHERS             = 4.
IF sy-subrc <> 0.
throw( |Function { function_name }: { error_message( ) }| ).
ENDIF.

METHOD new_function.
validate: list, list->car.

ro_func ?= new( type_abap_function ).
*      Determine the parameters of the function module to populate parameter table
*(let (( profiles
*        (let ( (f3 (ab-function "BAPI_USER_GET_DETAIL"))  )
*        ( begin (ab-set f3 "USERNAME" (ab-get ab-sy "UNAME") )
*                  (f3) (ab-get f3 "PROFILES")  ) )
*        ) )
*   (let ((profile (ab-get profiles 1)) )
*             (ab-get profile "BAPIPROF" )  )
ENDMETHOD.                    "new_function
*(define bapi-userdetail (ab-function "BAPI_USER_GET_DETAIL"))  ;; Assign interface of BAPI_USER_GET_DETAIL to a symbol
*(ab-set bapi-userdetail "USERNAME" (ab-get ab-sy "UNAME"))     ;; Set parameter "USERNAME" to current user

METHOD call.
DATA lv_message TYPE string.

create_parameters( list ).
*TODO: Map given list to parameters of function module
*      First parameter: Name of function to call;
*      second parameter: data to pass to interface
CALL FUNCTION list->value
PARAMETER-TABLE parameters
EXCEPTION-TABLE exceptions.

IF sy-subrc EQ c_error_message.
throw( |Call { list->value }: { error_message( ) }| ).
ENDIF.
*    Map output parameters to new list
ro_elem = list.      "Function reference is updated with values after call
ENDMETHOD.                    "call

METHOD error_message.
MESSAGE ID sy-msgid TYPE sy-msgty NUMBER sy-msgno    "#EC *
WITH sy-msgv1 sy-msgv2 sy-msgv3 sy-msgv4
INTO rv_message.
ENDMETHOD.

METHOD get_function_parameter.
*    Get function parameter by name
DATA ls_param TYPE abap_func_parmbind.

*    IDENTIFIER -> Lisp element, string or symbol or index, to identify subcomponent of value
IF identifier = nil OR
( identifier->type NE lcl_lisp=>type_string AND identifier->type NE lcl_lisp=>type_symbol ).
throw( `AB-GET: String or symbol required to access function parameter` ).
ENDIF.

create_parameters( nil ).

READ TABLE parameters INTO ls_param WITH KEY name = identifier->value.
IF sy-subrc NE 0.
throw( |AB-GET: No parameter { identifier->value } in function| ).
ENDIF.
rdata = ls_param-value.
ENDMETHOD.                    "get_function_parameter

METHOD create_table_params.
*    Create structures in parameter - TABLES
DATA ls_table TYPE rstbl.
DATA ls_par TYPE abap_func_parmbind.
DATA lv_type TYPE RS38L_TYP.

ls_par-kind = abap_func_tables.
LOOP AT it_table INTO ls_table.

IF ls_table-typ IS INITIAL.
lv_type = ls_table-dbstruct.
ELSE.
lv_type = ls_table-typ.
ENDIF.
CREATE DATA ls_par-value TYPE TABLE OF (lv_type).
CREATE DATA ls_par-tables_wa TYPE (lv_type).

ls_par-name = ls_table-parameter.
INSERT ls_par INTO TABLE parameters.
ENDLOOP.
ENDMETHOD.

METHOD create_params.
DATA ls_params TYPE ts_params.
FIELD-SYMBOLS <row>   TYPE any.
DATA ls_par TYPE abap_func_parmbind.
DATA lv_type TYPE RS38L_TYP.

ls_par-kind = iv_kind.
LOOP AT it_table ASSIGNING <row>.
MOVE-CORRESPONDING <row> TO ls_params.

lv_type = 'TEXT100'.   "Fallback for untyped parameters
IF ls_params-dbfield IS NOT INITIAL.
lv_type = ls_params-dbfield.
ELSEIF ls_params-typ IS NOT INITIAL.
lv_type = ls_params-typ.
ENDIF.
CREATE DATA ls_par-value TYPE (lv_type).

ls_par-name = ls_params-parameter.
INSERT ls_par INTO TABLE parameters.
ENDLOOP.
ENDMETHOD.

METHOD create_parameters.
CHECK parameters_generated EQ abap_false.

create_exceptions( ).
*    Tables
create_table_params( interface-tbl ).         "    input TABLES parameter
create_table_params( interface-enh_tbl ).
*    Import
create_params( it_table = interface-imp
iv_kind = abap_func_exporting ).
create_params( it_table = interface-enh_imp
iv_kind = abap_func_exporting ).
*    Export
create_params( it_table = interface-exp
iv_kind = abap_func_importing ).
create_params( it_table = interface-enh_exp
iv_kind = abap_func_importing ).
*    Changing
create_params( it_table = interface-cha
iv_kind = abap_func_changing ).
create_params( it_table = interface-enh_cha
iv_kind = abap_func_changing ).

parameters_generated = abap_true.
ENDMETHOD.

METHOD create_exceptions.
DATA ls_exc TYPE abap_func_excpbind.

CLEAR exceptions.
ls_exc-name = 'OTHERS'.
ls_exc-value = 10.
INSERT ls_exc INTO TABLE exceptions.
ls_exc-name = 'error_message'.
ls_exc-value = c_error_message.
INSERT ls_exc INTO TABLE exceptions.
ENDMETHOD.

ENDCLASS.                    "lcl_lisp_abapfunction IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_environment IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp_environment IMPLEMENTATION.

METHOD new.
CREATE OBJECT ro_env.
ro_env->outer = io_outer.
ENDMETHOD.                    "new

METHOD unbound_symbol.
RAISE EXCEPTION TYPE lcx_lisp_eval_err
EXPORTING
message = |Symbol { symbol } is unbound|.
ENDMETHOD.                    "unbound_symbol

METHOD find.
*      find the environment where the symbol is defined
READ TABLE map TRANSPORTING NO FIELDS WITH KEY symbol = symbol.
IF sy-subrc EQ 0.
env = me.            " found in current environment
ELSEIF outer IS BOUND.
env = outer->find( symbol ).
ELSE.
unbound_symbol( symbol ).
ENDIF.
ENDMETHOD.                    "find

METHOD lookup.
*      Lookup a value in the environment
DATA ls_map TYPE ts_map.
READ TABLE map INTO ls_map             " Try locate the symbol
WITH KEY symbol = symbol.            " in current environment
IF sy-subrc = 0.
cell = ls_map-value.
ELSEIF outer IS BOUND.                 " or
cell = outer->lookup( symbol ).      " in the parent (outer) environment
ENDIF.
CHECK cell IS NOT BOUND.
unbound_symbol( symbol ).
ENDMETHOD.                    "find

METHOD define_value.
element = lcl_lisp=>new_elem( type = type
value = value ).
define( symbol = symbol
element = element ).
ENDMETHOD.                    "define_cell

METHOD define.
*      Add a value to the (local) environment
DATA ls_map TYPE ts_map.
ls_map-symbol = symbol.
ls_map-value = element.
INSERT ls_map INTO TABLE map.
IF sy-subrc = 4.                  " To comply with Scheme define,
MODIFY TABLE map FROM ls_map.   " overwrite existing defined values
ENDIF.
ENDMETHOD.                    "define

METHOD parameters_to_symbols.
*      The lambda receives its own local environment in which to execute,
*      where parameters become symbols that are mapped to the corresponding arguments
*      Assign each argument to its corresponding symbol in the newly created environment
DATA lo_par TYPE REF TO lcl_lisp. " Parameter
DATA lo_arg TYPE REF TO lcl_lisp. " Argument
DATA lv_count TYPE i.

lo_par = io_pars.                      " Pointer to formal parameters
lo_arg = io_args.                      " Pointer to arguments
WHILE lo_par NE lcl_lisp=>nil.         " Nil would mean no parameters to map
IF lo_arg = lcl_lisp=>nil.           " Premature end of arguments
lcl_lisp=>throw( |Missing parameter(s) { lo_par->to_string( ) }| ).
ENDIF.

*        NOTE: Each element of the argument list is evaluated before being defined in the environment
define( symbol = lo_par->car->value
element = lo_arg->car ).

lo_par = lo_par->cdr.
lo_arg = lo_arg->rest( ).
ENDWHILE.

IF lo_arg NE lcl_lisp=>nil.  " Excessive number of arguments
lcl_lisp=>throw( |Expected { lv_count } parameter(s), found { io_args->to_string( ) }| ).
ENDIF.
ENDMETHOD.                    "parameters_to_symbols

ENDCLASS.                    "lcl_lisp_environment IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_profiler DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_lisp_profiler DEFINITION INHERITING FROM lcl_lisp_interpreter.
PUBLIC SECTION.
METHODS eval_repl REDEFINITION.
ENDCLASS.                    "lcl_lisp_profiler DEFINITION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_profiler IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp_profiler IMPLEMENTATION.

METHOD eval_repl.
DATA lv_begin TYPE i.
DATA lv_end   TYPE i.

GET RUN TIME FIELD lv_begin.               " Start timer
response = super->eval_repl( code ).       " Evaluate given code
GET RUN TIME FIELD lv_end.                 " Stop time

runtime = lv_end - lv_begin.
ENDMETHOD.                    "eval_repl

ENDCLASS.                    "lcl_lisp_profiler IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp IMPLEMENTATION.

METHOD class_constructor.
nil  = lcl_lisp=>new_symbol( 'nil' ).
false  = lcl_lisp=>new_symbol( 'false' ).
true  = lcl_lisp=>new_symbol( 'true' ).
ENDMETHOD.                    "class_constructor

METHOD first.
IF car IS BOUND.
ro_car = car.
ELSE.
ro_car = nil.
ENDIF.
ENDMETHOD.                    "first

METHOD rest.
IF cdr IS BOUND.
ro_cdr = cdr.
ELSE.
ro_cdr = nil.
ENDIF.
ENDMETHOD.                    "rest

METHOD new.
CASE type.
WHEN type_hash.
CREATE OBJECT ro_elem TYPE lcl_lisp_hash.
WHEN type_abap_function.
CREATE OBJECT ro_elem TYPE lcl_lisp_abapfunction.
WHEN OTHERS.
CREATE OBJECT ro_elem TYPE lcl_lisp.
ENDCASE.
ro_elem->type = type.
ro_elem->car = io_car.
ro_elem->cdr = io_cdr.
ENDMETHOD.                    "new

METHOD new_elem.
CASE type.
WHEN type_number.
ro_elem = new( type ).
ro_elem->number = value.
*         WHEN type_abap_data OR type_abap_table.
*           ro_elem = new( type ).
*           ro_elem->data = ref.
WHEN OTHERS.
ro_elem = new( type ).
ro_elem->value = value.
ENDCASE.
ENDMETHOD.                    "new_elem

METHOD new_string.
ro_elem = new_elem( type = type_string
value = value ).
ENDMETHOD.                    "new_string

METHOD new_symbol.
ro_elem = new_elem( type = type_symbol
value = value ).
ENDMETHOD.                    "new_symbol

METHOD new_atom.
DATA lv_num TYPE decfloat34.
*      Check whether the token can be converted to a float, to cover all
*      manner of number formats, including scientific, otherwise treat it
*      as a symbol (but we still store it as a string to preserve the original value
*      and let the ABAP kernel do the heavy lifting later on)
TRY.
MOVE EXACT value TO lv_num  ##needed. "If this passes, it's a number
ro_elem = new_number( value ).
CATCH cx_sy_conversion_no_number.
ro_elem = new_symbol( value ).
ENDTRY.
ENDMETHOD.                    "new_atom

METHOD new_number.
ro_elem = new_elem( type = type_number
value = value ).
ENDMETHOD.                    "new_number

METHOD new_data.
ro_elem = new( type_abap_data ).
ro_elem->data = ref.
ENDMETHOD.                    "new_data

METHOD new_table.
ro_elem = new( type_abap_table ).
ro_elem->data = ref.
ENDMETHOD.                    "new_table

METHOD new_cons.
ro_cons = new( type = type_conscell
io_car = io_car
io_cdr = io_cdr ).
ENDMETHOD.                    "new_cons

METHOD new_lambda.
*      The lambda is a special cell that stores a pointer to a list of parameters
*      and a pointer to a list which is the body to be evaluated later on
ro_lambda = new( type = type_lambda
io_car = io_car                         " List of parameters
io_cdr = io_cdr ).                      " Body
*      Store the reference to the environment in which the lambda was created
*      (lexical scope) e.g. if the lambda is created inside another lambda
*      we want that environment to be present when we evaluate the new lambda
ro_lambda->environment = io_env.
ENDMETHOD.                    "new_lambda

METHOD list_to_string.
DATA lo_elem TYPE REF TO lcl_lisp.

str = c_open_paren.
lo_elem = me.
WHILE ( lo_elem IS BOUND AND lo_elem NE nil ).
IF lo_elem->type NE type_conscell.               " If item is not a cons cell,
str = |{ str } . { lo_elem->to_string( ) }|.   " indicate with dot notation:
ELSE.
str = |{ str } { lo_elem->car->to_string( ) }|.
ENDIF.
lo_elem = lo_elem->cdr.
ENDWHILE.

str = |{ str } { c_close_paren }|.
ENDMETHOD.                    "list_to_string

METHOD to_string.
CASE type.
WHEN type_lambda.
str = |<lambda> { car->list_to_string( ) }|.
WHEN type_symbol.
str = value.
WHEN type_string.
*        TODO: Other Lisp REPLs give back the string as a quoted string
str = value.
WHEN type_number.
str = number.
WHEN lcl_lisp=>type_native.
str = '<native>'.
WHEN type_conscell.
str = list_to_string( ).
WHEN type_hash.
str = '<hash>'.
*--------------------------------------------------------------------*
WHEN type_abap_function.
str = |<ABAP function module { value }>|.
WHEN type_abap_class.
str = |<ABAP class { value }>|.
WHEN type_abap_method.
*          TODO
*           str = |<ABAP method { car->value }->{ cdr->value }( ) >|.
WHEN type_abap_data.
str = |<ABAP Data>|.
WHEN type_abap_table.
str = |<ABAP Table>|.
ENDCASE.
ENDMETHOD.                    "to_string

METHOD throw.
RAISE EXCEPTION TYPE lcx_lisp_eval_err
EXPORTING
message = message.
ENDMETHOD.                    "eval_err

ENDCLASS.                    "lcl_lisp IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_iterator IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp_iterator IMPLEMENTATION.

METHOD new.
IF io_elem IS NOT BOUND.
lcl_lisp=>throw( |Iterator: Invalid head of list| ).
ENDIF.
CREATE OBJECT ro_iter.
ro_iter->elem = io_elem.
ro_iter->first = abap_true.
ENDMETHOD.                    "new

METHOD has_next.
rv_flag = boolc( first EQ abap_true
OR ( elem->cdr IS BOUND AND elem->cdr NE lcl_lisp=>nil ) ).
ENDMETHOD.                    "has_next

METHOD next.
IF first EQ abap_true.
first = abap_false.
ELSE.
IF elem->cdr->type NE lcl_lisp=>type_conscell.
lcl_lisp=>throw( |{ elem->to_string( ) } is not a proper list| ).
ENDIF.
elem = elem->cdr.
ENDIF.
ro_elem = elem->car.
ENDMETHOD.                    "next

ENDCLASS.                    "lcl_lisp_iterator IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS lcl_lisp_hash IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_lisp_hash IMPLEMENTATION.

METHOD new_hash.
DATA lo_iter TYPE REF TO lcl_lisp_iterator.
DATA lo_ptr TYPE REF TO lcl_lisp.
DATA ls_entry TYPE ts_hash.

validate: list, list->car.
ro_elem ?= new( type_hash ).
CHECK list->car->type = type_conscell.

*      Can accept a parameter which should be a list of alternating symbols/strings and elements
lo_iter = lcl_lisp_iterator=>new( list->car ).
WHILE lo_iter->has_next( ) EQ abap_true.
lo_ptr = lo_iter->next( ).
IF lo_ptr->type NE type_symbol AND lo_ptr->type NE type_string.
throw( |MAKE-HASH: Use only symbol or string as a key| ).
ENDIF.
CHECK lo_iter->has_next( ) EQ abap_true.
ls_entry-key = lo_ptr->value.
ls_entry-element = lo_iter->next( ).
INSERT ls_entry INTO TABLE ro_elem->hash.
ENDWHILE.
ENDMETHOD.                    "new_hash

METHOD get.
DATA ls_entry TYPE ts_hash.

validate: list, list->car.
IF list->car = nil.
throw( |HASH-GET requires a key to access an element| ).
ENDIF.

*      TODO: Additional check for key type
READ TABLE hash INTO ls_entry WITH KEY key = list->car->value.
IF sy-subrc = 0.
result = ls_entry-element.
ELSE.
result = nil.
ENDIF.
ENDMETHOD.                    "get

METHOD insert.
DATA ls_entry TYPE ts_hash.
validate: list, list->car, list->cdr.

* TODO: Check number and type of parameters
ls_entry-key = list->car->value.
ls_entry-element = list->cdr->car.
INSERT ls_entry INTO TABLE hash.
* TODO: Should we overwrite existing keys?
result = nil.
ENDMETHOD.                    "insert

METHOD delete.
validate: list, list->car.
* TODO: Check number and type of parameters
DELETE hash WHERE key = list->car->value.
result = nil.
ENDMETHOD.                    "delete

METHOD get_hash_keys.
DATA ls_entry TYPE ts_hash.
DATA lo_last TYPE REF TO lcl_lisp.
DATA lo_ptr TYPE REF TO lcl_lisp.

result = nil.
LOOP AT hash INTO ls_entry.
lo_last = new_cons( io_car = new_symbol( ls_entry-key ) ).

IF result EQ nil.
result = lo_ptr = lo_last.
ELSE.
lo_ptr = lo_ptr->cdr = lo_last.
ENDIF.
ENDLOOP.
ENDMETHOD.                    "get_hash_keys

METHOD from_list.
validate: list, list->car.
IF list->car->type NE type_hash.
throw( |{ msg } only works on hashes| ).
ENDIF.
ro_hash ?= list->car.
ENDMETHOD.                    "from_list

ENDCLASS.                    "lcl_lisp_hash IMPLEMENTATION
```
Error rendering macro 'code': Invalid value specified for parameter 'com.atlassian.confluence.ext.code.render.InvalidValueException'
```
*&---------------------------------------------------------------------*
*&  Include           YY_LISP_AUNIT
*&---------------------------------------------------------------------*
*& ported from ZUSR_LISP_TEST by JNN (www.informatik-dv.com)

*&---------------------------------------------------------------------*
*& https://github.com/mydoghasworms/abap-lisp
*& Tests for the Lisp interpreter written in ABAP
*& Copy and paste this code into a type 1 (report) program, making sure
*& the necessary dependencies are met
*&---------------------------------------------------------------------*
*& Martin Ceronio, martin.ceronio@infosize.co.za
*& June 2015
*&---------------------------------------------------------------------*
*
*  Copyright (c) 2015 Martin Ceronio
*
*  Permission is hereby granted, free of charge, to any person obtaining a copy
*  of this software and associated documentation files (the "Software"), to deal
*  in the Software without restriction, including without limitation the rights
*  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
*  copies of the Software, and to permit persons to whom the Software is
*  furnished to do so, subject to the following conditions:
*
*  The above copyright notice and this permission notice shall be included in
*  all copies or substantial portions of the Software.
*
*  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
*  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
*  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
*  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
*  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
*  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
*  THE SOFTWARE.

*----------------------------------------------------------------------*
*       CLASS lcl_output_port DEFINITION
*----------------------------------------------------------------------*
CLASS lcl_output_port DEFINITION.
PUBLIC SECTION.
CLASS-METHODS new
RETURNING value(ro_port) TYPE REF TO lcl_output_port.
INTERFACES lif_port.
ALIASES write FOR lif_port~write.
METHODS get RETURNING value(rv_text) TYPE string.
PRIVATE SECTION.
DATA print_offset TYPE i.
DATA buffer TYPE string.

METHODS writeln IMPORTING text TYPE string.
METHODS add IMPORTING text TYPE string.
ENDCLASS.

*----------------------------------------------------------------------*
*       CLASS lcl_output_port  IMPLEMENTATION
*----------------------------------------------------------------------*
CLASS lcl_output_port IMPLEMENTATION.

METHOD new.
CREATE OBJECT ro_port.
ENDMETHOD.                    "new

METHOD get.
rv_text = buffer.
ENDMETHOD.                    "get

buffer = buffer && text.

METHOD writeln.
add( |\n{ repeat( val = ` ` occ = print_offset ) }{ text }| ).
ENDMETHOD.                    "writeln

* Write out a given element
METHOD write.
DATA lo_elem TYPE REF TO lcl_lisp.
CHECK element IS BOUND.

CASE element->type.
WHEN lcl_lisp=>type_conscell.
writeln( `(` ).
lo_elem = element.
DO.
write( lo_elem->car ).
SUBTRACT 2 FROM print_offset.
IF lo_elem->cdr IS NOT BOUND OR lo_elem->cdr EQ lcl_lisp=>nil.
EXIT.
ENDIF.
lo_elem = lo_elem->cdr.
ENDDO.
WHEN lcl_lisp=>type_number OR lcl_lisp=>type_symbol.
add( ` ` && element->value ).
ENDCASE.
ENDMETHOD.                    "write

ENDCLASS.                    "lcl_console IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_interpreter DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_interpreter DEFINITION FOR TESTING
RISK LEVEL HARMLESS DURATION SHORT.
PROTECTED SECTION.
"    DATA code TYPE string.
DATA mo_int TYPE REF TO lcl_lisp_interpreter.
*   Initialize Lisp interpreter
METHODS test IMPORTING title TYPE string
code TYPE string
actual    TYPE any
expected  TYPE any
level TYPE aunit_level.
METHODS test_f IMPORTING title TYPE string
code TYPE string
actual    TYPE numeric
expected  TYPE numeric.

METHODS code_test IMPORTING code     TYPE string
expected TYPE any
level TYPE aunit_level
DEFAULT if_aunit_constants=>critical.
METHODS code_test_f IMPORTING code     TYPE string
expected TYPE numeric.

METHODS riff_shuffle_code RETURNING value(code) TYPE string.

PRIVATE SECTION.
METHODS setup.
METHODS teardown.

*   Stability tests - No Dump should occur
METHODS stability_1 FOR TESTING.
METHODS stability_2 FOR TESTING.
*--------------------------------------------------------------------*
*   BASIC TESTS
METHODS: basic_define_error FOR TESTING,
basic_define_a_23 FOR TESTING,
*     Test strings
basic_string_value FOR TESTING,
basic_string_esc_double_quote FOR TESTING,
basic_string_quot_esc_dbl_quot FOR TESTING,

*     Evaluating multiple expressions
basic_multiple_expr FOR TESTING.
ENDCLASS.                    "ltc_interpreter DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_interpreter IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_interpreter IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

* Conduct a test with given code
METHOD test.
cl_abap_unit_assert=>assert_equals(
act = actual
exp = expected
msg = |Error { title } :{ code }\nActual : { actual }\nExpected :{ expected }\n|
level = level ).

*    write:/ '<- ', code.
*    write:/ '-> ', actual.
ENDMETHOD.                    "test

METHOD test_f.
cl_abap_unit_assert=>assert_equals_float(
act = actual
exp = expected
msg = |Error { title } :{ code }\n| ).
ENDMETHOD.                    "test_f

* Conduct a test with given code
METHOD code_test.
DATA lv_result TYPE string.
lv_result = mo_int->eval_source( code ).
test( code = code
actual = lv_result
expected = expected
title = 'CODE'
level = level ).
ENDMETHOD.                    "code_test

METHOD code_test_f.
DATA lv_result TYPE f.
lv_result = mo_int->eval_source( code ).
test_f( code = code
actual = lv_result
expected = expected
title = 'CODE' ).
ENDMETHOD.                    "code_test_f

METHOD stability_1.
code_test( code = 'a'
expected = `Eval: Symbol a is unbound` ).
ENDMETHOD.                    "stability_1

METHOD stability_2.
code_test( code = '(define a)'
expected = `Eval: Incorrect input` ).
ENDMETHOD.                    "stability_2

METHOD basic_define_error.
code_test( code = '(define 22 23)'
expected = `Eval: 22 cannot be a variable identifier` ).
ENDMETHOD.                    "basic_define_error

METHOD basic_define_a_23.
code_test( code = '(define a 23)'
expected = `a` ).
code_test( code = 'a'
expected = `23` ).
ENDMETHOD.                    "basic_define_a_23

METHOD basic_string_value.
code_test( code = '"string value"'
expected = `string value` ).
ENDMETHOD.                    "basic_string_value

METHOD basic_string_esc_double_quote.
code_test( code = '"string value with \" escaped double quote"'
expected = 'string value with \" escaped double quote' ).
ENDMETHOD.                    "basic_string_esc_double_quote

METHOD basic_string_quot_esc_dbl_quot.
code_test( code = '(quote "string value with \" escaped double quote")'
expected = 'string value with \" escaped double quote' ).
ENDMETHOD.                    "basic_string_quot_esc_dbl_quot

METHOD basic_multiple_expr.
*   Evaluating multiple expressions
code_test( code = '(define a (list 1 2 3 4)) (define b (cdr a)) a b'
expected = 'a b ( 1 2 3 4 ) ( 2 3 4 )' ).
ENDMETHOD.                    "basic_multiple_expr

METHOD riff_shuffle_code.
code =
|(define riff-shuffle | &
| ( lambda (deck) (begin | &
| (define take | &
| (lambda (n seq) (if (<= n 0) (quote ()) (cons (car seq) (take (- n 1) (cdr seq)))))) | &
| (define drop | &
| (lambda (n seq) (if (<= n 0) seq (drop (- n 1) (cdr seq)))))| &
| (define mid | &
| (lambda (seq) (/ (length seq) 2)))| &
| ((combine append) (take (mid deck) deck) (drop (mid deck) deck))| &
| )))|.
ENDMETHOD.                    "riff_shuffle_code

ENDCLASS.                    "ltc_interpreter IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_parse DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_parse DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
DATA output TYPE REF TO lcl_output_port.

METHODS setup.
METHODS teardown.
METHODS parse IMPORTING code TYPE string.
METHODS parse_test IMPORTING code     TYPE string
expected TYPE string
level TYPE aunit_level DEFAULT if_aunit_constants=>critical.
METHODS empty FOR TESTING.
METHODS lambda FOR TESTING.
METHODS riff_shuffle FOR TESTING.
ENDCLASS.                    "ltc_parse DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_parse IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_parse IMPLEMENTATION.

METHOD setup.
CREATE OBJECT output.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE output.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD parse.
DATA elements TYPE lcl_lisp_interpreter=>tt_element.
DATA element TYPE REF TO lcl_lisp.

elements = mo_int->parse( code ).
cl_abap_unit_assert=>assert_not_initial(
act = lines( elements )
msg = |No evaluated element from first expression| ).

READ TABLE elements INDEX 1 INTO element.
output->write( element ).
ENDMETHOD.                    "parse

* Test parsing of a given piece of code and write out result
METHOD parse_test.
parse( code ).
test( actual = output->get( )
code = code
expected = expected
title = 'PARSE'
level = level ).
ENDMETHOD.                    "parse_test

METHOD empty.
parse_test( code = ''
expected = | nil| ).
ENDMETHOD.                    "lambda

METHOD lambda.
parse_test( code = '(define a(lambda()20))'
expected = |\n( define a\n  ( lambda nil  ) )| ).
ENDMETHOD.                    "lambda

parse_test( code = |;; Comments\n| &
expected = |\n( define a\n  ( lambda nil  ) )| ).
ENDMETHOD.                    "lambda

METHOD riff_shuffle.
parse_test( code = riff_shuffle_code( )
expected =
|\n( define riff-shuffle\n  ( lambda\n    ( deck )\n    ( begin\n      ( define take\n        ( lambda| &
|\n          ( n seq )\n          ( if\n            ( <= n  )\n            ( quote nil )\n            ( cons| &
|\n              ( car seq )\n              ( take\n                ( - n  )\n                ( cdr seq ) ) ) ) ) )| &
|\n      ( define drop\n        ( lambda\n          ( n seq )\n          ( if\n            ( <= n  ) seq| &
|\n            ( drop\n              ( - n  )\n              ( cdr seq ) ) ) ) )\n      ( define mid\n| &
|        ( lambda\n          ( seq )\n          ( /\n            ( length seq )  ) ) )\n      (\n| &
|        ( combine append )\n        ( take\n          ( mid deck ) deck )\n        ( drop| &
|\n          ( mid deck ) deck ) ) ) ) )|
).
ENDMETHOD.                    "riff_shuffle

ENDCLASS.                    "ltc_parse IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_basic DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_basic DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.

METHODS setup.
METHODS teardown.

METHODS quote_19 FOR TESTING.
METHODS quote_a FOR TESTING.
METHODS quote_symbol_19 FOR TESTING.
METHODS quote_symbol_a FOR TESTING.
METHODS quote_list123 FOR TESTING.

METHODS set_1 FOR TESTING.
METHODS set_2 FOR TESTING.
METHODS set_3 FOR TESTING.

METHODS let_1 FOR TESTING.
METHODS let_2 FOR TESTING.
METHODS let_3 FOR TESTING.

METHODS letrec_1 FOR TESTING.

METHODS is_symbol_true FOR TESTING.
METHODS is_symbol_false FOR TESTING.
METHODS is_hash_true FOR TESTING.
METHODS is_hash_false FOR TESTING.
METHODS is_procedure_true FOR TESTING.
METHODS is_procedure_true_1 FOR TESTING.
METHODS is_procedure_true_2 FOR TESTING.
METHODS is_procedure_false FOR TESTING.
METHODS is_string_true FOR TESTING.
METHODS is_string_false FOR TESTING.
METHODS is_number_true FOR TESTING.
METHODS is_number_false FOR TESTING.

ENDCLASS.                    "ltc_basic DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_basic IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_basic IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD quote_19.
code_test( code = '(quote 19)'
expected = '19' ).
ENDMETHOD.                    "quote_19

METHOD quote_a.
code_test( code = '(quote a)'
expected = 'a' ).
ENDMETHOD.                    "quote_a

METHOD quote_symbol_19.
code_test( code = '''19'
expected = '19' ).
ENDMETHOD.                    "quote_symbol_19

METHOD quote_symbol_a.
code_test( code = '''a'
expected = 'a' ).
ENDMETHOD.                    "quote_symbol_a

METHOD quote_list123.
code_test( code = '''(list 1 2 3)'
expected = '( list 1 2 3 )' ).
ENDMETHOD.                    "quote_list123

METHOD set_1.
code_test( code = '(define x 3)'
expected = 'x' ).
code_test( code = '(set! x 7)'
expected = 'x' ).
code_test( code = 'x'
expected = '7' ).
ENDMETHOD.                    "set_1

METHOD set_2.
code_test( code = '(set! x 5)'
expected = 'Eval: Symbol x is unbound' ).
ENDMETHOD.                    "set_2

METHOD set_3.
code_test( code = '(define *seed* 1)'
expected = '*seed*' ).
code_test( code = |(define (srand seed)| &
|(set! *seed* seed)| &
|*seed*)|
expected = 'srand' ).
code_test( code = '(srand 2)'
expected = '2' ).
ENDMETHOD.

METHOD let_1.
code_test( code = '(let ((x 4) (y 5)) (+ x y))'
expected = '9' ).
ENDMETHOD.                    "let_1

METHOD let_2.
code_test( code = |(let ((x 2) (y 3))| &
|  (let ((foo (lambda (z) (+ x y z)))| &
|        (x 7))| &
|    (foo 4)))|
expected = '9' ).
ENDMETHOD.

METHOD let_3.
*      not allowed if we strictly follow the Scheme standard
code_test( code = |(let ((x 2) (x 0))| &
|    (+ x 5))|
expected = '5' ).
ENDMETHOD.

METHOD letrec_1.
code_test( code = '(define (not x) (if (eq? x #f) #t #f) )'
expected = 'not' ).
code_test( code = |(letrec ((is-even? (lambda (n)| &
|                     (or (zero? n)| &
|                         (is-odd? (- n 1)))))| &
|         (is-odd? (lambda (n)| &
|                     (and (not (zero? n))| &
|                          (is-even? (- n 1))))) )| &
|(is-odd? 11))|
expected = 'true' ).
ENDMETHOD.

METHOD is_symbol_true.
code_test( code = |(define x 5)|
expected = 'x' ).
code_test( code = |(symbol? 'x)|
expected = 'true' ).
code_test( code = |(symbol? x)|
expected = 'false' ).
ENDMETHOD.

METHOD is_symbol_false.
code_test( code = |(symbol? 4)|
expected = 'false' ).
ENDMETHOD.

METHOD is_hash_true.
code_test( code = |(define h (make-hash '(dog 4 car 5))|
expected = 'h' ).
code_test( code = |(hash? h)|
expected = 'true' ).
ENDMETHOD.

METHOD is_hash_false.
code_test( code = |(hash? 5)|
expected = 'false' ).
ENDMETHOD.

METHOD is_procedure_true.
code_test( code = |(define (fn x) (+ x 5))|
expected = 'fn' ).
code_test( code = |(procedure? fn)|
expected = 'true' ).
ENDMETHOD.

METHOD is_procedure_true_1.
code_test( code = |(procedure? car)|
expected = 'true' ).
code_test( code = |(procedure? 'car)|
expected = 'false' ).
ENDMETHOD.

METHOD is_procedure_true_2.
code_test( code = |(procedure? (lambda (x) (* x x)))|
expected = 'true' ).
code_test( code = |(procedure? '(lambda (x) (* x x)))|
expected = 'false' ).
ENDMETHOD.

METHOD is_procedure_false.
code_test( code = |(define x 5)|
expected = 'x' ).
code_test( code = |(procedure? x)|
expected = 'false' ).
ENDMETHOD.

METHOD is_string_true.
code_test( code = |(define txt "Badenkop")|
expected = 'txt' ).
code_test( code = |(string? txt)|
expected = 'true' ).
ENDMETHOD.

METHOD is_string_false.
code_test( code = |(string? 34)|
expected = 'false' ).
ENDMETHOD.

METHOD is_number_true.
code_test( code = |(define n 5)|
expected = 'n' ).
code_test( code = |(number? n)|
expected = 'true' ).
ENDMETHOD.

METHOD is_number_false.
code_test( code = |(define d "5")|
expected = 'd' ).
code_test( code = |(number? d)|
expected = 'false' ).
ENDMETHOD.

ENDCLASS.                    "ltc_basic IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_functional_tests DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_functional_tests DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS combine.
*   COMBINE + ZIP
METHODS functional_combine_zip FOR TESTING.

METHODS functional_compose FOR TESTING.

METHODS functional_fact_accum FOR TESTING.

ENDCLASS.                    "ltc_functional_tests DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_functional_tests IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_functional_tests IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD combine.
code_test( code = '(define combine (lambda (f) (lambda (x y) (if (nil? x) (quote ()) (f (list (car x) (car y)) ((combine f) (cdr x) (cdr y)))))))'
expected = 'combine' ).
ENDMETHOD.                    "combine

* COMBINE + ZIP
METHOD functional_combine_zip.
combine( ).
code_test( code = '(define zip (combine cons))'
expected = 'zip' ).
code_test( code = 'zip'
expected = '<lambda> ( x y )' ).
code_test( code = '(zip (list 1 2 3 4) (list 5 6 7 8))'
expected = '( ( 1 5 ) ( 2 6 ) ( 3 7 ) ( 4 8 ) )' ).
ENDMETHOD.                    "functional_combine_zip

METHOD functional_compose.
combine( ).
code_test( code = '(define compose (lambda (f g) (lambda (x) (f (g x)))))'
expected = 'compose' ).
code_test( code = '(define repeat (lambda (f) (compose f f)))'
expected = 'repeat' ).
code_test( code = riff_shuffle_code( )
expected = 'riff-shuffle' ).
code_test( code = '(riff-shuffle (list 1 2 3 4 5 6 7 8))'
expected = '( 1 5 2 6 3 7 4 8 )' ).
code_test( code = '((repeat riff-shuffle) (list 1 2 3 4 5 6 7 8))'
expected = '( 1 3 5 7 2 4 6 8 )' ).
code_test( code = '(riff-shuffle (riff-shuffle (riff-shuffle (list 1 2 3 4 5 6 7 8))))'
expected = '( 1 2 3 4 5 6 7 8 )' ).
ENDMETHOD.                    "functional_compose

METHOD functional_fact_accum.
code_test( code = '(define (fact x) (define (fact-tail x accum) (if (= x 0) accum (fact-tail (- x 1) (* x accum)))) (fact-tail x 1))'
expected = 'fact' ).
code_test( code = '(fact 8)' "FIXME: returns fact-tail
expected = '40320' ).
ENDMETHOD.                    "functional_fact_accum

ENDCLASS.                    "ltc_functional_tests IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_math DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_math DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS math_mult_1 FOR TESTING.
METHODS math_mult_2 FOR TESTING.
METHODS math_mult_3 FOR TESTING.

METHODS math_subtract_1 FOR TESTING.
METHODS math_subtract_2 FOR TESTING.
METHODS math_subtract_3 FOR TESTING.

METHODS math_division_1 FOR TESTING.
METHODS math_division_2 FOR TESTING.
METHODS math_division_3 FOR TESTING.
METHODS math_division_4 FOR TESTING.

METHODS math_sin FOR TESTING.
METHODS math_cos FOR TESTING.
METHODS math_tan FOR TESTING.
METHODS math_sinh_1 FOR TESTING.
METHODS math_cosh_1 FOR TESTING.
METHODS math_tanh_1 FOR TESTING.

METHODS math_sinh FOR TESTING.
METHODS math_cosh FOR TESTING.
METHODS math_tanh FOR TESTING.
METHODS math_asinh FOR TESTING.
METHODS math_acosh FOR TESTING.
METHODS math_atanh FOR TESTING.
METHODS math_asin FOR TESTING.
METHODS math_acos FOR TESTING.
METHODS math_atan FOR TESTING.

METHODS math_exp FOR TESTING.
METHODS math_expt FOR TESTING.
METHODS math_expt_1 FOR TESTING.
METHODS math_sqrt FOR TESTING.
METHODS math_log FOR TESTING.

METHODS math_floor FOR TESTING.
METHODS math_ceiling FOR TESTING.
METHODS math_truncate FOR TESTING.
METHODS math_round FOR TESTING.

METHODS math_remainder FOR TESTING.
METHODS math_modulo FOR TESTING.

ENDCLASS.                    "ltc_math DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_math IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_math IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

code_test( code = '(+ 22 24 25)'
expected = '71' ).

METHOD math_mult_1.
*   Test multiplication
code_test( code = '(* 22)'
expected = '22' ).
ENDMETHOD.                    "math_mult_1

METHOD math_mult_2.
code_test( code = '(* 11 12)'
expected = '132' ).
ENDMETHOD.                    "math_mult_2

METHOD math_mult_3.
code_test( code = '(* 11 12 13)'
expected = '1716' ).
ENDMETHOD.                    "math_mult_3

METHOD math_subtract_1.
code_test( code = '(- 22)'
expected = '-22' ).
ENDMETHOD.                    "math_subtract_1

METHOD math_subtract_2.
code_test( code = '(- 22 23 24)'
expected = '-25' ).
ENDMETHOD.                    "math_subtract_2

METHOD math_subtract_3.
code_test( code = '(- (- (- (- (- 5 1) 1) 1) 1) 1)'
expected = '0' ).
ENDMETHOD.                    "math_subtract_3

METHOD math_division_1.
*   Test division
code_test( code = '(/ 2)'
expected = '0.5' ).
ENDMETHOD.                    "math_division_1

METHOD math_division_2.
code_test( code =  '(/ 10)'
expected = '0.1' ).
ENDMETHOD.                    "math_division_2

METHOD math_division_3.
code_test( code =  '(/ 5 10)'
expected = '0.5' ).
ENDMETHOD.                    "math_division_3

METHOD math_division_4.
code_test_f( code =  '(/ 11 12 13)'
expected = '0.07051282051282051282051282051282052' ).
ENDMETHOD.                    "math_division_4

METHOD math_sin.
code_test( code =  '(sin 0)'
expected = '0' ).
ENDMETHOD.                    "math_sin

METHOD math_cos.
code_test( code =  '(cos 0)'
expected = '1' ).
ENDMETHOD.                    "math_cos

METHOD math_tan.
code_test( code =  '(tan 0)'
expected = '0' ).
ENDMETHOD.                    "math_tan

METHOD math_sinh.
code_test( code =  '(sinh 0)'
expected = '0' ).
ENDMETHOD.                    "math_sinh

METHOD math_cosh.
code_test( code =  '(cosh 0)'
expected = '1' ).
ENDMETHOD.                    "math_cosh

METHOD math_tanh.
code_test( code =  '(tanh 0)'
expected = '0' ).
ENDMETHOD.                    "math_tanh

METHOD math_sinh_1.
code_test_f( code =  '(sinh 0.5)'
expected = '0.52109530549374736162242562641149' ).
ENDMETHOD.                    "math_sinh_1

METHOD math_cosh_1.
code_test_f( code =  '(cosh 1)'
expected = '1.5430806348152437784779056207571' ).
ENDMETHOD.                    "math_cosh_1

METHOD math_tanh_1.
code_test_f( code =  '(tanh 1)'
expected = '0.76159415595576488811945828260479' ).
ENDMETHOD.                    "math_tanh_1

METHOD math_asinh.
code_test_f( code =  '(asinh 0)'
expected = 0 ).
ENDMETHOD.                    "math_asinh

METHOD math_acosh.
code_test_f( code =  '(acosh 1)'
expected = 0 ).
ENDMETHOD.                    "math_acosh

METHOD math_atanh.
code_test_f( code =  '(atanh 0)'
expected = 0 ).
ENDMETHOD.                    "math_atanh

METHOD math_asin.
code_test_f( code =  '(asin 1)'
expected = '1.5707963267948966192313216916398' ).
ENDMETHOD.                    "math_asin

METHOD math_acos.
code_test_f( code =  '(acos 0)'
expected = '1.5707963267948966192313216916398' ).
ENDMETHOD.                    "math_acos

METHOD math_atan.
code_test_f( code =  '(atan 1)'
expected = '0.78539816339744830961566084581988' ).
ENDMETHOD.                    "math_atan

METHOD math_exp.
code_test_f( code =  '(exp 2)'
expected = '7.389056098930650227230427460575' ).
ENDMETHOD.                    "math_exp

METHOD math_expt.
code_test( code =  '(expt 2 10)'
expected = '1024' ).
code_test_f( code =  '(expt 2 0.5)'
expected = '1.4142135623730950488016887242097' ).
ENDMETHOD.                    "math_expt

METHOD math_expt_1.
code_test( code =  '(exp 2 10)'
expected = 'Eval: ( 2 10 ) Parameter mismatch' ).
ENDMETHOD.                    "math_expt_1

METHOD math_sqrt.
code_test_f( code =  '(sqrt 2)'
expected = '1.4142135623730950488016887242097' ).
ENDMETHOD.                    "math_sqrt

METHOD math_log.
code_test_f( code =  '(log 7.389056)'
expected = '1.999999986611192' ).
ENDMETHOD.                    "math_log

METHOD math_floor.
"(floor x) - This returns the largest integer that is no larger than x.
code_test( code =  '(floor 7.3890560989306504)'
expected = '7' ).
ENDMETHOD.                    "math_floor

METHOD math_ceiling.
"(ceiling x) - This returns the smallest integer that is no smaller than x.
code_test( code =  '(ceiling 1.4142135623730951)'
expected = '2' ).
ENDMETHOD.                    "math_ceiling

METHOD math_truncate.
"(truncate x) - returns the integer value closest to x that is no larger than the absolute value of x.
code_test( code =  '(truncate -2.945)'
expected = '-2' ).
ENDMETHOD.                    "math_truncate

METHOD math_round.
"(round x) -
*   This rounds value of x to the nearest integer as is usual in mathematics.
*   It even works when halfway between values.
code_test( code =  '(round 7.389056)'
expected = '7' ).
code_test( code =  '(round 7.789056)'
expected = '8' ).
code_test( code =  '(round -7.789056)'
expected = '-8' ).
ENDMETHOD.                    "math_round

METHOD math_remainder.
code_test( code =  '(remainder 5 4)'
expected = '1' ).
code_test( code =  '(remainder -5 4)'
expected = '-1' ).
code_test( code =  '(remainder 5 -4)'
expected = '1' ).
code_test( code =  '(remainder -5 -4)'
expected = '-1' ).
ENDMETHOD.                    "math_remainder

METHOD math_modulo.
code_test( code =  '(modulo 5 4)'
expected = '1' ).
code_test( code =  '(modulo -5 4)'
expected = '3' ).
code_test( code =  '(modulo 5 -4)'
expected = '-3' ).
code_test( code =  '(modulo -5 -4)'
expected = '-1' ).
ENDMETHOD.                    "math_modulo

ENDCLASS.                    "ltc_math IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_list DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_list DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS is_list_1 FOR TESTING.
METHODS is_list_2 FOR TESTING.
METHODS is_list_3 FOR TESTING.
METHODS is_list_4 FOR TESTING.

METHODS list_nil_1 FOR TESTING.
METHODS list_nil_2 FOR TESTING.
METHODS list_test_1 FOR TESTING.
METHODS list_test_2 FOR TESTING.
METHODS list_append_1 FOR TESTING.
METHODS list_append_error FOR TESTING.
METHODS list_append_3 FOR TESTING.
METHODS list_append_arg_0 FOR TESTING.
METHODS list_append_arg_1 FOR TESTING.
METHODS list_append_arg_2 FOR TESTING.

METHODS list_length_0 FOR TESTING.
METHODS list_length_1 FOR TESTING.
METHODS list_length_2 FOR TESTING.

METHODS list_memq_0 FOR TESTING.
METHODS list_memq_1 FOR TESTING.
METHODS list_memq_2 FOR TESTING.
METHODS list_memq_3 FOR TESTING.

METHODS list_member FOR TESTING.
METHODS list_memv FOR TESTING.

*   CAR & CDR test
METHODS list_car_1 FOR TESTING.
METHODS list_cdr_1 FOR TESTING.
METHODS list_car_car_cdr FOR TESTING.
METHODS list_car_nil FOR TESTING.
METHODS list_car_list FOR TESTING.
METHODS list_cons_two_lists FOR TESTING.
METHODS list_cons_with_nil FOR TESTING.
METHODS list_cons_with_list FOR TESTING.
METHODS list_cons_two_elems FOR TESTING.
ENDCLASS.                    "ltc_list DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_list IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_list IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD is_list_1.
code_test( code = '(list? ''())'
expected = 'true' ).
ENDMETHOD.

METHOD is_list_2.
code_test( code = '(list? ''(1))'
expected = 'true' ).
ENDMETHOD.

METHOD is_list_3.
code_test( code = '(list? 1)'
expected = 'false' ).
ENDMETHOD.

METHOD is_list_4.
code_test( code = '(define x (append ''(1 2) 3))'
expected = 'x' ).
code_test( code = '(list? x)'
expected = 'false' ).
ENDMETHOD.

METHOD list_nil_1.
*  Test list
code_test( code = '(list ())'
expected = 'nil' ).
ENDMETHOD.                    "list_nil_1

METHOD list_nil_2.
code_test( code = '(list nil)'
expected = '( nil )' ).
ENDMETHOD.                    "list_nil_2

METHOD list_test_1.
*   Test list
code_test( code = '(list 22 23 24)'
expected = '( 22 23 24 )' ).
ENDMETHOD.                    "list_test_1

METHOD list_test_2.
code_test( code = '(list 22 (list 23 24))'
expected = '( 22 ( 23 24 ) )' ).
ENDMETHOD.                    "list_test_2

METHOD list_append_1.
*   Test append
code_test( code = '(append (list 22 (list 23 24)) 23)'
expected = '( 22 ( 23 24 ) . 23 )' ).
ENDMETHOD.                    "list_append_1

METHOD list_append_error.
code_test( code = '(append (append (list 22 (list 23 24)) 23) 28)'  "Should give an error
expected = 'Eval: ( ( 23 24 ) . 23 ) is not a proper list' ).
ENDMETHOD.

METHOD list_append_3.
code_test( code = '(append (list 1) (list 2))'
expected = '( 1 2 )' ).
ENDMETHOD.                    "list_append_3

METHOD list_append_arg_0.
code_test( code = '(append)'
expected = 'Eval: Incorrect input' ).
ENDMETHOD.

METHOD list_append_arg_1.
code_test( code = '(append 3)'
expected = '3' ).
ENDMETHOD.

METHOD list_append_arg_2.
code_test( code = |(append '(3))|
expected = '( 3 )' ).
ENDMETHOD.

METHOD list_length_0.
*   Test length
code_test( code = '(length nil)'
expected = '0' ).
ENDMETHOD.                    "list_length_0

METHOD list_length_1.
*   Test length
code_test( code = '(length (list 21 22 23 24))'
expected = '4' ).
ENDMETHOD.                    "list_length_1

METHOD list_length_2.
code_test( code = '(length (list 22 (list 23 24)))'
expected = '2' ).
ENDMETHOD.                    "list_length_2

METHOD list_memq_0.
code_test( code = |(memq 'a '(a b c))|
expected = '( a b c )' ).
ENDMETHOD.

METHOD list_memq_1.
code_test( code = |(memq 'b '(a b c))|
expected = '( b c )' ).
ENDMETHOD.

METHOD list_memq_2.
code_test( code = |(memq 'a '(b c d))|
expected = 'false' ).
ENDMETHOD.

METHOD list_memq_3.
code_test( code = |(memq (list 'a) '(b (a) c))|
expected = 'false' ).
ENDMETHOD.

METHOD list_member.
code_test( code = |(member (list 'a)| &
|        '(b (a) c))|
expected = '( ( a ) c )' ).
ENDMETHOD.

METHOD list_memv.
code_test( code = |(memv 101 '(100 101 102))|
expected = '( 101 102 )' ).
ENDMETHOD.

* CAR & CDR test
METHOD list_car_1.
*   Test append
code_test( code = '(car (list 22 (list 23 24)))'
expected = '22' ).
ENDMETHOD.                    "list_car_1

METHOD list_cdr_1.
code_test( code = '(cdr (list 22 (list 23 24)))'
expected = '( ( 23 24 ) )' ).
ENDMETHOD.                    "list_cdr_1

METHOD list_car_car_cdr.
code_test( code = '(car (car (cdr (list 22 (list 23 24)))))'
expected = '23' ).
ENDMETHOD.                    "list_car_car_cdr

METHOD list_car_nil.
code_test( code = '(car nil)'
expected = 'nil' ).
ENDMETHOD.                    "list_car_nil

METHOD list_car_list.
code_test( code = '(car (list 1))'
expected = '1' ).
ENDMETHOD.                    "list_car_list

METHOD list_cons_two_lists.
*   Test CONS
code_test( code = '(cons (list 1 2) (list 3 4))'
expected = '( ( 1 2 ) 3 4 )' ).
ENDMETHOD.                    "list_cons_two_lists

METHOD list_cons_with_nil.
code_test( code = '(cons 1 nil)'
expected = '( 1 )' ).
ENDMETHOD.                    "list_cons_with_nil

METHOD list_cons_with_list.
code_test( code = '(cons 2 (list 3 4))'
expected = '( 2 3 4 )' ).
ENDMETHOD.                    "list_cons_with_list

METHOD list_cons_two_elems.
code_test( code = '(cons 2 3)'
expected = '( 2 . 3 )' ).
ENDMETHOD.                    "list_cons_two_elems

ENDCLASS.                    "ltc_list IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_library_function DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_library_function DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS abs FOR TESTING.
ENDCLASS.                    "ltc_library_function DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_library_function IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_library_function IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD abs.
code_test( code = |(define (abs n)| &
|  (if (< n 0)| &
|  (- n)| &
|  n) )|
expected = |abs| ).
code_test( code = |(abs -2)|
expected = |2| ).
code_test( code = |(abs 12)|
expected = |12| ).
code_test( code = |(abs 0)|
expected = |0| ).
ENDMETHOD.                    "abs

ENDCLASS.                    "ltc_library_function IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_higher_order DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_higher_order DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS fold_right RETURNING value(code) TYPE string.

METHODS foldr FOR TESTING.
METHODS foldl FOR TESTING.
METHODS map FOR TESTING.
METHODS filter FOR TESTING.
ENDCLASS.                    "ltc_higher_order DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_higher_order IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_higher_order IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD fold_right.
code = |(define (fold-right f init seq)| &
|  (if (null? seq)| &
|  init| &
|  (f (car seq)| &
|       (fold-right f init (cdr seq)))))|.
ENDMETHOD.                    "fold_right

METHOD foldr.
code_test( code = fold_right( )
expected = 'fold-right' ).
code_test( code = |(fold-right + 1 (list 1 2 3 7))|
expected = '14' ).
code_test( code = |(define (last lst)| &
|  (if (null? lst)| &
|    nil| &
|    (if (null? (cdr lst))| &
|      (car lst)| &
|      (last (cdr lst)) )| &
|  ))|
expected = 'last' ).
code_test( code = |(define (delete-adjacent-duplicates lst)| &
|  (fold-right (lambda (elem ret)| &
|                (if (equal? elem (car ret))| &
|                    ret| &
|                    (cons elem ret)))| &
|              (list (last lst))| &
|              lst))|
code_test( code = |(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))|
expected = |( 1 2 3 4 5 )| ).
ENDMETHOD.                    "foldr

METHOD foldl.
code_test( code = |(define (fold-left f init seq)| &
|  (if (null? seq)| &
|  init| &
|  (fold-left f| &
|             (f init (car seq))| &
|             (cdr seq))))|
expected = |fold-left| ).
code_test( code = |(fold-left + 0 (list 1 2 3))|
expected = '6' ).

code_test( code = |(define (reverse l)| &
|  (fold-left (lambda (i j)| &
|               (cons j i))| &
|               '()| &
|               l))|
expected = |reverse| ).
code_test( code = |(reverse (list 1 2 3))|
expected = '( 3 2 1 )' ).

ENDMETHOD.                    "foldl

METHOD map.
code_test( code = |(define (map f lst)| &
|  (if (null? lst)| &
|    '()| &
|    (cons (f (car lst)) (map f (cdr lst)))))|
expected = |map| ).
code_test( code = |(map (lambda (n) (+ n 3))| &
|     '(1 2 3 4 5) )|
expected = |( 4 5 6 7 8 )| ).
ENDMETHOD.                    "map

METHOD filter.
code_test( code = fold_right( )
expected = 'fold-right' ).
code_test( code = |(define (filter pred? lst)| &
|  (fold-right (lambda (x y) (if (pred? x)| &
|                                (cons x y)| &
|                                y) )| &
|              '() lst))|
expected = |filter| ).
code_test( code = |(filter (lambda (n) (> n 4))| &
|     '(1 2 3 4 5 7) )|
expected = |( 5 7 )| ).
ENDMETHOD.                    "filter

ENDCLASS.                    "ltc_higher_order IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_comparison DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_comparison DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS compa_gt_1 FOR TESTING.
METHODS compa_gt_2 FOR TESTING.
METHODS compa_gt_3 FOR TESTING.
METHODS compa_gt_4 FOR TESTING.

METHODS compa_gte_1 FOR TESTING.
METHODS compa_gte_2 FOR TESTING.
METHODS compa_gte_3 FOR TESTING.

METHODS compa_lte_1 FOR TESTING.
METHODS compa_lte_2 FOR TESTING.
METHODS compa_lte_3 FOR TESTING.

METHODS compa_equal_1 FOR TESTING.
METHODS compa_equal_2 FOR TESTING.
METHODS compa_equal_3 FOR TESTING.

METHODS compa_if_1 FOR TESTING.
METHODS compa_if_2 FOR TESTING.
METHODS compa_if_3 FOR TESTING.

METHODS compa_eq_1 FOR TESTING.
METHODS compa_eq_2 FOR TESTING.
METHODS compa_eq_3 FOR TESTING.

METHODS compa_nil_1 FOR TESTING.
METHODS compa_nil_2 FOR TESTING.
METHODS compa_nil_3 FOR TESTING.
METHODS compa_nil_4 FOR TESTING.

METHODS compa_string FOR TESTING.
ENDCLASS.                    "ltc_comparison DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_comparison IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_comparison IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD compa_gt_1.
*   Test GT
code_test( code = '(> 1 2)'
expected = 'false' ).
ENDMETHOD.                    "compa_gt_1

METHOD compa_gt_2.
code_test( code = '(> 2 1)'
expected = 'true' ).
ENDMETHOD.                    "compa_gt_2

METHOD compa_gt_3.
code_test( code = '(> 4 3 2 1)'
expected = 'true' ).
ENDMETHOD.                    "compa_gt_3

METHOD compa_gt_4.
code_test( code = '(> 4 3 2 2)'
expected = 'false' ).
ENDMETHOD.                    "compa_gt_4
*
METHOD compa_gte_1.
*   Test GTE
code_test( code = '(>= 2 2)'
expected = 'true' ).
ENDMETHOD.                    "compa_gte_1

METHOD compa_gte_2.
code_test( code = '(>= 4 3 3 2)'
expected = 'true' ).
ENDMETHOD.                    "compa_gte_2

METHOD compa_gte_3.
code_test( code = '(>= 1 4)'
expected = 'false' ).
ENDMETHOD.                    "compa_gte_3

METHOD compa_lte_1.
*   Test LT
code_test( code = '(< 1 2 3)'
expected = 'true' ).
ENDMETHOD.                    "compa_lte_1

METHOD compa_lte_2.
code_test( code = '(< 1 2 2)'
expected = 'false' ).
ENDMETHOD.                    "compa_lte_2

METHOD compa_lte_3.
code_test( code = '(< 3 1)'
expected = 'false' ).
ENDMETHOD.                    "compa_lte_3

METHOD compa_equal_1.
*   Test equal?
code_test( code = '(equal? 22 23)'
expected = 'false' ).
ENDMETHOD.                    "compa_equal_1

METHOD compa_equal_2.
code_test( code = '(equal? 22 22)'
expected = 'true' ).
ENDMETHOD.                    "compa_equal_2

METHOD compa_equal_3.
code_test( code = '(equal? (list 21) (list 21))'
expected = 'true' ).
ENDMETHOD.                    "compa_equal_3

METHOD compa_if_1.
*   Test IF
code_test( code = '(if 22 23)'
expected = '23' ).
ENDMETHOD.                    "compa_if_1

METHOD compa_if_2.
code_test( code = '(if (< 2 1) 23)'
expected = 'false' ).
ENDMETHOD.                    "compa_if_2

METHOD compa_if_3.
code_test( code = '(if (< 2 1) 23 24)'
expected = '24' ).
ENDMETHOD.                    "compa_if_3

METHOD compa_eq_1.
*      Test =
code_test( code = '(= 2 3)'
expected = 'false' ).
ENDMETHOD.                    "compa_eq_1

METHOD compa_eq_2.
code_test( code = '(= 3 3)'
expected = 'true' ).
ENDMETHOD.                    "compa_eq_2

METHOD compa_eq_3.
*      equality of many things
code_test( code = '(= (+ 3 4) 7 (+ 2 5))'
expected = 'true' ).
ENDMETHOD.                    "compa_eq_2

METHOD compa_nil_1.
*      Test nil?
code_test( code = '(nil? ())'
expected = 'Eval: Incorrect input' ).
ENDMETHOD.                    "compa_nil_1

METHOD compa_nil_2.
code_test( code = '(nil? nil)'
expected = 'true' ).
ENDMETHOD.                    "compa_nil_2

METHOD compa_nil_3.
code_test( code = '(nil? (cdr (list 1)))'
expected = 'true' ).
ENDMETHOD.                    "compa_nil_3

METHOD compa_nil_4.
code_test( code = '(nil? (cdr (list 1 2)))'
expected = 'false' ).
ENDMETHOD.                    "compa_nil_4

METHOD compa_string.
code_test( code = '(define str "A string")'
expected = 'str' ).
code_test( code = '(< str "The string")'
expected = 'Eval: A string is not a number [<]' ).
ENDMETHOD.                    "compa_string

ENDCLASS.                    "ltc_comparison IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_basic_functions DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_basic_functions DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS funct_lambda_0 FOR TESTING.
METHODS funct_lambda_1 FOR TESTING.
METHODS funct_lambda_2 FOR TESTING.

METHODS funct_fact FOR TESTING.

METHODS funct_arg_count FOR TESTING.
METHODS funct_arg_missing FOR TESTING.
ENDCLASS.                    "ltc_basic_functions DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_basic_functions IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_basic_functions IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD funct_lambda_0.
code_test( code = '(define (b n) (* 11 n))'
expected = 'b' ).
code_test( code = 'b'
expected = '<lambda> ( n )' ).
code_test( code = '(b 20)'
expected = '220' ).
ENDMETHOD.                    "funct_lambda_0

METHOD funct_lambda_1.
*   Test LAMBDA
code_test( code = '(define b (lambda (b) (* 10 b)))'
expected = 'b' ).
code_test( code = 'b'
expected = '<lambda> ( b )' ).
code_test( code = '(b 20)'
expected = '200' ).
ENDMETHOD.                    "funct_lambda_1

METHOD funct_lambda_2.
code_test( code = '((lambda (a) (+ a 20)) 10 )'
expected = '30' ).
ENDMETHOD.                    "funct_lambda_2

METHOD funct_fact.
*   Function shorthand
code_test( code = '(define (fact x) (if (= x 0) 1 (* x (fact (- x 1)))))'
expected = 'fact' ).
code_test( code = '(fact 8)'
expected = '40320' ).
ENDMETHOD.                    "funct_fact

METHOD funct_arg_count.
code_test( code = '(define (f x y) (+ x y))'
expected = 'f' ).
code_test( code = '(f 1 2 3)'
expected = 'Eval: Expected 2 parameter(s), found ( 1 2 3 )' ).
ENDMETHOD.                    "funct_arg_count

METHOD funct_arg_missing.
code_test( code = '(define (add x y) (+ x y))'
expected = 'Eval: Missing parameter(s) ( y )' ).
ENDMETHOD.                    "funct_arg_count

ENDCLASS.                    "ltc_basic_functions IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_hash_element DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_hash_element DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS hash FOR TESTING.
ENDCLASS.                    "ltc_hash_element DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_hash_element IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_hash_element IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD hash.
*   Hash implementation
code_test( code = '(define h1 (make-hash ''(dog "bow-wow" cat "meow" kennel (dog cat hedgehog))))'
expected = 'h1' ).
code_test( code = 'h1'
expected = '<hash>' ).
code_test( code = '(hash-keys h1)'
expected = '( dog cat kennel )' ).
code_test( code = '(hash-get h1 ''kennel)'
expected = '( dog cat hedgehog )' ).
code_test( code = '(hash-remove h1 ''kennel)'
expected = 'nil' ).
code_test( code = '(hash-get h1 ''sparrow)'
expected = 'nil' ).
code_test( code = '(hash-insert h1 ''sparrow "whoosh")'
expected = 'nil' ).
code_test( code = '(hash-get h1 ''sparrow)'
expected = 'whoosh' ).
code_test( code = '(hash-keys h1)'
expected = '( dog cat sparrow )' ).
ENDMETHOD.                    "hash

ENDCLASS.                    "ltc_hash_element IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_abap_integration DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_abap_integration DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.

METHODS abap_data_mandt FOR TESTING.
METHODS abap_data_t005g FOR TESTING.
METHODS empty_structure FOR TESTING.
METHODS user_name FOR TESTING.
ENDCLASS.                    "ltc_abap_integration DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_abap_integration IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_abap_integration IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

METHOD abap_data_mandt.
code_test( code = '(define mandt (ab-data "MANDT"))'
expected = 'mandt' ).
code_test( code = '(ab-set-value mandt "000")'
expected = 'nil' ).
code_test( code = 'mandt'
expected = '<ABAP Data>' ).
ENDMETHOD.                    "abap_data

METHOD abap_data_t005g.
code_test( code = '(define t005g (ab-data "T005G"))'
expected = 't005g' ).
code_test( code = '(ab-set t005g "LAND1" "ZA")'  " Set field "LAND1" to "ZA"
expected = 'nil' ).
code_test( code = '(ab-get t005g "LAND1")'       " Return the value of field "LAND1"
expected = 'ZA' ).
ENDMETHOD.                    "abap_data

METHOD empty_structure.
code_test( code = '(define t005g (ab-data "T005G"))'
expected = 't005g' ).
code_test( code = '(ab-set-value t005g ''("000" "ZA" "ABC" "JHB"))'
expected = 'nil' ).
code_test( code = '(ab-get-value t005g)'
expected = '( 000 ZA ABC JHB )' ).
code_test( code = '(ab-get t005g "LAND1")'
expected = 'ZA' ).
ENDMETHOD.                    "empty_structure

METHOD user_name.
DATA lv_uname TYPE string.
lv_uname = sy-uname.
code_test( code = '(ab-get ab-sy "UNAME")'
expected = lv_uname ).
ENDMETHOD.                    "user_name

ENDCLASS.                    "ltc_abap_integration IMPLEMENTATION

*----------------------------------------------------------------------*
*       CLASS ltc_abap_function_module DEFINITION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_abap_function_module DEFINITION INHERITING FROM ltc_interpreter
FOR TESTING RISK LEVEL HARMLESS DURATION SHORT.
PRIVATE SECTION.
METHODS setup.
METHODS teardown.
METHODS get_first_profile RETURNING value(rv_prof) TYPE xuprofile.

METHODS fm_user_info FOR TESTING.
METHODS fm_test_rfc FOR TESTING.
METHODS fm_user_details FOR TESTING.

ENDCLASS.                    "ltc_abap_function_module DEFINITION

*----------------------------------------------------------------------*
*       CLASS ltc_abap_function_module IMPLEMENTATION
*----------------------------------------------------------------------*
*
*----------------------------------------------------------------------*
CLASS ltc_abap_function_module IMPLEMENTATION.

METHOD setup.
CREATE OBJECT mo_int.
ENDMETHOD.                    "setup

METHOD teardown.
FREE mo_int.
ENDMETHOD.                    "teardown

CALL FUNCTION 'TH_USER_INFO'
IMPORTING

METHOD fm_user_info.
*;(let ( ( f1 (ab-function "TH_USER_INFO")  )  )
*;       ( begin (f1) (ab-get f1 "ADDRSTR")  )
code_test( code = '(ab-function "TH_USER_INFO")'
expected = '<ABAP function module TH_USER_INFO>' ).
code_test( code = '(define f1 (ab-function "TH_USER_INFO"))'
expected = 'f1' ).
code_test( code = '(f1)'
expected = '<ABAP function module TH_USER_INFO>' ).
code_test( code = '(ab-get f1 "ADDRSTR")'
ENDMETHOD.                    "fm_user_info

METHOD fm_test_rfc.
*; (let ( (f2 (ab-function "TH_TEST_RFC"))  )
*;        ( begin (ab-set f2 "TEXT_IN" "Calling from ABAP Lisp" )
*;                  (f2) (ab-get f2 "TEXT_OUT")  ) )
code_test( code = '(define f2 (ab-function "TH_TEST_RFC"))'
expected = 'f2' ).
code_test( code = '(ab-set f2 "TEXT_IN" "Calling from ABAP Lisp")'
expected = 'nil' ).
code_test( code = '(f2)'
expected = '<ABAP function module TH_TEST_RFC>' ).
code_test( code = '(ab-get f2 "TEXT_OUT")'
expected = 'Calling from ABAP Lisp' ).
ENDMETHOD.                    "fm_test_rfc

METHOD get_first_profile.
DATA lt_profiles TYPE STANDARD TABLE OF bapiprof.
DATA ls_profiles TYPE bapiprof.
DATA lt_return TYPE bapiret2_t.

CALL FUNCTION 'BAPI_USER_GET_DETAIL'
EXPORTING
TABLES
profiles = lt_profiles
return   = lt_return.

READ TABLE lt_profiles INDEX 1 INTO ls_profiles.
rv_prof = ls_profiles-bapiprof.
ENDMETHOD.                    "get_first_profile

METHOD fm_user_details.
*(let (( profiles
*        (let ( (f3 (ab-function "BAPI_USER_GET_DETAIL"))  )
*        ( begin (ab-set f3 "USERNAME" (ab-get ab-sy "UNAME") )
*                  (f3) (ab-get f3 "PROFILES")  ) )
*        ) )
*   (let ((profile (ab-get profiles 1)) )
*             (ab-get profile "BAPIPROF" )  )
*)
code_test( code = '(define f3 (ab-function "BAPI_USER_GET_DETAIL"))'
expected = 'f3' ).
code_test( code = '(ab-set f3 "USERNAME" (ab-get ab-sy "UNAME"))'
expected = 'nil' ).
code_test( code = '(f3)'
expected = '<ABAP function module BAPI_USER_GET_DETAIL>' ).
code_test( code = '(define profiles (ab-get f3 "PROFILES"))'
expected = 'profiles' ).
code_test( code = 'profiles'
expected = '<ABAP Table>' ).

code_test( code = '(define profile (ab-get profiles 1))'
expected = 'profile' ).
code_test( code = '(ab-get profile "BAPIPROF")'
expected = get_first_profile( ) ).
ENDMETHOD.                    "fm_user_details

ENDCLASS.                    "ltc_abap_function_module IMPLEMENTATION
```

That is all for now

### A Simple Game

Guess My Number
```;----------------------------------------------------------
;; guess my number between 1 and 100

(define *big* 100)
(define *small* 1)

(define (guess) (round (/ (+ *big* *small*) 2)) )
(define (larger) (set! *small* (+ 1 (guess))) (guess))
(define (smaller) (set! *big* (- (guess) 1)) (guess))

(define (restart) (set! *big* 100) (set! *small* 1) (guess))

; my number is 16 - the logic needs 7 steps
(restart)   ; 51
(smaller) ; 26
(smaller) ; 13
(larger)  ; 20
(smaller) ; 17
(smaller) ; 15
(larger)  ; 16