Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/DoubleOhSeven.pm @ 12511:1c41c70a24da draft default tip
<int-e> mkx ../bin/tio//<<<"$@" sed \'s=.*##==\' | tr @- ++ | base64 -d 2>/dev/null | cat <(printf "\\x1f\\x8b\\x08\\x00\\x00\\x00\\x00\\x00\\x00\\x00") - | gzip -dq 2>/dev/null | LC_CTYPE=C sed -zE \'s=.*\\xFF\\xFF(.*)\\xFF\\xFF.*=\\1=\'
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Sun, 04 Aug 2024 19:18:25 +0100 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::DoubleOhSeven; # Special version of Language::INTERCAL::Numbers used for "double-oh-seven" # registers # This file is part of CLC-INTERCAL # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. # CLC-INTERCAL is copyrighted software. However, permission to use, modify, # and distribute it is granted provided that the conditions set out in the # licence agreement are met. See files README and COPYING in the distribution. use strict; use vars qw($VERSION $PERVERSION); ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/DoubleOhSeven.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use Language::INTERCAL::Exporter '1.-94.-2'; use Language::INTERCAL::Splats '1.-94.-2', qw(:SP splatname); use Language::INTERCAL::Numbers '1.-94.-2'; use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(roman_type roman_name); use Language::INTERCAL::Charset '1.-94.-2', qw(charset charset_name); use Language::INTERCAL::ArrayIO '1.-94.-2', qw(iotype iotype_name); use vars qw(@ISA); @ISA = qw(Language::INTERCAL::Numbers::Spot); my %types = ( base => [2, \&_code_base, undef], charset => [0, \&_code_charset, \&_decode_charset], comefrom => [0, \&_code_comefrom, undef], crawlhorror => [1, \&_code_crawlhorror, undef], iotype => [0, \&_code_iotype, \&_decode_iotype], roman => [0, \&_code_roman, \&_decode_roman], splat => [1000, \&_code_splat, \&_decode_splat], spot => [0, undef, undef], symbol => [0, \&_code_symbol, \&_decode_symbol], zeroone => [0, \&_code_zeroone, undef], ); sub new { @_ == 3 || @_ == 4 or croak "Usage: Language::INTERCAL::DoubleOhSeven" . "->new(TYPE, OBJECT [,VALUE])"; my ($class, $type, $object, @value) = @_; exists $types{$type} or faint(SP_SPECIAL, "(type $type)"); @value = ($types{$type}[0]) unless @value; return Language::INTERCAL::Numbers::Spot->new(@value) if ! defined $types{$type}[1]; @value = &{$types{$type}[1]}($object, @value); # note, we don't use SUPER here, rather we rebless later my $num = Language::INTERCAL::Numbers::Spot->new(@value); $num->{doubleohseven} = { object => $object, type => $types{$type}[1], typename => $type, decode => $types{$type}[2], }; bless $num, $class; } sub type { @_ == 1 or croak "Usage: DOUBLEOHSEVEN->type"; my ($num) = @_; $num->{doubleohseven}{typename}; } sub print { @_ == 1 or croak "Usage: DOUBLEOHSEVEN->print"; my ($num) = @_; my $d = $num->{doubleohseven}; $d->{decode} or return $num->SUPER::print; &{$d->{decode}}($d->{object}, $num->number); } sub _assign { @_ == 2 or croak "Usage: DOUBLEOHSEVEN->assign(VALUE)"; my ($num, $value) = @_; exists $num->{doubleohseven} or faint(SP_NOSPECIAL); $num->{doubleohseven}{type} or faint(SP_NOSPECIAL); $value = &{$num->{doubleohseven}{type}}($num->{doubleohseven}{object}, $value); $num->SUPER::_assign($value); $num; } sub _get_number { my ($value, $translate, $splat) = @_; faint(SP_NOASSIGN, '(undef)', 'Not a number') if ! defined $value; return $value->spot->number if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers'); return $value if ! ref $value && defined $value && $value =~ /^\d+$/; if ($translate) { if (ref $value) { my @num = (); if (ref $value eq 'ARRAY') { @num = map { _get_number($_, $translate) } @$value; } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays')) { @num = map { $_->spot->number } $value->as_list; } else { faint(SP_NOASSIGN, $value, 'Not a number'); } $value = pack('C*', @num); } my $t = &{$translate}($value); defined $t or faint($splat, $value); return $t; } faint(SP_NOASSIGN, $value, 'Not a number'); } sub _decode { my ($value, $code) = @_; my $nv = $code->($value); return "?$nv" if defined $nv && $nv ne ''; "#$value"; } sub _code_base { my ($object, $value) = @_; $value = _get_number($value); $value < 2 || $value > 7 and faint(SP_BASE, $value); $value; } sub _code_charset { my ($object, $value) = @_; _get_number($value, \&charset, SP_CHARSET); } sub _decode_charset { my ($object, $value) = @_; _decode($value, \&charset_name); } sub _code_comefrom { my ($object, $value) = @_; $value = _get_number($value); $value < 0 || $value > 3 and faint(SP_NOASSIGN, $value, 'come from value must be between 0 and 3'); $value; } sub _code_crawlhorror { my ($object, $value) = @_; $object or faint(SP_CONTEXT, 'missing grammar'); my $c = _get_number($value); $c < 1 || $c > $object->num_parsers and faint(SP_NOASSIGN, $value, 'grammar number out of range'); $c; } sub _code_iotype { my ($object, $value) = @_; _get_number($value, \&iotype, SP_IOTYPE); } sub _decode_iotype { my ($object, $value) = @_; _decode($value, \&iotype_name); } sub _code_roman { my ($object, $value) = @_; _get_number($value, \&roman_type, SP_ROMAN); } sub _decode_roman { my ($object, $value) = @_; _decode($value, \&roman_name); } sub _code_splat { my ($object, $value) = @_; _get_number($value, \&_splat_type, SP_INVSPLAT); } sub _splat_type { my ($code) = @_; defined splatname($code) ? $code : 1000; } sub _decode_splat { my ($object, $value) = @_; $value < 1000 ? $value : undef; } sub _code_symbol { my ($object, $value) = @_; $object or faint(SP_CONTEXT, 'symbol without grammar'); _get_number($value, sub { $object->symboltable->find(@_) }, SP_SYMBOL); } sub _decode_symbol { my ($object, $value) = @_; _decode($value, sub { $object->symboltable->symbol(@_) } ); } sub _code_zeroone { my ($object, $value) = @_; $value = _get_number($value); $value < 0 || $value > 1 and faint(SP_NOASSIGN, $value, 'value must be 0 or 1'); $value; } 1;